aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--server/src/Thermoprint/Server/API.hs9
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)
39import Prelude hiding ((.), id, mapM) 39import Prelude hiding ((.), id, mapM)
40import Control.Category 40import Control.Category
41 41
42import Control.DeepSeq
43
42import Data.Foldable (toList) 44import Data.Foldable (toList)
43import Data.Traversable (mapM) 45import Data.Traversable (mapM)
44import Data.Bifunctor 46import Data.Bifunctor
@@ -100,11 +102,14 @@ lookupPrinter pId = asks printers >>= maybePrinter' pId
100 102
101queue' :: MonadIO m => Printer -> m Queue 103queue' :: MonadIO m => Printer -> m Queue
102-- ^ Call 'queue' and handle concurrency 104-- ^ Call 'queue' and handle concurrency
103queue' = liftIO . readTVarIO . queue 105queue' = fmap force . liftIO . readTVarIO . queue
104 106
105extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) 107extractJobs :: (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'
107extractJobs (pId, Queue pending current history) = fmap (, Queued pId) pending' <> maybe Seq.empty Seq.singleton (fmap (, Printing pId) current') <> fmap (second $ maybe Done Failed) history' 109extractJobs (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