From 44a6279b86deecc865f05d2ee519f64f39ac1ccb Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 31 Jan 2016 15:03:57 +0000
Subject: Recording job creation time in printer queues

---
 server/src/Thermoprint/Server/API.hs | 41 ++++++++++++++++++++++--------------
 1 file changed, 25 insertions(+), 16 deletions(-)

(limited to 'server/src/Thermoprint/Server/API.hs')

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 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections     #-}
 
 module Thermoprint.Server.API
        ( ProtoHandler, Handler
@@ -59,6 +58,8 @@ import           Data.Acquire (with)
 
 import           Control.Monad.Catch (handle, catch)
 
+import           Data.Time
+
 type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO))
 type Handler      = EitherT ServantErr ProtoHandler
 
@@ -116,18 +117,18 @@ queue' :: MonadIO m => Printer -> m Queue
 -- ^ Call 'queue' and handle concurrency
 queue' = fmap force . liftIO . readTVarIO . queue
 
-extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus)
+extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, UTCTime, JobStatus)
 -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue'
-extractJobs (pId, Queue pending current history) = mconcat [ fmap ((, Queued pId) . castId) pending
-                                                           , maybe Seq.empty Seq.singleton $ fmap ((, Printing pId) . castId) current
-                                                           , fmap (bimap castId $ maybe Done Failed) history
+extractJobs (pId, Queue pending current history) = mconcat [ fmap (\e -> (castId $ jobId e, created e, Queued pId)) pending
+                                                           , maybe Seq.empty Seq.singleton $ fmap (\e -> (castId $ jobId e, created e, Printing pId)) current
+                                                           , fmap (\(e, s) -> (castId $ jobId e, created e, maybe Done Failed $ s)) history
                                                            ]
 
 listPrinters :: Handler (Map PrinterId PrinterStatus)
 listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask)
   where
     toStatus (Queue _ Nothing   _) = Available
-    toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id
+    toStatus (Queue _ (Just id) _) = Busy . castId $ jobId id
 
 queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
 queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId
@@ -136,31 +137,39 @@ printerStatus :: PrinterId -> Handler PrinterStatus
 printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just
   where
     queueToStatus (Queue _ Nothing   _) = Available
-    queueToStatus (Queue _ (Just id) _) = Busy $ castId id
-
-listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
-listJobs Nothing minId maxId = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId) =<< asks (Map.keys . printers)
-listJobs pId     minId maxId = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId
+    queueToStatus (Queue _ (Just c) _) = Busy . castId $ jobId c
+
+listJobs :: Maybe PrinterId
+         -> Maybe API.JobId -> Maybe API.JobId
+         -> Maybe UTCTime   -> Maybe UTCTime
+         -> Handler (Seq (API.JobId, UTCTime, JobStatus))
+listJobs Nothing minId maxId minTime maxTime = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId minTime maxTime) =<< asks (Map.keys . printers)
+listJobs pId     minId maxId minTime maxTime = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId
   where
-    filterJobs = Seq.filter (\(id, _) -> maybe True (< id) minId && maybe True (> id) maxId)
+    filterJobs = Seq.filter (\(id, time, _) -> and [ maybe True (<= id)   minId
+                                                   , maybe True (>= id)   maxId
+                                                   , maybe True (<= time) minTime
+                                                   , maybe True (>= time) maxTime
+                                                   ]
+                            )
 
 getJob :: API.JobId -> Handler Printout
 getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool
 
 jobStatus :: API.JobId -> Handler JobStatus
-jobStatus jobId = maybe (left err404) return . lookup jobId . toList =<< listJobs Nothing Nothing Nothing
+jobStatus jobId = maybe (left err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing Nothing Nothing
 
 abortJob :: API.JobId -> Handler ()
-abortJob jobId = do
+abortJob needle = do
   printerIds <- asks (Map.keys . printers)
   found <- fmap or . forM printerIds $ \pId -> do
     (pId', p) <- lookupPrinter $ Just pId
     found <- liftIO . atomically $ do
       current@(Queue pending _ _) <- readTVar $ queue p
-      let filtered = Seq.filter (/= castId jobId) pending
+      let filtered = Seq.filter ((/= castId needle) . jobId) pending
       writeTVar (queue p) $ current { pending = filtered }
       return . not $ ((==) `on` length) pending filtered
-    when found . $(logInfo) $ "Removed job #" <> (T.pack $ show (castId jobId :: Integer)) <> " from " <> (T.pack . show $ pId')
+    when found . $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
     return found
   when (not found) $ left err404
 
-- 
cgit v1.2.3