module Network.HTTP2.Arch.Manager (
Manager
, Action
, start
, setAction
, stop
, spawnAction
, addMyId
, deleteMyId
, timeoutKillThread
, timeoutClose
) where
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
import Data.Foldable
import Data.IORef
import Data.Set (Set)
import qualified Data.Set as Set
import qualified System.TimeManager as T
import Imports
type Action = IO ()
noAction :: Action
noAction :: Action
noAction = () -> Action
forall (m :: * -> *) a. Monad m => a -> m a
return ()
data Command = Stop | Spawn | Add ThreadId | Delete ThreadId
data Manager = Manager (TQueue Command) (IORef Action) T.Manager
start :: T.Manager -> IO Manager
start :: Manager -> IO Manager
start Manager
timmgr = do
TQueue Command
q <- IO (TQueue Command)
forall a. IO (TQueue a)
newTQueueIO
IORef Action
ref <- Action -> IO (IORef Action)
forall a. a -> IO (IORef a)
newIORef Action
noAction
IO ThreadId -> Action
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> Action) -> IO ThreadId -> Action
forall a b. (a -> b) -> a -> b
$ Action -> IO ThreadId
forkIO (Action -> IO ThreadId) -> Action -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TQueue Command -> Set ThreadId -> IORef Action -> Action
go TQueue Command
q Set ThreadId
forall a. Set a
Set.empty IORef Action
ref
Manager -> IO Manager
forall (m :: * -> *) a. Monad m => a -> m a
return (Manager -> IO Manager) -> Manager -> IO Manager
forall a b. (a -> b) -> a -> b
$ TQueue Command -> IORef Action -> Manager -> Manager
Manager TQueue Command
q IORef Action
ref Manager
timmgr
where
go :: TQueue Command -> Set ThreadId -> IORef Action -> Action
go TQueue Command
q Set ThreadId
tset0 IORef Action
ref = do
Command
x <- STM Command -> IO Command
forall a. STM a -> IO a
atomically (STM Command -> IO Command) -> STM Command -> IO Command
forall a b. (a -> b) -> a -> b
$ TQueue Command -> STM Command
forall a. TQueue a -> STM a
readTQueue TQueue Command
q
case Command
x of
Command
Stop -> Set ThreadId -> Action
kill Set ThreadId
tset0
Command
Spawn -> Set ThreadId -> Action
next Set ThreadId
tset0
Add ThreadId
newtid -> let tset :: Set ThreadId
tset = ThreadId -> Set ThreadId -> Set ThreadId
add ThreadId
newtid Set ThreadId
tset0
in TQueue Command -> Set ThreadId -> IORef Action -> Action
go TQueue Command
q Set ThreadId
tset IORef Action
ref
Delete ThreadId
oldtid -> let tset :: Set ThreadId
tset = ThreadId -> Set ThreadId -> Set ThreadId
del ThreadId
oldtid Set ThreadId
tset0
in TQueue Command -> Set ThreadId -> IORef Action -> Action
go TQueue Command
q Set ThreadId
tset IORef Action
ref
where
next :: Set ThreadId -> Action
next Set ThreadId
tset = do
Action
action <- IORef Action -> IO Action
forall a. IORef a -> IO a
readIORef IORef Action
ref
ThreadId
newtid <- Action -> IO ThreadId
forkIO Action
action
let tset' :: Set ThreadId
tset' = ThreadId -> Set ThreadId -> Set ThreadId
add ThreadId
newtid Set ThreadId
tset
TQueue Command -> Set ThreadId -> IORef Action -> Action
go TQueue Command
q Set ThreadId
tset' IORef Action
ref
setAction :: Manager -> Action -> IO ()
setAction :: Manager -> Action -> Action
setAction (Manager TQueue Command
_ IORef Action
ref Manager
_) Action
action = IORef Action -> Action -> Action
forall a. IORef a -> a -> Action
writeIORef IORef Action
ref Action
action
stop :: Manager -> IO ()
stop :: Manager -> Action
stop (Manager TQueue Command
q IORef Action
_ Manager
_) = STM () -> Action
forall a. STM a -> IO a
atomically (STM () -> Action) -> STM () -> Action
forall a b. (a -> b) -> a -> b
$ TQueue Command -> Command -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Command
q Command
Stop
spawnAction :: Manager -> IO ()
spawnAction :: Manager -> Action
spawnAction (Manager TQueue Command
q IORef Action
_ Manager
_) = STM () -> Action
forall a. STM a -> IO a
atomically (STM () -> Action) -> STM () -> Action
forall a b. (a -> b) -> a -> b
$ TQueue Command -> Command -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Command
q Command
Spawn
addMyId :: Manager -> IO ()
addMyId :: Manager -> Action
addMyId (Manager TQueue Command
q IORef Action
_ Manager
_) = do
ThreadId
tid <- IO ThreadId
myThreadId
STM () -> Action
forall a. STM a -> IO a
atomically (STM () -> Action) -> STM () -> Action
forall a b. (a -> b) -> a -> b
$ TQueue Command -> Command -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Command
q (Command -> STM ()) -> Command -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> Command
Add ThreadId
tid
deleteMyId :: Manager -> IO ()
deleteMyId :: Manager -> Action
deleteMyId (Manager TQueue Command
q IORef Action
_ Manager
_) = do
ThreadId
tid <- IO ThreadId
myThreadId
STM () -> Action
forall a. STM a -> IO a
atomically (STM () -> Action) -> STM () -> Action
forall a b. (a -> b) -> a -> b
$ TQueue Command -> Command -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Command
q (Command -> STM ()) -> Command -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> Command
Delete ThreadId
tid
add :: ThreadId -> Set ThreadId -> Set ThreadId
add :: ThreadId -> Set ThreadId -> Set ThreadId
add ThreadId
tid Set ThreadId
set = Set ThreadId
set'
where
set' :: Set ThreadId
set' = ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
tid Set ThreadId
set
del :: ThreadId -> Set ThreadId -> Set ThreadId
del :: ThreadId -> Set ThreadId -> Set ThreadId
del ThreadId
tid Set ThreadId
set = Set ThreadId
set'
where
set' :: Set ThreadId
set' = ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.delete ThreadId
tid Set ThreadId
set
kill :: Set ThreadId -> IO ()
kill :: Set ThreadId -> Action
kill Set ThreadId
set = (ThreadId -> Action) -> Set ThreadId -> Action
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ThreadId -> Action
killThread Set ThreadId
set
timeoutKillThread :: Manager -> (T.Handle -> IO ()) -> IO ()
timeoutKillThread :: Manager -> (Handle -> Action) -> Action
timeoutKillThread (Manager TQueue Command
_ IORef Action
_ Manager
tmgr) Handle -> Action
action = IO Handle -> (Handle -> Action) -> (Handle -> Action) -> Action
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO Handle
register Handle -> Action
T.cancel Handle -> Action
action
where
register :: IO Handle
register = Manager -> Action -> IO Handle
T.registerKillThread Manager
tmgr Action
noAction
timeoutClose :: Manager -> IO () -> IO (IO ())
timeoutClose :: Manager -> Action -> IO Action
timeoutClose (Manager TQueue Command
_ IORef Action
_ Manager
tmgr) Action
closer = do
Handle
th <- Manager -> Action -> IO Handle
T.register Manager
tmgr Action
closer
Action -> IO Action
forall (m :: * -> *) a. Monad m => a -> m a
return (Action -> IO Action) -> Action -> IO Action
forall a b. (a -> b) -> a -> b
$ Handle -> Action
T.tickle Handle
th