From 9a8190e3dd6899ca1be16fa24172e842fcb16bd8 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 8 Sep 2022 10:10:01 +0200 Subject: Initial --- .gitignore | 1 + Main.hs | 25 +++++++++++++++++++++++++ repro.sh | 10 ++++++++++ sleep.sh | 2 ++ snap-efault.cabal | 19 +++++++++++++++++++ 5 files changed, 57 insertions(+) create mode 100644 .gitignore create mode 100644 Main.hs create mode 100755 repro.sh create mode 100755 sleep.sh create mode 100644 snap-efault.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..fa27ae7 --- /dev/null +++ b/Main.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import Control.Concurrent +import Control.Monad (replicateM_) +import Snap.Http.Server +import qualified System.Process as Pr + + +makeWorker :: IO () +makeWorker = do + _ <- forkIO $ do + Pr.withCreateProcess (Pr.proc "./sleep.sh" []) $ \_ _ _ _ -> do + threadDelay 1000000 + return () + +makePool :: Int -> IO () +makePool numWorkers = replicateM_ numWorkers makeWorker + +main :: IO () +main = do + nprocs <- getNumCapabilities + putStrLn $ "Starting worker with " ++ show nprocs ++ " threads (use +RTS -N to set)" + _ <- makePool nprocs + + httpServe defaultConfig (return ()) diff --git a/repro.sh b/repro.sh new file mode 100755 index 0000000..747601d --- /dev/null +++ b/repro.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash +exe=$(cabal list-bin snap-efault) +echo "Program: <$exe>" + +echo "Be ready to 'kill $$', because ^C tends to not work with 'timeout'" + +while true; do + echo -n "*" + timeout 0.4 "$exe" +RTS -N 2>&1 | grep spawnp +done diff --git a/sleep.sh b/sleep.sh new file mode 100755 index 0000000..ffd1820 --- /dev/null +++ b/sleep.sh @@ -0,0 +1,2 @@ +#!/bin/sh +sleep 10 diff --git a/snap-efault.cabal b/snap-efault.cabal new file mode 100644 index 0000000..5bb005c --- /dev/null +++ b/snap-efault.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.0 +name: snap-efault +synopsis: Stuff +version: 0.1.0.0 +license: MIT +author: Tom Smeding +maintainer: tom@tomsmeding.com +build-type: Simple + +executable snap-efault + main-is: + Main.hs + build-depends: + base >= 4.13 && < 4.15, + process >= 1.6.13.2 && < 1.7, + snap-server >= 1.1.1.2 && < 1.2 + hs-source-dirs: . + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded -- cgit v1.2.3-70-g09d2