diff options
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r-- | server/src/Thermoprint/Server.hs | 21 |
1 files changed, 4 insertions, 17 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 4e8d962..39bf0a1 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs | |||
@@ -3,11 +3,10 @@ | |||
3 | {-# LANGUAGE OverloadedStrings #-} | 3 | {-# LANGUAGE OverloadedStrings #-} |
4 | {-# LANGUAGE TypeOperators #-} | 4 | {-# LANGUAGE TypeOperators #-} |
5 | {-# LANGUAGE FlexibleContexts #-} | 5 | {-# LANGUAGE FlexibleContexts #-} |
6 | {-# LANGUAGE ViewPatterns #-} | ||
7 | 6 | ||
8 | module Thermoprint.Server | 7 | module Thermoprint.Server |
9 | ( thermoprintServer | 8 | ( thermoprintServer |
10 | , Config(..), withPrinters | 9 | , Config(..) |
11 | , module Data.Default.Class | 10 | , module Data.Default.Class |
12 | , module Servant.Server.Internal.Enter | 11 | , module Servant.Server.Internal.Enter |
13 | , module Thermoprint.Server.Printer | 12 | , module Thermoprint.Server.Printer |
@@ -20,8 +19,7 @@ import Data.Map (Map) | |||
20 | import qualified Data.Map as Map | 19 | import qualified Data.Map as Map |
21 | 20 | ||
22 | import Data.Maybe (maybe) | 21 | import Data.Maybe (maybe) |
23 | import Data.Foldable (mapM_, forM_, foldlM) | 22 | import Data.Foldable (mapM_, forM_) |
24 | import Data.Monoid | ||
25 | 23 | ||
26 | import Control.Monad.Trans.Resource | 24 | import Control.Monad.Trans.Resource |
27 | import Control.Monad.Trans.Control | 25 | import Control.Monad.Trans.Control |
@@ -29,8 +27,6 @@ import Control.Monad.Logger | |||
29 | import Control.Monad.Reader | 27 | import Control.Monad.Reader |
30 | import Control.Monad.IO.Class | 28 | import Control.Monad.IO.Class |
31 | 29 | ||
32 | import Control.Monad.Writer | ||
33 | |||
34 | import Control.Concurrent | 30 | import Control.Concurrent |
35 | 31 | ||
36 | import Data.Text (Text) | 32 | import Data.Text (Text) |
@@ -66,9 +62,9 @@ instance Default Config where | |||
66 | 62 | ||
67 | 63 | ||
68 | thermoprintServer :: ( MonadLoggerIO m | 64 | thermoprintServer :: ( MonadLoggerIO m |
69 | , MonadReader ConnectionPool m | 65 | , MonadIO m |
70 | , MonadResource m | ||
71 | , MonadBaseControl IO m | 66 | , MonadBaseControl IO m |
67 | , MonadReader ConnectionPool m | ||
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. | 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. |
73 | -> Config -> IO () | 69 | -> Config -> IO () |
74 | -- ^ Run the server | 70 | -- ^ Run the server |
@@ -83,12 +79,3 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams | |||
83 | mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask | 79 | mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask |
84 | forM_ printers $ liftBaseDiscard forkIO . runPrinter | 80 | forM_ printers $ liftBaseDiscard forkIO . runPrinter |
85 | liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers | 81 | 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 | ||