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
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Thermoprint.Server.Printer
( PrinterMethod(..), PrinterSpec(..), IsPrinter(..), Printer(..), printer
, Queue(..)
, 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, ViewL(..), viewl, (<|))
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
newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) }
data PrinterSpec m = forall p. IsPrinter p m => PS p
class IsPrinter p m where
printMethod :: p -> m PrinterMethod
instance Applicative m => IsPrinter PrinterMethod m where
printMethod = pure
instance IsPrinter (PrinterSpec m) m where
printMethod (PS p) = printMethod p
data Printer = Printer
{ print :: PrinterMethod
, queue :: TVar Queue
}
-- | Zipper for 'Seq JobId'
data Queue = Queue
{ pending :: Seq JobId -- ^ Pending jobs, closest first
, current :: Maybe JobId
, history :: Seq (JobId, Maybe PrintingError) -- ^ Completed jobs, closest first
}
deriving (Typeable, Generic, NFData)
instance Default Queue where
def = Queue
{ pending = Seq.empty
, current = Nothing
, history = Seq.empty
}
printer :: (MonadResource m, IsPrinter p m) => p -> m Printer
printer spec = Printer <$> printMethod spec <*> 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
jobId <- 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
job <- runSqlPool (get jobId) =<< ask
case job of
Nothing -> $(logWarn) "Nonexistent job id in printer queue"
Just job -> do
$(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId)
printReturn <- (unPM print) (jobContent job)
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)
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
$(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId)
atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (jobId <| pending) current history)
return jobId
|
