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
|
{-# 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 (forever)
import Control.Concurrent.STM
import Data.Time.Clock
import Thermoprint.Server.Queue
newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger 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
) => 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
|
