runPrinter

3 files changed, 64 insertions, 12 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)
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 8862255..926118d 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -40,6 +40,7 @@ library
                      , either >=4.4.1 && <5
                      , text >=1.2.1 && <2
                      , stm >=2.4.4 && <3
+                     , deepseq >=1.4.1 && <2
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 57e94a3..69bff1d 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,5 +1,5 @@
-{ mkDerivation, base, containers, data-default-class, dyre, either
-, monad-logger, mtl, persistent, persistent-sqlite
+{ mkDerivation, base, containers, data-default-class, deepseq, dyre
+, either, monad-logger, mtl, persistent, persistent-sqlite
 , persistent-template, resourcet, servant-server, stdenv, stm, text
 , thermoprint-spec, transformers, wai, warp
 }:
@@ -10,9 +10,9 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base containers data-default-class dyre either monad-logger mtl
-    persistent persistent-template resourcet servant-server stm text
-    thermoprint-spec transformers wai warp
+    base containers data-default-class deepseq dyre either monad-logger
+    mtl persistent persistent-template resourcet servant-server stm
+    text thermoprint-spec transformers wai warp
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet