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 ImpredicativeTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Thermoprint.Server.Printer
( Printer(..), printer
, IsPrinter(..), PrinterSpec(..)
, Queue(..)
, runPrinter
) 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 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.Default.Class
import Prelude hiding (print)
class IsPrinter a where
toMethod :: forall m. (MonadResource m) => a -> (forall m1. (MonadResource m1) => m (Printout -> m1 (Maybe PrintingError)))
instance (MonadResource m) => IsPrinter (Printer m) where
toMethod Printer{..} = return print
instance (MonadResource m) => IsPrinter (PrinterSpec m) where
toMethod (PS p) = toMethod p
data PrinterSpec m = forall p. IsPrinter p => PS p
data Printer m = Printer
{ print :: Printout -> m (Maybe PrintingError)
, 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, MonadResource m1, IsPrinter p) => p -> m (Printer m1)
-- ^ Version of 'Printer' handling the initialisation of the 'TVar'
printer p = Printer <$> toMethod p <*> liftIO (newTVarIO def)
atomically' :: MonadIO m => STM a -> m a
atomically' = liftIO . atomically
runPrinter :: ( MonadReader ConnectionPool m
, MonadLogger m
, MonadResource m
, MonadBaseControl IO m
) => Printer m -> 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
printReturn <- print (jobContent job)
maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show jobId ++ ": ") ++) . show) $ printReturn
atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history)
|
