Prototype queue manager configuration

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