@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP, BangPatterns #-}
22
33-- | A thread pool manager.
44-- The manager has responsibility to spawn and kill
@@ -20,42 +20,45 @@ import Control.Concurrent.STM
2020import Control.Monad (void)
2121import Data.Set (Set)
2222import qualified Data.Set as Set
23+import Data.Foldable
2324import Network.Wai.Handler.Warp.IORef
25+import Network.Wai.Handler.Warp.Settings
26+import qualified Network.Wai.Handler.Warp.Timeout as T
2427
2528----------------------------------------------------------------
2629
30+type Action = T.Manager -> IO ()
31+
2732data Command = Stop | Spawn | Replace ThreadId
2833
29−data Manager = Manager (TQueue Command) (IORef (IO ()))
34+data Manager = Manager (TQueue Command) (IORef Action)
3035
3136-- | Starting a thread pool manager.
3237-- Its action is initially set to 'return ()' and should be set
3338-- by 'setAction'. This allows that the action can include
3439-- the manager itself.
35−start :: IO Manager
36−start = do
37− tset <- newThreadSet
40+start :: Settings -> IO Manager
41+start set = do
3842 q <- newTQueueIO
39− ref <- newIORef (return ())
40− void $ forkIO $ go q tset ref
43+ ref <- newIORef (\_ -> return ())
44+ timmgr <- T.initialize $ settingsTimeout set * 1000000
45+ void $ forkIO $ go q Set.empty ref timmgr
4146 return $ Manager q ref
4247 where
43− go q tset ref = do
48+ go q !tset0 ref timmgr = do
4449 x <- atomically $ readTQueue q
4550 case x of
46− Stop -> kill tset
47− Spawn -> next
48− Replace oldtid -> do
49− del tset oldtid
50− next
51+ Stop -> kill tset0 >> T.killManager timmgr
52+ Spawn -> next tset0
53+ Replace oldtid -> next $ del oldtid tset0
5154 where
52− next = do
55+ next tset = do
5356 action <- readIORef ref
54− newtid <- forkIO action
55− add tset newtid
56− go q tset ref
57+ newtid <- forkIO (action timmgr)
58+ let !tset' = add newtid tset
59+ go q tset' ref timmgr
5760
58−setAction :: Manager -> IO () -> IO ()
61+setAction :: Manager -> Action -> IO ()
5962setAction (Manager _ ref) action = writeIORef ref action
6063
6164stop :: Manager -> IO ()
@@ -69,18 +72,15 @@ replaceWithAction (Manager q _) tid = atomically $ writeTQueue q $ Replace tid
6972
7073----------------------------------------------------------------
7174
72−newtype ThreadSet = ThreadSet (IORef (Set ThreadId))
73−
74−newThreadSet :: IO ThreadSet
75−newThreadSet = ThreadSet <$> newIORef Set.empty
76−
77−add :: ThreadSet -> ThreadId -> IO ()
78−add (ThreadSet ref) tid =
79− atomicModifyIORef' ref (\set -> (Set.insert tid set, ()))
75+add :: ThreadId -> Set ThreadId -> Set ThreadId
76+add tid set = set'
77+ where
78+ !set' = Set.insert tid set
8079
81−del :: ThreadSet -> ThreadId -> IO ()
82−del (ThreadSet ref) tid =
83− atomicModifyIORef' ref (\set -> (Set.delete tid set, ()))
80+del :: ThreadId -> Set ThreadId -> Set ThreadId
81+del tid set = set'
82+ where
83+ !set' = Set.delete tid set
8484
85−kill :: ThreadSet -> IO ()
86−kill (ThreadSet ref) = Set.toList <$> readIORef ref >>= mapM_ killThread
85+kill :: Set ThreadId -> IO ()
86+kill set = traverse_ killThread set