From d71b088528e18be357da61522bda31defab1b710 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 24 Jan 2016 17:28:26 +0000
Subject: Additional job handlers

---
 server/src/Thermoprint/Server/API.hs | 37 ++++++++++++++++++++++++++++--------
 1 file changed, 29 insertions(+), 8 deletions(-)

diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index a1efb8f..bff8eed 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
 
 module Thermoprint.Server.API
        ( ProtoHandler, Handler
@@ -38,7 +39,11 @@ import Control.Monad ((<=<), liftM2)
 import Prelude hiding ((.), id, mapM)
 import Control.Category
 
+import Data.Foldable (toList)
 import Data.Traversable (mapM)
+import Data.Bifunctor
+import Data.Monoid
+import Data.Maybe
 
 import Database.Persist
 import Database.Persist.Sql
@@ -82,16 +87,26 @@ thermoprintServer = listPrinters
     (<||>) = liftM2 (:<|>)
     infixr 9 <||>
 
-lookupPrinter :: Maybe PrinterId -> Handler Printer
+lookupPrinter :: Maybe PrinterId -> Handler (PrinterId, Printer)
 lookupPrinter pId = asks printers >>= maybePrinter' pId
   where
     maybePrinter' Nothing printerMap
       | Map.null printerMap = left $ err501 { errBody = "No printers available" }
-      | otherwise = return . snd $ Map.findMin printerMap
+      | otherwise = return $ Map.findMin printerMap
     maybePrinter (Just pId) printerMap
-      | Just printer <- Map.lookup pId printerMap = return printer
+      | Just printer <- Map.lookup pId printerMap = return (pId, printer)
       | otherwise = left $ err404 { errBody = "No such printer" }
 
+queue' :: MonadIO m => Printer -> m Queue
+queue' = liftIO . readTVarIO . queue
+
+extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus)
+extractJobs (pId, Queue pending current history) = fmap (, Queued pId) pending' <> maybe Seq.empty Seq.singleton (fmap (, Printing pId) current') <> fmap (second $ maybe Done Failed) history'
+  where
+    pending' = fmap (castId' . unJobKey) pending
+    current' = fmap (castId' . unJobKey) current
+    history' = fmap (first $ castId' . unJobKey) history
+
 listPrinters :: Handler (Map PrinterId PrinterStatus)
 listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask)
   where
@@ -99,19 +114,25 @@ listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers
     toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id
 
 queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
-queueJob pId printout = lift . fmap (castId' . unJobKey) . withReaderT sqlPool . addToQueue printout =<< lookupPrinter pId
+queueJob pId printout = lift . fmap (castId' . unJobKey) . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId
 
 printerStatus :: PrinterId -> Handler PrinterStatus
-printerStatus = return undefined
+printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just
+  where
+    queueToStatus (Queue _ Nothing   _) = Available
+    queueToStatus (Queue _ (Just id) _) = Busy . castId' $ unJobKey id
 
 listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
-listJobs = return undefined
+listJobs Nothing minId maxId = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId) =<< asks (Map.keys . printers)
+listJobs pId     minId maxId = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId
+  where
+    filterJobs = Seq.filter (\(id, _) -> maybe True (< id) minId && maybe True (> id) maxId)
 
 getJob :: API.JobId -> Handler Printout
-getJob = return undefined
+getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get . JobKey . SqlBackendKey $ castId jobId) =<< asks sqlPool
 
 jobStatus :: API.JobId -> Handler JobStatus
-jobStatus = return undefined
+jobStatus jobId = maybe (left err404) return . lookup jobId . toList =<< listJobs Nothing Nothing Nothing
 
 deleteJob :: API.JobId -> Handler ()
 deleteJob = return undefined
-- 
cgit v1.2.3