1 files changed, 19 insertions, 15 deletions

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)