diff options
| -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) |