Broken existentially quantified printer config

1 files changed, 17 insertions, 4 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 39bf0a1..4e8d962 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -3,10 +3,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators     #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 module Thermoprint.Server
        ( thermoprintServer
-       , Config(..)
+       , Config(..), withPrinters
        , module Data.Default.Class
        , module Servant.Server.Internal.Enter
        , module Thermoprint.Server.Printer
@@ -19,7 +20,8 @@ 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 Data.Monoid
 
 import Control.Monad.Trans.Resource
 import Control.Monad.Trans.Control
@@ -27,6 +29,8 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Monad.IO.Class
 
+import Control.Monad.Writer
+
 import Control.Concurrent
        
 import Data.Text (Text)
@@ -62,9 +66,9 @@ instance Default Config where
 
 
 thermoprintServer :: ( MonadLoggerIO m
-                     , MonadIO m
-                     , MonadBaseControl IO m
                      , MonadReader ConnectionPool m
+                     , MonadResource m
+                     , MonadBaseControl IO 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 ()
 -- ^ Run the server
@@ -79,3 +83,12 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
         mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
         forM_ printers $ liftBaseDiscard forkIO . runPrinter
         liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers
+
+withPrinters :: MonadResource m => Config -> [PrinterSpec] -> m Config
+-- ^ Helper for comfortably specifying a set of 'Printer's
+withPrinters cfg = fmap (\ps -> cfg { printers = printers cfg <> ps }) . foldlM (\ps p -> Map.insert (nextKey ps) <$> printer p <*> pure ps) Map.empty
+  where
+    nextKey :: Map PrinterId a -> PrinterId
+    nextKey (Map.keys -> keys)
+      | null keys = 0
+      | otherwise = succ $ maximum keys