diff options
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r-- | server/src/Thermoprint/Server.hs | 24 |
1 files changed, 17 insertions, 7 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index c2a4972..446c63e 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs | |||
@@ -4,6 +4,7 @@ | |||
4 | {-# LANGUAGE TypeOperators #-} | 4 | {-# LANGUAGE TypeOperators #-} |
5 | {-# LANGUAGE FlexibleContexts #-} | 5 | {-# LANGUAGE FlexibleContexts #-} |
6 | {-# LANGUAGE ImpredicativeTypes #-} | 6 | {-# LANGUAGE ImpredicativeTypes #-} |
7 | {-# LANGUAGE ExistentialQuantification #-} | ||
7 | {-# LANGUAGE ViewPatterns #-} | 8 | {-# LANGUAGE ViewPatterns #-} |
8 | {-# LANGUAGE DataKinds #-} | 9 | {-# LANGUAGE DataKinds #-} |
9 | 10 | ||
@@ -14,8 +15,7 @@ module Thermoprint.Server | |||
14 | , module Data.Default.Class | 15 | , module Data.Default.Class |
15 | , module Servant.Server.Internal.Enter | 16 | , module Servant.Server.Internal.Enter |
16 | , module Thermoprint.Server.Printer | 17 | , module Thermoprint.Server.Printer |
17 | , module Thermoprint.Server.QMConfig | 18 | , module Thermoprint.Server.Queue |
18 | , Queue(..), QueueEntry(..) | ||
19 | ) where | 19 | ) where |
20 | 20 | ||
21 | import Data.Default.Class | 21 | import Data.Default.Class |
@@ -78,8 +78,7 @@ import Thermoprint.Server.Push | |||
78 | 78 | ||
79 | import Thermoprint.Server.Database | 79 | import Thermoprint.Server.Database |
80 | import Thermoprint.Server.Printer | 80 | import Thermoprint.Server.Printer |
81 | import Thermoprint.Server.Queue hiding (intersection, idQM, union, nullQM, runQM) | 81 | import Thermoprint.Server.Queue |
82 | import Thermoprint.Server.QMConfig | ||
83 | import qualified Thermoprint.Server.API as API (thermoprintServer) | 82 | import qualified Thermoprint.Server.API as API (thermoprintServer) |
84 | import Thermoprint.Server.API hiding (thermoprintServer) | 83 | import Thermoprint.Server.API hiding (thermoprintServer) |
85 | 84 | ||
@@ -89,9 +88,17 @@ import Debug.Trace | |||
89 | data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error | 88 | data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error |
90 | , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour | 89 | , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour |
91 | , printers :: Map API.PrinterId Printer | 90 | , printers :: Map API.PrinterId Printer |
92 | , queueManagers :: API.PrinterId -> QMConfig | 91 | , queueManagers :: API.PrinterId -> QMConfig m |
93 | } | 92 | } |
94 | 93 | ||
94 | data QMConfig m = forall t. ( MonadTrans t | ||
95 | , MFunctor t | ||
96 | , Monad (t STM) | ||
97 | , MonadIO (t IO) | ||
98 | ) => QMConfig { manager :: QueueManager t | ||
99 | , collapse :: (t IO) :~> m | ||
100 | } | ||
101 | |||
95 | instance MonadIO m => Default (Config m) where | 102 | instance MonadIO m => Default (Config m) where |
96 | def = Config { dyreError = Nothing | 103 | def = Config { dyreError = Nothing |
97 | , warpSettings = Warp.defaultSettings | 104 | , warpSettings = Warp.defaultSettings |
@@ -99,7 +106,10 @@ instance MonadIO m => Default (Config m) where | |||
99 | , queueManagers = const def | 106 | , queueManagers = const def |
100 | } | 107 | } |
101 | 108 | ||
102 | withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig)] -> m (Config m) | 109 | instance MonadIO m => Default (QMConfig m) where |
110 | def = QMConfig idQM $ Nat (liftIO . runIdentityT) | ||
111 | |||
112 | withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m) | ||
103 | -- ^ Add a list of printers to a 'Config' | 113 | -- ^ Add a list of printers to a 'Config' |
104 | withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg) | 114 | withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg) |
105 | where | 115 | where |
@@ -140,7 +150,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams | |||
140 | gcChan <- liftIO newTChanIO | 150 | gcChan <- liftIO newTChanIO |
141 | fork tMgr $ jobGC gcChan | 151 | fork tMgr $ jobGC gcChan |
142 | let | 152 | let |
143 | runQM' = liftIO . runQM gcChan . queueManagers | 153 | runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer |
144 | mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers | 154 | mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers |
145 | nChan <- liftIO $ newBroadcastTChanIO | 155 | nChan <- liftIO $ newBroadcastTChanIO |
146 | let | 156 | let |