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/Printer.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/Printer.hs')
-rw-r--r-- | server/src/Thermoprint/Server/Printer.hs | 67 |
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 | |||
12 | ( PrinterMethod(..), Printer(..) | 12 | ( PrinterMethod(..), Printer(..) |
13 | , printer | 13 | , printer |
14 | , Queue(..) | 14 | , Queue(..) |
15 | , QueueEntry(..) | ||
15 | , runPrinter | 16 | , runPrinter |
16 | , addToQueue | 17 | , addToQueue |
17 | ) where | 18 | ) where |
18 | 19 | ||
19 | import Thermoprint.API (PrintingError(..), Printout) | 20 | import Thermoprint.API (PrintingError(..), Printout) |
20 | import qualified Thermoprint.API as API (JobStatus(..)) | 21 | import qualified Thermoprint.API as API (JobStatus(..)) |
21 | 22 | ||
22 | import Thermoprint.Server.Database | 23 | import Thermoprint.Server.Database |
23 | 24 | ||
24 | import Database.Persist | 25 | import Database.Persist |
25 | import Database.Persist.Sql | 26 | import Database.Persist.Sql |
26 | 27 | ||
27 | import Data.Sequence (Seq, ViewL(..), viewl, (<|)) | 28 | import Data.Sequence (Seq, ViewL(..), viewl, (<|), (|>)) |
28 | import qualified Data.Sequence as Seq | 29 | import qualified Data.Sequence as Seq |
29 | import Data.Map (Map) | 30 | import Data.Map (Map) |
30 | import qualified Data.Map as Map | 31 | import qualified Data.Map as Map |
31 | 32 | ||
32 | import qualified Data.Text as T (pack) | 33 | import qualified Data.Text as T (pack) |
33 | 34 | ||
34 | import Data.Typeable (Typeable) | 35 | import Data.Typeable (Typeable) |
35 | import GHC.Generics (Generic) | 36 | import GHC.Generics (Generic) |
36 | import Control.DeepSeq | 37 | import Control.DeepSeq |
37 | import Data.Default.Class | 38 | import Data.Default.Class |
38 | 39 | ||
39 | import Control.Monad.Trans.Resource | 40 | import Control.Monad.Trans.Resource |
40 | import Control.Monad.IO.Class | 41 | import Control.Monad.IO.Class |
41 | import Control.Monad.Logger | 42 | import Control.Monad.Logger |
42 | import Control.Monad.Reader | 43 | import Control.Monad.Reader |
43 | 44 | ||
44 | import Control.Monad (forever) | 45 | import Control.Monad (forever) |
45 | 46 | ||
46 | import Control.Concurrent.STM | 47 | import Control.Concurrent.STM |
48 | |||
49 | import Data.Time.Clock | ||
47 | 50 | ||
48 | newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } | 51 | newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } |
49 | 52 | ||
@@ -52,11 +55,11 @@ data Printer = Printer | |||
52 | , queue :: TVar Queue | 55 | , queue :: TVar Queue |
53 | } | 56 | } |
54 | 57 | ||
55 | -- | Zipper for 'Seq JobId' | 58 | -- | Zipper for 'Seq QueueEntry' |
56 | data Queue = Queue | 59 | data Queue = Queue |
57 | { pending :: Seq JobId -- ^ Pending jobs, closest first | 60 | { pending :: Seq QueueEntry -- ^ Pending jobs, closest last |
58 | , current :: Maybe JobId | 61 | , current :: Maybe QueueEntry |
59 | , history :: Seq (JobId, Maybe PrintingError) -- ^ Completed jobs, closest first | 62 | , history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first |
60 | } | 63 | } |
61 | deriving (Typeable, Generic, NFData) | 64 | deriving (Typeable, Generic, NFData) |
62 | 65 | ||
@@ -67,6 +70,12 @@ instance Default Queue where | |||
67 | , history = Seq.empty | 70 | , history = Seq.empty |
68 | } | 71 | } |
69 | 72 | ||
73 | data QueueEntry = QueueEntry | ||
74 | { jobId :: JobId | ||
75 | , created :: UTCTime | ||
76 | } | ||
77 | deriving (Typeable, Generic, NFData) | ||
78 | |||
70 | printer :: MonadResource m => m PrinterMethod -> m Printer | 79 | printer :: MonadResource m => m PrinterMethod -> m Printer |
71 | printer p = Printer <$> p <*> liftIO (newTVarIO def) | 80 | printer p = Printer <$> p <*> liftIO (newTVarIO def) |
72 | 81 | ||
@@ -80,13 +89,13 @@ runPrinter :: ( MonadReader ConnectionPool m | |||
80 | ) => Printer -> m () | 89 | ) => Printer -> m () |
81 | -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method | 90 | -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method |
82 | runPrinter Printer{..} = forever $ do | 91 | runPrinter Printer{..} = forever $ do |
83 | jobId <- atomically' $ do | 92 | entry@(QueueEntry{..}) <- atomically' $ do |
84 | (Queue queuePending Nothing history) <- readTVar queue | 93 | (Queue queuePending Nothing history) <- readTVar queue |
85 | case viewl queuePending of | 94 | case viewl queuePending of |
86 | EmptyL -> retry | 95 | EmptyL -> retry |
87 | (jobId :< remaining) -> do | 96 | (current :< remaining) -> do |
88 | writeTVar queue $!! Queue remaining (Just jobId) history | 97 | writeTVar queue $!! Queue remaining (Just current) history |
89 | return jobId | 98 | return current |
90 | job <- runSqlPool (get jobId) =<< ask | 99 | job <- runSqlPool (get jobId) =<< ask |
91 | case job of | 100 | case job of |
92 | Nothing -> do | 101 | Nothing -> do |
@@ -96,7 +105,7 @@ runPrinter Printer{..} = forever $ do | |||
96 | $(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId) | 105 | $(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId) |
97 | 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 | 106 | 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 |
98 | maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show (unSqlBackendKey . unJobKey $ jobId) ++ ": ") ++) . show) $ printReturn | 107 | maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show (unSqlBackendKey . unJobKey $ jobId) ++ ": ") ++) . show) $ printReturn |
99 | atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history) | 108 | atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (entry, printReturn) <| history) |
100 | 109 | ||
101 | addToQueue :: ( MonadReader ConnectionPool m | 110 | addToQueue :: ( MonadReader ConnectionPool m |
102 | , MonadLogger m | 111 | , MonadLogger m |
@@ -105,6 +114,12 @@ addToQueue :: ( MonadReader ConnectionPool m | |||
105 | ) => Printout -> Printer -> m JobId | 114 | ) => Printout -> Printer -> m JobId |
106 | addToQueue printout Printer{..} = do | 115 | addToQueue printout Printer{..} = do |
107 | jobId <- runSqlPool (insert $ Job printout) =<< ask | 116 | jobId <- runSqlPool (insert $ Job printout) =<< ask |
117 | time <- liftIO getCurrentTime | ||
118 | let | ||
119 | entry = QueueEntry | ||
120 | { jobId = jobId | ||
121 | , created = time | ||
122 | } | ||
108 | $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId) | 123 | $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId) |
109 | atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (jobId <| pending) current history) | 124 | atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (pending |> entry) current history) |
110 | return jobId | 125 | return jobId |