diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-02-04 22:03:50 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-02-04 22:03:50 +0000 |
commit | 35e66962daea42b8964dbf76ca92b7619f387e02 (patch) | |
tree | d8f2162b88afe2883587f68c1f5f91b058924942 /server | |
parent | bf1bea05f992dd21f267d25034d2ffd5ef6f865d (diff) | |
download | thermoprint-35e66962daea42b8964dbf76ca92b7619f387e02.tar thermoprint-35e66962daea42b8964dbf76ca92b7619f387e02.tar.gz thermoprint-35e66962daea42b8964dbf76ca92b7619f387e02.tar.bz2 thermoprint-35e66962daea42b8964dbf76ca92b7619f387e02.tar.xz thermoprint-35e66962daea42b8964dbf76ca92b7619f387e02.zip |
docs
Diffstat (limited to 'server')
-rw-r--r-- | server/src/Thermoprint/Server/Queue.hs | 2 |
1 files changed, 2 insertions, 0 deletions
diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs index bae9617..cfe0970 100644 --- a/server/src/Thermoprint/Server/Queue.hs +++ b/server/src/Thermoprint/Server/Queue.hs | |||
@@ -60,6 +60,7 @@ data QueueEntry = QueueEntry | |||
60 | } | 60 | } |
61 | deriving (Typeable, Generic, NFData) | 61 | deriving (Typeable, Generic, NFData) |
62 | 62 | ||
63 | -- | A queue manager periodically modifies a 'Queue', e.g. for cleanup of old jobs | ||
63 | type QueueManager t = ComposeT (StateT Queue) t STM DiffTime | 64 | type QueueManager t = ComposeT (StateT Queue) t STM DiffTime |
64 | 65 | ||
65 | runQM :: ( HasQueue q | 66 | runQM :: ( HasQueue q |
@@ -68,6 +69,7 @@ runQM :: ( HasQueue q | |||
68 | , MonadIO (t IO) | 69 | , MonadIO (t IO) |
69 | , Monad (t STM) | 70 | , Monad (t STM) |
70 | ) => QueueManager t -> q -> t IO () | 71 | ) => QueueManager t -> q -> t IO () |
72 | -- ^ Periodically modify a 'Queue' | ||
71 | runQM qm (extractQueue -> q) = forever $ liftIO . threadDelay . toMicro =<< qm' | 73 | runQM qm (extractQueue -> q) = forever $ liftIO . threadDelay . toMicro =<< qm' |
72 | where | 74 | where |
73 | qm' = hoist atomically $ (\(a, s) -> lift (writeTVar q s) >> return a) =<< runStateT (getComposeT qm) =<< lift (readTVar q) | 75 | qm' = hoist atomically $ (\(a, s) -> lift (writeTVar q s) >> return a) =<< runStateT (getComposeT qm) =<< lift (readTVar q) |