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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ViewPatterns #-}
module Thermoprint.Server
( thermoprintServer
, Config(..), QMConfig(..)
, withPrinters
, module Data.Default.Class
, module Servant.Server.Internal.Enter
, module Thermoprint.Server.Printer
, module Thermoprint.Server.Queue
) where
import Data.Default.Class
import qualified Config.Dyre as Dyre
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe (maybe)
import Data.Foldable (mapM_, forM_, foldlM)
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Control.Monad.Trans.Identity
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Category
import Control.Monad.Catch (MonadMask(mask), finally)
import Prelude hiding (id, (.))
import qualified Control.Monad as M
import Control.Concurrent
import Control.Concurrent.STM
import Data.Text (Text)
import qualified Data.Text as T (pack)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai (Application)
import Servant.Server (serve)
import Servant.Server.Internal.Enter (enter, (:~>)(..))
import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool)
import Thermoprint.API (thermoprintAPI, PrinterId)
import Thermoprint.Server.Fork
import Thermoprint.Server.Database
import Thermoprint.Server.Printer
import Thermoprint.Server.Queue
import qualified Thermoprint.Server.API as API (thermoprintServer)
import Thermoprint.Server.API hiding (thermoprintServer)
import Debug.Trace
-- | Compile-time configuration for 'thermoprintServer'
data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error
, warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour
, printers :: Map PrinterId Printer
, queueManagers :: PrinterId -> QMConfig m
}
data QMConfig m = forall t. ( MonadTrans t
, MFunctor t
, Monad (t STM)
, MonadIO (t IO)
) => QMConfig { manager :: QueueManager t
, collapse :: (t IO) :~> m
}
instance MonadIO m => Default (Config m) where
def = Config { dyreError = Nothing
, warpSettings = Warp.defaultSettings
, printers = Map.empty
, queueManagers = const def
}
instance MonadIO m => Default (QMConfig m) where
def = QMConfig idQM $ Nat (liftIO . runIdentityT)
withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m)
-- ^ Add a list of printers to a 'Config'
withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg)
where
mapInsert map (spec, qm) = Map.insert (nextKey map) <$> ((,) <$> printer spec <*> pure qm) <*> pure map
updateCfg map = let
printerMap = fmap fst map
qmMap = fmap snd map
qmMap' id
| (Just qm) <- (Map.lookup id qmMap) = qm
| otherwise = queueManagers cfg id
in cfg { printers = printerMap, queueManagers = qmMap' }
nextKey map
| Map.null map = 0
| otherwise = succ . fst $ Map.findMax map
thermoprintServer :: ( MonadLoggerIO m
, MonadReader ConnectionPool m
, MonadResourceBase m
, MonadMask m
) => Bool -- ^ Invoke 'dyre' to look for and attempt to compile custom configurations (pass 'False' iff testing)
-> (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify much of the rest of it (we handle 'ResourceT' ourselves, since we need it to fork properly). Therefore we require a specification of how to collapse the stack.
-> ResourceT m (Config (ResourceT m)) -> IO ()
-- ^ Run the server
thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
{ Dyre.projectName = "thermoprint-server"
, Dyre.realMain = realMain
, Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
, Dyre.configCheck = dyre
}
where
realMain cfg = unNat (io . Nat runResourceT) $ do
tMgr <- threadManager resourceForkIO
flip finally (cleanup tMgr) $ do
Config{..} <- cfg
maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
forM_ printers $ fork tMgr . runPrinter
let
runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM qm printer
mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers
|