1 files changed, 41 insertions, 26 deletions

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