diff options
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r-- | server/src/Thermoprint/Server.hs | 35 |
1 files changed, 23 insertions, 12 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 39bf0a1..ed20983 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs | |||
@@ -1,12 +1,14 @@ | |||
1 | {-# LANGUAGE RecordWildCards #-} | 1 | {-# LANGUAGE RecordWildCards #-} |
2 | {-# LANGUAGE TemplateHaskell #-} | 2 | {-# LANGUAGE TemplateHaskell #-} |
3 | {-# LANGUAGE OverloadedStrings #-} | 3 | {-# LANGUAGE OverloadedStrings #-} |
4 | {-# LANGUAGE TypeOperators #-} | 4 | {-# LANGUAGE TypeOperators #-} |
5 | {-# LANGUAGE FlexibleContexts #-} | 5 | {-# LANGUAGE FlexibleContexts #-} |
6 | {-# LANGUAGE ImpredicativeTypes #-} | ||
6 | 7 | ||
7 | module Thermoprint.Server | 8 | module Thermoprint.Server |
8 | ( thermoprintServer | 9 | ( thermoprintServer |
9 | , Config(..) | 10 | , Config(..) |
11 | , withPrinters | ||
10 | , module Data.Default.Class | 12 | , module Data.Default.Class |
11 | , module Servant.Server.Internal.Enter | 13 | , module Servant.Server.Internal.Enter |
12 | , module Thermoprint.Server.Printer | 14 | , module Thermoprint.Server.Printer |
@@ -19,13 +21,15 @@ import Data.Map (Map) | |||
19 | import qualified Data.Map as Map | 21 | import qualified Data.Map as Map |
20 | 22 | ||
21 | import Data.Maybe (maybe) | 23 | import Data.Maybe (maybe) |
22 | import Data.Foldable (mapM_, forM_) | 24 | import Data.Foldable (mapM_, forM_, foldlM) |
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 |
26 | import Control.Monad.Logger | 28 | 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 |
31 | import Control.Category | ||
32 | import Prelude hiding (id, (.)) | ||
29 | 33 | ||
30 | import Control.Concurrent | 34 | import Control.Concurrent |
31 | 35 | ||
@@ -62,20 +66,27 @@ 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 | , MonadResourceBase 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. | 71 | ) => (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 () | 72 | -> ResourceT m Config -> IO () |
70 | -- ^ Run the server | 73 | -- ^ Run the server |
71 | thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams | 74 | thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams |
72 | { Dyre.projectName = "thermoprint-server" | 75 | { Dyre.projectName = "thermoprint-server" |
73 | , Dyre.realMain = realMain | 76 | , Dyre.realMain = realMain |
74 | , Dyre.showError = (\cfg msg -> cfg { dyreError = Just msg }) | 77 | , Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg })) |
75 | } | 78 | } |
76 | where | 79 | where |
77 | realMain Config{..} = unNat io $ do | 80 | realMain cfg = unNat (io . Nat runResourceT) $ do |
81 | Config{..} <- cfg | ||
78 | maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError | 82 | maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError |
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 $ resourceForkIO . 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] -> m Config | ||
88 | withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss | ||
89 | where | ||
90 | nextKey map | ||
91 | | Map.null map = 0 | ||
92 | | otherwise = succ . fst $ Map.findMin map | ||