From 575a06949d7271734db4d52fe512981d6c0e139d Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 14 Feb 2016 21:41:53 +0000
Subject: Support for exception masking in PrinterMethods

---
 server/src/Thermoprint/Server.hs         | 2 ++
 server/src/Thermoprint/Server/Printer.hs | 4 +++-
 2 files changed, 5 insertions(+), 1 deletion(-)

(limited to 'server/src')

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 2413b2a..678d056 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -34,6 +34,7 @@ import Control.Monad.Reader
 import Control.Monad.IO.Class
 import Control.Monad.Morph
 import Control.Category
+import Control.Monad.Catch (MonadMask)
 import Prelude hiding (id, (.))
 
 import qualified Control.Monad as M
@@ -105,6 +106,7 @@ withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a
 thermoprintServer :: ( MonadLoggerIO m
                      , MonadReader ConnectionPool m
                      , MonadResourceBase m
+                     , MonadMask m
                      ) => (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
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index d9cea9d..d0dc37b 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -40,6 +40,7 @@ import           Control.Monad.Trans.Resource
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader
+import           Control.Monad.Catch (MonadMask)
 
 import           Control.Monad (forever)
 
@@ -49,7 +50,7 @@ import           Data.Time.Clock
 
 import           Thermoprint.Server.Queue
 
-newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) }
+newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m) => Printout -> m (Maybe PrintingError) }
 
 data Printer = Printer
   { print :: PrinterMethod
@@ -69,6 +70,7 @@ runPrinter :: ( MonadReader ConnectionPool m
               , MonadLogger m
               , MonadBaseControl IO m
               , MonadResource m
+              , MonadMask m
               ) => Printer -> m ()
 -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
 runPrinter Printer{..} = forever $ do
-- 
cgit v1.2.3