1 files changed, 58 insertions, 7 deletions

diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index e66afff..0db98a0 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -1,29 +1,80 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes                    #-}
+{-# LANGUAGE MultiParamTypeClasses         #-}
+{-# LANGUAGE FlexibleContexts              #-}
+{-# LANGUAGE RecordWildCards               #-}
+{-# LANGUAGE OverloadedStrings             #-}
+{-# LANGUAGE TemplateHaskell               #-}
+{-# LANGUAGE StandaloneDeriving            #-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 
 module Thermoprint.Server.Printer
-       ( Printer
+       ( Printer(..)
+       , Queue(..)
+       , runPrinter
        ) where
 
 import Thermoprint.API (PrintingError(..), Printout)
+import qualified Thermoprint.API as API (JobStatus(..))
 
 import Thermoprint.Server.Database
 
 import Database.Persist
 import Database.Persist.Sql
 
-import Data.Sequence (Seq, ViewL(..))
+import Data.Sequence (Seq, ViewL(..), viewl, (<|))
 import qualified Data.Sequence as Seq
 import Data.Map (Map)
 import qualified Data.Map as Map
 
-import Control.Monad.IO.Class (MonadIO)
+import qualified Data.Text as T (pack)
+
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import Control.DeepSeq
+
+import Control.Monad.Trans.Resource
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader
+
+import Control.Monad (forever)
 
 import Control.Concurrent.STM
 
 data Printer = Printer
   { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)
-  , queue :: TVar (Seq JobId)
+  , queue :: TVar Queue
   }
 
-runPrinter :: Printer -> IO ()
-runPrinter = undefined
+-- | Zipper for 'Seq JobId'
+data Queue = Queue
+  { pending :: Seq JobId -- ^ Pending jobs, closest first
+  , current :: Maybe JobId
+  , history :: Seq (JobId, Maybe PrintingError) -- ^ Completed jobs, closest first
+  }
+  deriving (Typeable, Generic, NFData)
+
+atomically' :: MonadIO m => STM a -> m a
+atomically' = liftIO . atomically
+
+runPrinter :: ( MonadReader ConnectionPool m
+              , MonadIO m
+              , MonadLogger m
+              , MonadBaseControl IO m
+              ) => Printer -> m ()
+-- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
+runPrinter Printer{..} = forever $ do
+  jobId <- atomically' $ do
+    (Queue queuePending Nothing history) <- readTVar queue
+    case viewl queuePending of
+      EmptyL               -> retry
+      (jobId :< remaining) -> do
+        writeTVar queue $!! Queue remaining (Just jobId) history
+        return jobId
+  job <- runSqlPool (get jobId) =<< ask
+  case job of
+    Nothing  -> $(logWarn) "Nonexistent job id in printer queue"
+    Just job -> do
+      printReturn <- print (jobContent job)
+      maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show jobId ++ ": ") ++) . show) $ printReturn
+      atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history)