From f4aa09d615a9cb77f1d13cbbc516be23a2d3cc69 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 12 Feb 2016 00:54:43 +0000 Subject: Prototype queue manager configuration --- server/default-conf/Main.hs | 2 +- server/src/Thermoprint/Server.hs | 71 +++++++++++++++++++++++++++++----------- 2 files changed, 52 insertions(+), 21 deletions(-) diff --git a/server/default-conf/Main.hs b/server/default-conf/Main.hs index 39e500d..36f6c12 100644 --- a/server/default-conf/Main.hs +++ b/server/default-conf/Main.hs @@ -19,5 +19,5 @@ main = thermoprintServer (Nat runSqlite) $ def `withPrinters` printers runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a runSqlite = runStderrLoggingT . withSqlitePool "thermoprint.sqlite" 1 . runReaderT - printers = [ pure debugPrint + printers = [ (pure debugPrint, def) ] diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 2dcb8e9..2413b2a 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ViewPatterns #-} module Thermoprint.Server ( thermoprintServer - , Config(..) + , Config(..), QMConfig(..) , withPrinters , module Data.Default.Class , module Servant.Server.Internal.Enter @@ -26,13 +28,18 @@ import Data.Foldable (mapM_, forM_, foldlM) import Control.Monad.Trans.Resource import Control.Monad.Trans.Control +import Control.Monad.Trans.Identity import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.IO.Class +import Control.Monad.Morph import Control.Category import Prelude hiding (id, (.)) +import qualified Control.Monad as M + import Control.Concurrent +import Control.Concurrent.STM import Data.Text (Text) import qualified Data.Text as T (pack) @@ -55,21 +62,42 @@ import qualified Thermoprint.Server.API as API (thermoprintServer) import Thermoprint.Server.API hiding (thermoprintServer) -- | Compile-time configuration for 'thermoprintServer' -data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error - , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour - , printers :: Map PrinterId Printer - } - -instance Default Config where - def = Config { dyreError = Nothing - , warpSettings = Warp.defaultSettings - , printers = Map.empty +data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error + , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour + , printers :: Map PrinterId Printer + , queueManagers :: PrinterId -> QMConfig m + } + +data QMConfig m = forall t. ( MonadTrans t + , MFunctor t + , Monad (t STM) + , MonadIO (t IO) + ) => QMConfig { manager :: QueueManager t + , collapse :: (t IO) :~> m + } + +instance MonadIO m => Default (Config m) where + def = Config { dyreError = Nothing + , warpSettings = Warp.defaultSettings + , printers = Map.empty + , queueManagers = const def } -withPrinters :: MonadResource m => Config -> [m PrinterMethod] -> m Config +instance MonadIO m => Default (QMConfig m) where + def = QMConfig idQM $ Nat (liftIO . runIdentityT) + +withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m) -- ^ Add a list of printers to a 'Config' -withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss +withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg) where + mapInsert map (spec, qm) = Map.insert (nextKey map) <$> ((,) <$> printer spec <*> pure qm) <*> pure map + updateCfg map = let + printerMap = fmap fst map + qmMap = fmap snd map + qmMap' id + | (Just qm) <- (Map.lookup id qmMap) = qm + | otherwise = queueManagers cfg id + in cfg { printers = printerMap, queueManagers = qmMap' } nextKey map | Map.null map = 0 | otherwise = succ . fst $ Map.findMax map @@ -77,8 +105,8 @@ withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> thermoprintServer :: ( MonadLoggerIO m , MonadReader ConnectionPool m , MonadResourceBase m - ) => (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 collapse the stack. - -> ResourceT m Config -> IO () + ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify much of the rest of it (we handle 'ResourceT' ourselves, since we need it to fork properly). Therefore we require a specification of how to collapse the stack. + -> ResourceT m (Config (ResourceT m)) -> IO () -- ^ Run the server thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams { Dyre.projectName = "thermoprint-server" @@ -91,4 +119,7 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask forM_ printers $ resourceForkIO . runPrinter + let + runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM qm printer + Map.foldrWithKey (\k p a -> resourceForkIO (runQM' k p) >> a) (return ()) printers liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers -- cgit v1.2.3