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
|
{-# 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.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 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.Database
import Thermoprint.Server.Printer
import Thermoprint.Server.Queue
import qualified Thermoprint.Server.API as API (thermoprintServer)
import Thermoprint.Server.API hiding (thermoprintServer)
-- | 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
) => (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 io = Dyre.wrapMain $ Dyre.defaultParams
{ Dyre.projectName = "thermoprint-server"
, Dyre.realMain = realMain
, Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
}
where
realMain cfg = unNat (io . Nat runResourceT) $ do
Config{..} <- cfg
maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
forM_ printers $ resourceForkIO . runPrinter
let
runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM qm printer
Map.foldrWithKey (\k p a -> resourceForkIO (runQM' k p) >> a) (return ()) printers
liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers
|
