Working printer config & debug printer

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 @@
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators     #-}
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE ImpredicativeTypes #-}
 
 module Thermoprint.Server
        ( thermoprintServer
        , Config(..)
+       , withPrinters
        , module Data.Default.Class
        , module Servant.Server.Internal.Enter
        , module Thermoprint.Server.Printer
@@ -19,13 +21,15 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 import Data.Maybe (maybe)
-import Data.Foldable (mapM_, forM_)
+import Data.Foldable (mapM_, forM_, foldlM)
 
 import Control.Monad.Trans.Resource
 import Control.Monad.Trans.Control
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Monad.IO.Class
+import Control.Category
+import Prelude hiding (id, (.))
 
 import Control.Concurrent
        
@@ -62,20 +66,27 @@ instance Default Config where
 
 
 thermoprintServer :: ( MonadLoggerIO m
-                     , MonadIO m
-                     , MonadBaseControl IO 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 enter the stack.
-                     -> Config -> IO ()
+                     -> ResourceT m Config -> IO ()
 -- ^ Run the server
 thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
   { Dyre.projectName = "thermoprint-server"
   , Dyre.realMain    = realMain
-  , Dyre.showError   = (\cfg msg -> cfg { dyreError = Just msg })
+  , Dyre.showError   = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
   }
     where
-      realMain Config{..} = unNat io $ do
+      realMain cfg = unNat (io . Nat runResourceT) $ do
+        Config{..} <- cfg
         maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
         mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
-        forM_ printers $ liftBaseDiscard forkIO . runPrinter
+        forM_ printers $ resourceForkIO . runPrinter
         liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers
+
+withPrinters :: MonadResource m => Config -> [PrinterSpec m] -> m Config
+withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss
+  where
+    nextKey map
+      | Map.null map = 0
+      | otherwise    = succ . fst $ Map.findMin map