From 44a6279b86deecc865f05d2ee519f64f39ac1ccb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 31 Jan 2016 15:03:57 +0000 Subject: Recording job creation time in printer queues --- server/src/Thermoprint/Server/API.hs | 41 +++++++++++-------- server/src/Thermoprint/Server/Printer.hs | 67 +++++++++++++++++++------------- 2 files changed, 66 insertions(+), 42 deletions(-) (limited to 'server/src') 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 -- cgit v1.2.3