6 files changed, 30 insertions, 26 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 15fb651..a33a613 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -111,7 +111,7 @@ instance MonadIO m => Default (Config m) where
                }
 
 instance MonadIO m => Default (QMConfig m) where
-  def = QMConfig idQM $ Nat (liftIO . runIdentityT)
+  def = QMConfig idQM $ NT (liftIO . runIdentityT)
 
 withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m)
 -- ^ Add a list of printers to a 'Config'
@@ -149,7 +149,7 @@ thermoprintServer dyre io cfg = do
     , Dyre.cacheDir    = return <$> cacheDir
     }
   where
-    realMain cfg = unNat (io . Nat runResourceT) $ do
+    realMain cfg = (io . NT runResourceT) $$ do
       tMgr <- threadManager resourceForkIO
       flip finally (cleanup tMgr) $ do
         Config{..} <- cfg
@@ -159,11 +159,11 @@ thermoprintServer dyre io cfg = do
         gcChan <- liftIO newTChanIO
         fork tMgr $ jobGC gcChan
         let
-          runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
+          runQM' (queueManagers -> QMConfig qm nat) printer = nat $$ runQM gcChan qm printer
         mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
         nChan <- liftIO $ newBroadcastTChanIO
         let
           printerUrl :: API.PrinterId -> URI
-          printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) . Just
+          printerUrl = linkURI . safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) . Just
         mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers
         liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index f7a8576..30ef290 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -29,6 +29,7 @@ import qualified Data.Text as T
 
 import           Servant hiding (Handler)
 import           Servant.Server hiding (Handler)
+import qualified Servant.Server as Servant (Handler(..))
 import           Servant.Utils.Enter
 import           Servant.Utils.Links
 
@@ -75,8 +76,8 @@ data HandlerInput = HandlerInput { sqlPool  :: ConnectionPool -- ^ How to intera
 
 handlerNat :: ( MonadReader ConnectionPool m
               , MonadLoggerIO m
-              ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> ExceptT ServantErr IO)
--- ^ Servant requires its handlers to be 'ExceptT ServantErr IO'
+              ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> Servant.Handler)
+-- ^ Servant requires its handlers to be essentially 'ExceptT ServantErr IO'
 --
 -- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants
 handlerNat printerMap nChan = do
@@ -89,8 +90,11 @@ handlerNat printerMap nChan = do
       , nChan    = nChan
       }
     protoNat :: ProtoHandler :~> IO
-    protoNat = Nat runResourceT . Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
-  return $ hoistNat protoNat
+    protoNat = NT runResourceT . NT (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
+  return $ NT Servant.Handler . hoistNat protoNat
+
+runSql :: ReaderT SqlBackend ProtoHandler a -> Handler a
+runSql act = lift $ runSqlPool act =<< asks sqlPool
 
 thermoprintServer :: ServerT ThermoprintAPI Handler
 -- ^ A 'servant-server' for 'ThermoprintAPI'
@@ -157,7 +161,7 @@ listJobs pId     idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a
                             )
 
 getJob :: API.JobId -> Handler Printout
-getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool
+getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSql (get $ castId jobId)
 
 jobStatus :: API.JobId -> Handler JobStatus
 jobStatus jobId = maybe (throwError err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing
@@ -174,36 +178,36 @@ abortJob needle = do
       return . not $ ((==) `on` length) pending filtered
     when found $ do
       $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
-      notify $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
+      notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
     return found
   when (not found) $ throwError err404
 
 listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
-listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap
+listDrafts = runSql (selectSourceRes [] []) >>= lift . flip with toMap
   where
     toMap source = fmap Map.fromList . sourceToList $ (\(Entity key (Draft title _)) -> (castId key, title)) `mapOutput` source
 
 addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
 addDraft title content = do
-  id <- fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool
+  id <- castId <$> runSql (insert $ Draft title content)
   $(logInfo) $ "Added draft #" <> (T.pack $ show (castId id :: Integer)) <> " (" <> (T.pack $ show title) <> ")"
-  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
+  notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
   return id
 
 updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
 updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do
-  void . runSqlPool (updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool
+  void . runSql $ updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]
   $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer))
-  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId
+  notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId
 
 getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
-getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
+getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSql (get $ castId draftId)
 
 deleteDraft :: API.DraftId -> Handler ()
 deleteDraft draftId = do
-  runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool
+  runSql $ delete (castId draftId :: Key Draft)
   $(logInfo) $ "Made sure draft #" <> (T.pack $ show (castId draftId :: Integer)) <> " is Deleted"
-  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
+  notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
 
 printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
-printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
+printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSql (get $ castId draftId)
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index 722d4ed..ae0c6a0 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -50,7 +50,7 @@ import           Data.Time.Clock
 
 import           Thermoprint.Server.Queue
 
-newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m) => Printout -> m (Maybe PrintingError) }
+newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m, MonadUnliftIO m) => Printout -> m (Maybe PrintingError) }
 
 data Printer = Printer
   { print :: PrinterMethod
@@ -68,7 +68,7 @@ atomically' = liftIO . atomically
 
 runPrinter :: ( MonadReader ConnectionPool m
               , MonadLogger m
-              , MonadBaseControl IO m
+              , MonadUnliftIO m
               , MonadResource m
               , MonadMask m
               ) => Printer -> m ()
@@ -95,7 +95,7 @@ runPrinter Printer{..} = forever $ do
 addToQueue :: ( MonadReader ConnectionPool m
               , MonadLogger m
               , MonadResource m
-              , MonadBaseControl IO m
+              , MonadUnliftIO m
               ) => Printout -> Printer -> m JobId
 addToQueue printout Printer{..} = do
   jobId <- runSqlPool (insert $ Job printout) =<< ask
diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs
index ce818ee..441c74d 100644
--- a/server/src/Thermoprint/Server/Printer/Generic.hs
+++ b/server/src/Thermoprint/Server/Printer/Generic.hs
@@ -63,10 +63,10 @@ import Prelude hiding (mapM_, sequence_, lines)
 genericPrint :: FilePath -> PrinterMethod
 genericPrint path = PM $ genericPrint' path
 
-genericPrint' :: (MonadIO m, MonadMask m, MonadLogger m) => FilePath -> Printout -> m (Maybe PrintingError)
+genericPrint' :: (MonadIO m, MonadMask m, MonadLogger m, MonadUnliftIO m) => FilePath -> Printout -> m (Maybe PrintingError)
 genericPrint' path = flip catches handlers . withFile path . print
   where
-    withFile path f = flip withEx f $ mkAcquire (openFile path WriteMode >>= (\h -> h <$ hSetBuffering h NoBuffering)) hClose
+    withFile path f = flip with f $ mkAcquire (openFile path WriteMode >>= (\h -> h <$ hSetBuffering h NoBuffering)) hClose
     handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String)
                , Handler $ return . Just . EncError
                , Handler $ return . Just
diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs
index aa26fe3..fb5deb9 100644
--- a/server/src/Thermoprint/Server/Queue.hs
+++ b/server/src/Thermoprint/Server/Queue.hs
@@ -180,7 +180,7 @@ runQM gcChan qm (extractQueue -> q) = sleep =<< qm'
       | otherwise = return ()
 
 jobGC :: ( MonadReader ConnectionPool m
-         , MonadBaseControl IO m
+         , MonadUnliftIO m
          , MonadIO m
          ) => TChan JobId -> m ()
 -- ^ Listen for 'JobId's on a 'TChan' and delete them from the database 'forever'
diff --git a/server/src/Thermoprint/Server/Queue/Utils.hs b/server/src/Thermoprint/Server/Queue/Utils.hs
index 745053e..0255250 100644
--- a/server/src/Thermoprint/Server/Queue/Utils.hs
+++ b/server/src/Thermoprint/Server/Queue/Utils.hs
@@ -22,7 +22,7 @@ import Servant.Utils.Enter
 import Thermoprint.Server.Queue
 
 standardCollapse :: MonadIO m => IdentityT IO :~> m
-standardCollapse = Nat $ liftIO . runIdentityT
+standardCollapse = NT $ liftIO . runIdentityT
 
 standardSleep :: Monad (QueueManagerM t) => QueueManager t
 -- ^ Instruct 'runQM' to sleep some standard amount of time