From c8112e2c4a4550372b20b32f7f159c0f31605f4c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 24 Jan 2016 17:35:20 +0000 Subject: make sure we get our queues strictly --- server/src/Thermoprint/Server/API.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'server/src') 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) import Prelude hiding ((.), id, mapM) import Control.Category +import Control.DeepSeq + import Data.Foldable (toList) import Data.Traversable (mapM) import Data.Bifunctor @@ -100,11 +102,14 @@ lookupPrinter pId = asks printers >>= maybePrinter' pId queue' :: MonadIO m => Printer -> m Queue -- ^ Call 'queue' and handle concurrency -queue' = liftIO . readTVarIO . queue +queue' = fmap force . liftIO . readTVarIO . queue extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' -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' +extractJobs (pId, Queue pending current history) = mconcat [ fmap (, Queued pId) pending' + , maybe Seq.empty Seq.singleton (fmap (, Printing pId) current') + , fmap (second $ maybe Done Failed) history' + ] where pending' = fmap (castId' . unJobKey) pending current' = fmap (castId' . unJobKey) current -- cgit v1.2.3