diff options
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r-- | server/src/Thermoprint/Server.hs | 21 |
1 files changed, 17 insertions, 4 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 39bf0a1..4e8d962 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs | |||
@@ -3,10 +3,11 @@ | |||
3 | {-# LANGUAGE OverloadedStrings #-} | 3 | {-# LANGUAGE OverloadedStrings #-} |
4 | {-# LANGUAGE TypeOperators #-} | 4 | {-# LANGUAGE TypeOperators #-} |
5 | {-# LANGUAGE FlexibleContexts #-} | 5 | {-# LANGUAGE FlexibleContexts #-} |
6 | {-# LANGUAGE ViewPatterns #-} | ||
6 | 7 | ||
7 | module Thermoprint.Server | 8 | module Thermoprint.Server |
8 | ( thermoprintServer | 9 | ( thermoprintServer |
9 | , Config(..) | 10 | , Config(..), withPrinters |
10 | , module Data.Default.Class | 11 | , module Data.Default.Class |
11 | , module Servant.Server.Internal.Enter | 12 | , module Servant.Server.Internal.Enter |
12 | , module Thermoprint.Server.Printer | 13 | , module Thermoprint.Server.Printer |
@@ -19,7 +20,8 @@ import Data.Map (Map) | |||
19 | import qualified Data.Map as Map | 20 | import qualified Data.Map as Map |
20 | 21 | ||
21 | import Data.Maybe (maybe) | 22 | import Data.Maybe (maybe) |
22 | import Data.Foldable (mapM_, forM_) | 23 | import Data.Foldable (mapM_, forM_, foldlM) |
24 | import Data.Monoid | ||
23 | 25 | ||
24 | import Control.Monad.Trans.Resource | 26 | import Control.Monad.Trans.Resource |
25 | import Control.Monad.Trans.Control | 27 | import Control.Monad.Trans.Control |
@@ -27,6 +29,8 @@ import Control.Monad.Logger | |||
27 | import Control.Monad.Reader | 29 | import Control.Monad.Reader |
28 | import Control.Monad.IO.Class | 30 | import Control.Monad.IO.Class |
29 | 31 | ||
32 | import Control.Monad.Writer | ||
33 | |||
30 | import Control.Concurrent | 34 | import Control.Concurrent |
31 | 35 | ||
32 | import Data.Text (Text) | 36 | import Data.Text (Text) |
@@ -62,9 +66,9 @@ instance Default Config where | |||
62 | 66 | ||
63 | 67 | ||
64 | thermoprintServer :: ( MonadLoggerIO m | 68 | thermoprintServer :: ( MonadLoggerIO m |
65 | , MonadIO m | ||
66 | , MonadBaseControl IO m | ||
67 | , MonadReader ConnectionPool m | 69 | , MonadReader ConnectionPool m |
70 | , MonadResource m | ||
71 | , MonadBaseControl IO m | ||
68 | ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify the rest of it. Therefore we require a specification of how to enter the stack. | 72 | ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify the rest of it. Therefore we require a specification of how to enter the stack. |
69 | -> Config -> IO () | 73 | -> Config -> IO () |
70 | -- ^ Run the server | 74 | -- ^ Run the server |
@@ -79,3 +83,12 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams | |||
79 | mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask | 83 | mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask |
80 | forM_ printers $ liftBaseDiscard forkIO . runPrinter | 84 | forM_ printers $ liftBaseDiscard forkIO . runPrinter |
81 | liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers | 85 | liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers |
86 | |||
87 | withPrinters :: MonadResource m => Config -> [PrinterSpec] -> m Config | ||
88 | -- ^ Helper for comfortably specifying a set of 'Printer's | ||
89 | withPrinters cfg = fmap (\ps -> cfg { printers = printers cfg <> ps }) . foldlM (\ps p -> Map.insert (nextKey ps) <$> printer p <*> pure ps) Map.empty | ||
90 | where | ||
91 | nextKey :: Map PrinterId a -> PrinterId | ||
92 | nextKey (Map.keys -> keys) | ||
93 | | null keys = 0 | ||
94 | | otherwise = succ $ maximum keys | ||