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 | ||
