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
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Thermoprint.Server.Printer
( Printer(..), printer
, 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
data Printer = Printer
{ print :: forall m. (MonadIO m) => 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)
printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer
printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty)
atomically' :: MonadIO m => STM a -> m a
atomically' = liftIO . atomically
runPrinter :: ( MonadReader ConnectionPool m
, MonadIO m
, MonadLogger m
, MonadBaseControl IO 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
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)
|
