diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-31 15:03:57 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-31 15:03:57 +0000 |
commit | 44a6279b86deecc865f05d2ee519f64f39ac1ccb (patch) | |
tree | e2634312eee0c99b383520e0877c33ece32102ee /server/src/Thermoprint/Server/API.hs | |
parent | 2914fd9d66265080dbb38aed61ef8aad77b5ec2c (diff) | |
download | thermoprint-44a6279b86deecc865f05d2ee519f64f39ac1ccb.tar thermoprint-44a6279b86deecc865f05d2ee519f64f39ac1ccb.tar.gz thermoprint-44a6279b86deecc865f05d2ee519f64f39ac1ccb.tar.bz2 thermoprint-44a6279b86deecc865f05d2ee519f64f39ac1ccb.tar.xz thermoprint-44a6279b86deecc865f05d2ee519f64f39ac1ccb.zip |
Recording job creation time in printer queues
Diffstat (limited to 'server/src/Thermoprint/Server/API.hs')
-rw-r--r-- | server/src/Thermoprint/Server/API.hs | 41 |
1 files changed, 25 insertions, 16 deletions
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 4d036ce..add771a 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs | |||
@@ -2,7 +2,6 @@ | |||
2 | {-# LANGUAGE FlexibleContexts #-} | 2 | {-# LANGUAGE FlexibleContexts #-} |
3 | {-# LANGUAGE TemplateHaskell #-} | 3 | {-# LANGUAGE TemplateHaskell #-} |
4 | {-# LANGUAGE OverloadedStrings #-} | 4 | {-# LANGUAGE OverloadedStrings #-} |
5 | {-# LANGUAGE TupleSections #-} | ||
6 | 5 | ||
7 | module Thermoprint.Server.API | 6 | module Thermoprint.Server.API |
8 | ( ProtoHandler, Handler | 7 | ( ProtoHandler, Handler |
@@ -59,6 +58,8 @@ import Data.Acquire (with) | |||
59 | 58 | ||
60 | import Control.Monad.Catch (handle, catch) | 59 | import Control.Monad.Catch (handle, catch) |
61 | 60 | ||
61 | import Data.Time | ||
62 | |||
62 | type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO)) | 63 | type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO)) |
63 | type Handler = EitherT ServantErr ProtoHandler | 64 | type Handler = EitherT ServantErr ProtoHandler |
64 | 65 | ||
@@ -116,18 +117,18 @@ queue' :: MonadIO m => Printer -> m Queue | |||
116 | -- ^ Call 'queue' and handle concurrency | 117 | -- ^ Call 'queue' and handle concurrency |
117 | queue' = fmap force . liftIO . readTVarIO . queue | 118 | queue' = fmap force . liftIO . readTVarIO . queue |
118 | 119 | ||
119 | extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) | 120 | extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, UTCTime, JobStatus) |
120 | -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' | 121 | -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' |
121 | extractJobs (pId, Queue pending current history) = mconcat [ fmap ((, Queued pId) . castId) pending | 122 | extractJobs (pId, Queue pending current history) = mconcat [ fmap (\e -> (castId $ jobId e, created e, Queued pId)) pending |
122 | , maybe Seq.empty Seq.singleton $ fmap ((, Printing pId) . castId) current | 123 | , maybe Seq.empty Seq.singleton $ fmap (\e -> (castId $ jobId e, created e, Printing pId)) current |
123 | , fmap (bimap castId $ maybe Done Failed) history | 124 | , fmap (\(e, s) -> (castId $ jobId e, created e, maybe Done Failed $ s)) history |
124 | ] | 125 | ] |
125 | 126 | ||
126 | listPrinters :: Handler (Map PrinterId PrinterStatus) | 127 | listPrinters :: Handler (Map PrinterId PrinterStatus) |
127 | listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask) | 128 | listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask) |
128 | where | 129 | where |
129 | toStatus (Queue _ Nothing _) = Available | 130 | toStatus (Queue _ Nothing _) = Available |
130 | toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id | 131 | toStatus (Queue _ (Just id) _) = Busy . castId $ jobId id |
131 | 132 | ||
132 | queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId | 133 | queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId |
133 | queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId | 134 | queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId |
@@ -136,31 +137,39 @@ printerStatus :: PrinterId -> Handler PrinterStatus | |||
136 | printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just | 137 | printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just |
137 | where | 138 | where |
138 | queueToStatus (Queue _ Nothing _) = Available | 139 | queueToStatus (Queue _ Nothing _) = Available |
139 | queueToStatus (Queue _ (Just id) _) = Busy $ castId id | 140 | queueToStatus (Queue _ (Just c) _) = Busy . castId $ jobId c |
140 | 141 | ||
141 | listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus)) | 142 | listJobs :: Maybe PrinterId |
142 | listJobs Nothing minId maxId = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId) =<< asks (Map.keys . printers) | 143 | -> Maybe API.JobId -> Maybe API.JobId |
143 | listJobs pId minId maxId = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId | 144 | -> Maybe UTCTime -> Maybe UTCTime |
145 | -> Handler (Seq (API.JobId, UTCTime, JobStatus)) | ||
146 | listJobs Nothing minId maxId minTime maxTime = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId minTime maxTime) =<< asks (Map.keys . printers) | ||
147 | listJobs pId minId maxId minTime maxTime = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId | ||
144 | where | 148 | where |
145 | filterJobs = Seq.filter (\(id, _) -> maybe True (< id) minId && maybe True (> id) maxId) | 149 | filterJobs = Seq.filter (\(id, time, _) -> and [ maybe True (<= id) minId |
150 | , maybe True (>= id) maxId | ||
151 | , maybe True (<= time) minTime | ||
152 | , maybe True (>= time) maxTime | ||
153 | ] | ||
154 | ) | ||
146 | 155 | ||
147 | getJob :: API.JobId -> Handler Printout | 156 | getJob :: API.JobId -> Handler Printout |
148 | getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool | 157 | getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool |
149 | 158 | ||
150 | jobStatus :: API.JobId -> Handler JobStatus | 159 | jobStatus :: API.JobId -> Handler JobStatus |
151 | jobStatus jobId = maybe (left err404) return . lookup jobId . toList =<< listJobs Nothing Nothing Nothing | 160 | jobStatus jobId = maybe (left err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing Nothing Nothing |
152 | 161 | ||
153 | abortJob :: API.JobId -> Handler () | 162 | abortJob :: API.JobId -> Handler () |
154 | abortJob jobId = do | 163 | abortJob needle = do |
155 | printerIds <- asks (Map.keys . printers) | 164 | printerIds <- asks (Map.keys . printers) |
156 | found <- fmap or . forM printerIds $ \pId -> do | 165 | found <- fmap or . forM printerIds $ \pId -> do |
157 | (pId', p) <- lookupPrinter $ Just pId | 166 | (pId', p) <- lookupPrinter $ Just pId |
158 | found <- liftIO . atomically $ do | 167 | found <- liftIO . atomically $ do |
159 | current@(Queue pending _ _) <- readTVar $ queue p | 168 | current@(Queue pending _ _) <- readTVar $ queue p |
160 | let filtered = Seq.filter (/= castId jobId) pending | 169 | let filtered = Seq.filter ((/= castId needle) . jobId) pending |
161 | writeTVar (queue p) $ current { pending = filtered } | 170 | writeTVar (queue p) $ current { pending = filtered } |
162 | return . not $ ((==) `on` length) pending filtered | 171 | return . not $ ((==) `on` length) pending filtered |
163 | when found . $(logInfo) $ "Removed job #" <> (T.pack $ show (castId jobId :: Integer)) <> " from " <> (T.pack . show $ pId') | 172 | when found . $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId') |
164 | return found | 173 | return found |
165 | when (not found) $ left err404 | 174 | when (not found) $ left err404 |
166 | 175 | ||