aboutsummaryrefslogtreecommitdiff
path: root/server/src/Thermoprint/Server.hs
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-01-24 07:04:53 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-01-24 07:04:53 +0000
commit7d3df6adce65e8840ef651a8a02a34a1a02083aa (patch)
treea5f82445047b6a4eefb803c0f3ee7dec5d1247f7 /server/src/Thermoprint/Server.hs
parent6434397a3d103547b563ada27fd64c38cb05e1f0 (diff)
downloadthermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar
thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar.gz
thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar.bz2
thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar.xz
thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.zip
Revert "Broken existentially quantified printer config"
This reverts commit 6434397a3d103547b563ada27fd64c38cb05e1f0.
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r--server/src/Thermoprint/Server.hs21
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
8module Thermoprint.Server 7module 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)
20import qualified Data.Map as Map 19import qualified Data.Map as Map
21 20
22import Data.Maybe (maybe) 21import Data.Maybe (maybe)
23import Data.Foldable (mapM_, forM_, foldlM) 22import Data.Foldable (mapM_, forM_)
24import Data.Monoid
25 23
26import Control.Monad.Trans.Resource 24import Control.Monad.Trans.Resource
27import Control.Monad.Trans.Control 25import Control.Monad.Trans.Control
@@ -29,8 +27,6 @@ import Control.Monad.Logger
29import Control.Monad.Reader 27import Control.Monad.Reader
30import Control.Monad.IO.Class 28import Control.Monad.IO.Class
31 29
32import Control.Monad.Writer
33
34import Control.Concurrent 30import Control.Concurrent
35 31
36import Data.Text (Text) 32import Data.Text (Text)
@@ -66,9 +62,9 @@ instance Default Config where
66 62
67 63
68thermoprintServer :: ( MonadLoggerIO m 64thermoprintServer :: ( 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
87withPrinters :: MonadResource m => Config -> [PrinterSpec] -> m Config
88-- ^ Helper for comfortably specifying a set of 'Printer's
89withPrinters 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