From 9dd562eef0c4ff6f15e6ef3e7c360f5fdf04573b Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 28 Jan 2016 12:16:27 +0000
Subject: more logging

---
 server/src/Thermoprint/Server/API.hs | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

(limited to 'server/src')

diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index 77f33e7..4d036ce 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -67,6 +67,9 @@ data HandlerInput = HandlerInput { sqlPool  :: ConnectionPool -- ^ How to intera
                                  , printers :: Map PrinterId Printer
                                  }
 
+instance MonadLogger m => MonadLogger (EitherT a m) where
+  monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl
+
 handlerNat :: ( MonadReader ConnectionPool m
               , MonadLoggerIO m
               ) => Map PrinterId Printer -> m (Handler :~> EitherT ServantErr IO)
@@ -157,7 +160,7 @@ abortJob jobId = do
       let filtered = Seq.filter (/= castId jobId) pending
       writeTVar (queue p) $ current { pending = filtered }
       return . not $ ((==) `on` length) pending filtered
-    when found . lift . $(logInfo) $ "Removed " <> (T.pack $ show (castId jobId :: Integer)) <> " from " <> (T.pack . show $ pId')
+    when found . $(logInfo) $ "Removed job #" <> (T.pack $ show (castId jobId :: Integer)) <> " from " <> (T.pack . show $ pId')
     return found
   when (not found) $ left err404
 
@@ -167,16 +170,23 @@ listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with t
     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 = fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool
+addDraft title content = do
+  id <- fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool
+  $(logInfo) $ "Added draft #" <> (T.pack $ show (castId id :: Integer)) <> " (" <> (T.pack $ show title) <> ")"
+  return id
 
 updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
-updateDraft draftId title content = (\(KeyNotFound _) -> left $ err404) `handle` (runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool)
+updateDraft draftId title content = handle (\(KeyNotFound _) -> left $ err404) $ do
+  runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool
+  $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer))
 
 getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
 getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
 
 deleteDraft :: API.DraftId -> Handler ()
-deleteDraft draftId = runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool
+deleteDraft draftId = do
+  runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool
+  $(logInfo) $ "Made sure draft #" <> (T.pack $ show (castId draftId :: Integer)) <> " is Deleted"
 
 printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
 printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
-- 
cgit v1.2.3