Recording job creation time in printer queues

2 files changed, 66 insertions, 42 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 @@
 {-# 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
 
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index 67180c4..7f41430 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -12,38 +12,41 @@ module Thermoprint.Server.Printer
        ( PrinterMethod(..), Printer(..)
        , printer
        , Queue(..)
+       , QueueEntry(..)
        , runPrinter
        , addToQueue
        ) where
 
-import Thermoprint.API (PrintingError(..), Printout)
+import           Thermoprint.API (PrintingError(..), Printout)
 import qualified Thermoprint.API as API (JobStatus(..))
 
-import Thermoprint.Server.Database
+import           Thermoprint.Server.Database
 
-import Database.Persist
-import Database.Persist.Sql
+import           Database.Persist
+import           Database.Persist.Sql
 
-import Data.Sequence (Seq, ViewL(..), viewl, (<|))
+import           Data.Sequence (Seq, ViewL(..), viewl, (<|), (|>))
 import qualified Data.Sequence as Seq
-import Data.Map (Map)
+import           Data.Map (Map)
 import qualified Data.Map as Map
 
 import qualified Data.Text as T (pack)
 
-import Data.Typeable (Typeable)
-import GHC.Generics (Generic)
-import Control.DeepSeq
-import Data.Default.Class
+import           Data.Typeable (Typeable)
+import           GHC.Generics (Generic)
+import           Control.DeepSeq
+import           Data.Default.Class
 
-import Control.Monad.Trans.Resource
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader
 
-import Control.Monad (forever)
+import           Control.Monad (forever)
 
-import Control.Concurrent.STM
+import           Control.Concurrent.STM
+
+import           Data.Time.Clock
 
 newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) }
 
@@ -52,11 +55,11 @@ data Printer = Printer
   , queue :: TVar Queue
   }
 
--- | Zipper for 'Seq JobId'
+-- | Zipper for 'Seq QueueEntry'
 data Queue = Queue
-  { pending :: Seq JobId -- ^ Pending jobs, closest first
-  , current :: Maybe JobId
-  , history :: Seq (JobId, Maybe PrintingError) -- ^ Completed jobs, closest first
+  { pending :: Seq QueueEntry -- ^ Pending jobs, closest last
+  , current :: Maybe QueueEntry
+  , history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first
   }
   deriving (Typeable, Generic, NFData)
 
@@ -67,6 +70,12 @@ instance Default Queue where
     , history = Seq.empty
     }
 
+data QueueEntry = QueueEntry
+  { jobId :: JobId
+  , created :: UTCTime
+  }
+  deriving (Typeable, Generic, NFData)
+
 printer :: MonadResource m => m PrinterMethod -> m Printer
 printer p = Printer <$> p <*> liftIO (newTVarIO def)
 
@@ -80,13 +89,13 @@ runPrinter :: ( MonadReader ConnectionPool m
               ) => Printer -> m ()
 -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
 runPrinter Printer{..} = forever $ do
-  jobId <- atomically' $ do
+  entry@(QueueEntry{..}) <- atomically' $ do
     (Queue queuePending Nothing history) <- readTVar queue
     case viewl queuePending of
       EmptyL               -> retry
-      (jobId :< remaining) -> do
-        writeTVar queue $!! Queue remaining (Just jobId) history
-        return jobId
+      (current :< remaining) -> do
+        writeTVar queue $!! Queue remaining (Just current) history
+        return current
   job <- runSqlPool (get jobId) =<< ask
   case job of
     Nothing  -> do
@@ -96,7 +105,7 @@ runPrinter Printer{..} = forever $ do
       $(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId)
       printReturn <- (unPM print) (jobContent job) -- We could, at this point, do some exception handling. It was decided that this would be undesirable, because we really don't have any idea what exceptions to catch
       maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show (unSqlBackendKey . unJobKey $ jobId) ++ ": ") ++) . show) $ printReturn
-      atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history)
+      atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (entry, printReturn) <| history)
 
 addToQueue :: ( MonadReader ConnectionPool m
               , MonadLogger m
@@ -105,6 +114,12 @@ addToQueue :: ( MonadReader ConnectionPool m
               ) => Printout -> Printer -> m JobId
 addToQueue printout Printer{..} = do
   jobId <- runSqlPool (insert $ Job printout) =<< ask
+  time <- liftIO getCurrentTime
+  let
+    entry = QueueEntry
+      { jobId = jobId
+      , created = time
+      }
   $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId)
-  atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (jobId <| pending) current history)
+  atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (pending |> entry) current history)
   return jobId