diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-24 16:10:48 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-24 16:10:48 +0000 |
commit | c3a6d0657eb2987aa13b53419269274d848d9e0c (patch) | |
tree | fcf161b74fffad2294efc0b558a0dfd1bc27d49b /server/src/Thermoprint/Server/Printer.hs | |
parent | 7d3df6adce65e8840ef651a8a02a34a1a02083aa (diff) | |
download | thermoprint-c3a6d0657eb2987aa13b53419269274d848d9e0c.tar thermoprint-c3a6d0657eb2987aa13b53419269274d848d9e0c.tar.gz thermoprint-c3a6d0657eb2987aa13b53419269274d848d9e0c.tar.bz2 thermoprint-c3a6d0657eb2987aa13b53419269274d848d9e0c.tar.xz thermoprint-c3a6d0657eb2987aa13b53419269274d848d9e0c.zip |
Working printer config & debug printer
Diffstat (limited to 'server/src/Thermoprint/Server/Printer.hs')
-rw-r--r-- | server/src/Thermoprint/Server/Printer.hs | 51 |
1 files changed, 44 insertions, 7 deletions
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs index f34b2fa..46b8a53 100644 --- a/server/src/Thermoprint/Server/Printer.hs +++ b/server/src/Thermoprint/Server/Printer.hs | |||
@@ -1,16 +1,21 @@ | |||
1 | {-# LANGUAGE RankNTypes #-} | 1 | {-# LANGUAGE RankNTypes #-} |
2 | {-# LANGUAGE TypeSynonymInstances #-} | ||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | 3 | {-# LANGUAGE MultiParamTypeClasses #-} |
4 | {-# LANGUAGE FlexibleInstances #-} | ||
3 | {-# LANGUAGE FlexibleContexts #-} | 5 | {-# LANGUAGE FlexibleContexts #-} |
4 | {-# LANGUAGE RecordWildCards #-} | 6 | {-# LANGUAGE RecordWildCards #-} |
5 | {-# LANGUAGE OverloadedStrings #-} | 7 | {-# LANGUAGE OverloadedStrings #-} |
6 | {-# LANGUAGE TemplateHaskell #-} | 8 | {-# LANGUAGE TemplateHaskell #-} |
7 | {-# LANGUAGE StandaloneDeriving #-} | 9 | {-# LANGUAGE StandaloneDeriving #-} |
10 | {-# LANGUAGE GADTs #-} | ||
11 | {-# LANGUAGE ExistentialQuantification #-} | ||
8 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} | 12 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} |
9 | 13 | ||
10 | module Thermoprint.Server.Printer | 14 | module Thermoprint.Server.Printer |
11 | ( Printer(..), printer | 15 | ( PrinterMethod(..), PrinterSpec(..), IsPrinter(..), Printer(..), printer |
12 | , Queue(..) | 16 | , Queue(..) |
13 | , runPrinter | 17 | , runPrinter |
18 | , addToQueue | ||
14 | ) where | 19 | ) where |
15 | 20 | ||
16 | import Thermoprint.API (PrintingError(..), Printout) | 21 | import Thermoprint.API (PrintingError(..), Printout) |
@@ -31,6 +36,7 @@ import qualified Data.Text as T (pack) | |||
31 | import Data.Typeable (Typeable) | 36 | import Data.Typeable (Typeable) |
32 | import GHC.Generics (Generic) | 37 | import GHC.Generics (Generic) |
33 | import Control.DeepSeq | 38 | import Control.DeepSeq |
39 | import Data.Default.Class | ||
34 | 40 | ||
35 | import Control.Monad.Trans.Resource | 41 | import Control.Monad.Trans.Resource |
36 | import Control.Monad.IO.Class | 42 | import Control.Monad.IO.Class |
@@ -41,8 +47,20 @@ import Control.Monad (forever) | |||
41 | 47 | ||
42 | import Control.Concurrent.STM | 48 | import Control.Concurrent.STM |
43 | 49 | ||
50 | newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } | ||
51 | data PrinterSpec m = forall p. IsPrinter p m => PS p | ||
52 | |||
53 | class IsPrinter p m where | ||
54 | printMethod :: p -> m PrinterMethod | ||
55 | |||
56 | instance Applicative m => IsPrinter PrinterMethod m where | ||
57 | printMethod = pure | ||
58 | |||
59 | instance IsPrinter (PrinterSpec m) m where | ||
60 | printMethod (PS p) = printMethod p | ||
61 | |||
44 | data Printer = Printer | 62 | data Printer = Printer |
45 | { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError) | 63 | { print :: PrinterMethod |
46 | , queue :: TVar Queue | 64 | , queue :: TVar Queue |
47 | } | 65 | } |
48 | 66 | ||
@@ -54,16 +72,23 @@ data Queue = Queue | |||
54 | } | 72 | } |
55 | deriving (Typeable, Generic, NFData) | 73 | deriving (Typeable, Generic, NFData) |
56 | 74 | ||
57 | printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer | 75 | instance Default Queue where |
58 | printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty) | 76 | def = Queue |
77 | { pending = Seq.empty | ||
78 | , current = Nothing | ||
79 | , history = Seq.empty | ||
80 | } | ||
81 | |||
82 | printer :: (MonadResource m, IsPrinter p m) => p -> m Printer | ||
83 | printer spec = Printer <$> printMethod spec <*> liftIO (newTVarIO def) | ||
59 | 84 | ||
60 | atomically' :: MonadIO m => STM a -> m a | 85 | atomically' :: MonadIO m => STM a -> m a |
61 | atomically' = liftIO . atomically | 86 | atomically' = liftIO . atomically |
62 | 87 | ||
63 | runPrinter :: ( MonadReader ConnectionPool m | 88 | runPrinter :: ( MonadReader ConnectionPool m |
64 | , MonadIO m | ||
65 | , MonadLogger m | 89 | , MonadLogger m |
66 | , MonadBaseControl IO m | 90 | , MonadBaseControl IO m |
91 | , MonadResource m | ||
67 | ) => Printer -> m () | 92 | ) => Printer -> m () |
68 | -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method | 93 | -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method |
69 | runPrinter Printer{..} = forever $ do | 94 | runPrinter Printer{..} = forever $ do |
@@ -78,6 +103,18 @@ runPrinter Printer{..} = forever $ do | |||
78 | case job of | 103 | case job of |
79 | Nothing -> $(logWarn) "Nonexistent job id in printer queue" | 104 | Nothing -> $(logWarn) "Nonexistent job id in printer queue" |
80 | Just job -> do | 105 | Just job -> do |
81 | printReturn <- print (jobContent job) | 106 | $(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId) |
82 | maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show jobId ++ ": ") ++) . show) $ printReturn | 107 | printReturn <- (unPM print) (jobContent job) |
108 | maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show (unSqlBackendKey . unJobKey $ jobId) ++ ": ") ++) . show) $ printReturn | ||
83 | atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history) | 109 | atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history) |
110 | |||
111 | addToQueue :: ( MonadReader ConnectionPool m | ||
112 | , MonadLogger m | ||
113 | , MonadResource m | ||
114 | , MonadBaseControl IO m | ||
115 | ) => Printout -> Printer -> m JobId | ||
116 | addToQueue printout Printer{..} = do | ||
117 | jobId <- runSqlPool (insert $ Job printout) =<< ask | ||
118 | $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId) | ||
119 | atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (jobId <| pending) current history) | ||
120 | return jobId | ||