1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
module Thermoprint.Server.Printer
( PrinterMethod(..), Printer(..)
, printer
, Queue(..)
, QueueEntry(..)
, runPrinter
, addToQueue
) where
import Thermoprint.API (PrintingError(..), Printout)
import qualified Thermoprint.API as API (JobStatus(..))
import Thermoprint.Server.Database
import Database.Persist
import Database.Persist.Sql
import Data.Sequence (Seq, ViewR(..), viewr, (<|), (|>))
import qualified Data.Sequence as Seq
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 Control.Monad.Trans.Resource
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Catch (MonadMask)
import Control.Monad (forever)
import Control.Concurrent.STM
import Data.Time.Clock
import Thermoprint.Server.Queue
newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m) => Printout -> m (Maybe PrintingError) }
data Printer = Printer
{ print :: PrinterMethod
, queue :: TVar Queue
}
instance HasQueue Printer where
extractQueue = queue
printer :: MonadResource m => m PrinterMethod -> m Printer
printer p = Printer <$> p <*> liftIO (newTVarIO def)
atomically' :: MonadIO m => STM a -> m a
atomically' = liftIO . atomically
runPrinter :: ( MonadReader ConnectionPool m
, MonadLogger m
, MonadBaseControl IO m
, MonadResource m
, MonadMask m
) => Printer -> m ()
-- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
runPrinter Printer{..} = forever $ do
entry@(QueueEntry{..}) <- atomically' $ do
(Queue queuePending Nothing history) <- readTVar queue
case viewr queuePending of
EmptyR -> retry
(remaining :> current) -> do
writeTVar queue $!! Queue remaining (Just current) history
return current
job <- runSqlPool (get jobId) =<< ask
case job of
Nothing -> do
atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue pending Nothing history)
$(logWarn) "Nonexistent job id in printer queue"
Just job -> 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 $ (entry, printReturn) <| history)
addToQueue :: ( MonadReader ConnectionPool m
, MonadLogger m
, MonadResource m
, MonadBaseControl IO 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 (pending |> entry) current history)
return jobId
|
