diff options
-rw-r--r-- | server/src/Thermoprint/Server/API.hs | 9 |
1 files changed, 7 insertions, 2 deletions
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 2aa9cb8..1bbefb1 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs | |||
@@ -39,6 +39,8 @@ import Control.Monad ((<=<), liftM2) | |||
39 | import Prelude hiding ((.), id, mapM) | 39 | import Prelude hiding ((.), id, mapM) |
40 | import Control.Category | 40 | import Control.Category |
41 | 41 | ||
42 | import Control.DeepSeq | ||
43 | |||
42 | import Data.Foldable (toList) | 44 | import Data.Foldable (toList) |
43 | import Data.Traversable (mapM) | 45 | import Data.Traversable (mapM) |
44 | import Data.Bifunctor | 46 | import Data.Bifunctor |
@@ -100,11 +102,14 @@ lookupPrinter pId = asks printers >>= maybePrinter' pId | |||
100 | 102 | ||
101 | queue' :: MonadIO m => Printer -> m Queue | 103 | queue' :: MonadIO m => Printer -> m Queue |
102 | -- ^ Call 'queue' and handle concurrency | 104 | -- ^ Call 'queue' and handle concurrency |
103 | queue' = liftIO . readTVarIO . queue | 105 | queue' = fmap force . liftIO . readTVarIO . queue |
104 | 106 | ||
105 | extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) | 107 | extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) |
106 | -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' | 108 | -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' |
107 | extractJobs (pId, Queue pending current history) = fmap (, Queued pId) pending' <> maybe Seq.empty Seq.singleton (fmap (, Printing pId) current') <> fmap (second $ maybe Done Failed) history' | 109 | extractJobs (pId, Queue pending current history) = mconcat [ fmap (, Queued pId) pending' |
110 | , maybe Seq.empty Seq.singleton (fmap (, Printing pId) current') | ||
111 | , fmap (second $ maybe Done Failed) history' | ||
112 | ] | ||
108 | where | 113 | where |
109 | pending' = fmap (castId' . unJobKey) pending | 114 | pending' = fmap (castId' . unJobKey) pending |
110 | current' = fmap (castId' . unJobKey) current | 115 | current' = fmap (castId' . unJobKey) current |