Queue managers

4 files changed, 41 insertions, 6 deletions

diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index 3700f45..d9cea9d 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -56,6 +56,9 @@ data Printer = Printer
   , queue :: TVar Queue
   }
 
+instance HasQueue Printer where
+  extractQueue = queue
+
 printer :: MonadResource m => m PrinterMethod -> m Printer
 printer p = Printer <$> p <*> liftIO (newTVarIO def)
 
diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs
index 672d540..bae9617 100644
--- a/server/src/Thermoprint/Server/Queue.hs
+++ b/server/src/Thermoprint/Server/Queue.hs
@@ -1,7 +1,12 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
+{-# LANGUAGE ExistentialQuantification #-}
 
 module Thermoprint.Server.Queue
        ( Queue(..), QueueEntry(..)
+       , HasQueue(..)
+       , QueueManager(..), runQM
        ) where
 
 import           Thermoprint.API (PrintingError(..), Printout)
@@ -12,14 +17,22 @@ import           Thermoprint.Server.Database
 import           Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
 
-import Data.Time
+import           Data.Time
+import           Data.Time.Clock
 
 import           Control.DeepSeq (NFData)
 import           Data.Typeable (Typeable)
 import           GHC.Generics (Generic)
 
+import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Monad.State
+
 import           Data.Default.Class
 
+import           Control.Monad.Morph
+import           Control.Monad.Trans.Compose
+
 -- | Zipper for 'Seq QueueEntry' with additional support for 'PrintingError' in the section after point
 data Queue = Queue
   { pending :: Seq QueueEntry -- ^ Pending jobs, closest last
@@ -28,6 +41,12 @@ data Queue = Queue
   }
   deriving (Typeable, Generic, NFData)
 
+class HasQueue a where
+  extractQueue :: a -> TVar Queue
+
+instance HasQueue (TVar Queue) where
+  extractQueue = id
+
 instance Default Queue where
   def = Queue
     { pending = Seq.empty
@@ -41,3 +60,15 @@ data QueueEntry = QueueEntry
   }
   deriving (Typeable, Generic, NFData)
 
+type QueueManager t = ComposeT (StateT Queue) t STM DiffTime
+
+runQM :: ( HasQueue q
+         , MFunctor t
+         , MonadTrans t
+         , MonadIO (t IO)
+         , Monad (t STM)
+         ) => QueueManager t -> q -> t IO ()
+runQM qm (extractQueue -> q) = forever $ liftIO . threadDelay . toMicro =<< qm'
+  where
+    qm' = hoist atomically $ (\(a, s) -> lift (writeTVar q s) >> return a) =<< runStateT (getComposeT qm) =<< lift (readTVar q)
+    toMicro = (`div` 10^6) . fromEnum
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index b948ce3..2eda3b5 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -47,6 +47,7 @@ library
                      , transformers >=0.3.0 && <1
                      , wai >=3.0.4 && <4
                      , warp >=3.1.9 && <4
+                     , mmorph >=1.0.5 && <2
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index afcf2ba..1cbccd2 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,8 +1,8 @@
 { mkDerivation, base, conduit, containers, data-default-class
-, deepseq, dyre, either, exceptions, monad-control, monad-logger
-, mtl, persistent, persistent-sqlite, persistent-template
-, resourcet, servant-server, stdenv, stm, text, thermoprint-spec
-, time, transformers, wai, warp
+, deepseq, dyre, either, exceptions, mmorph, monad-control
+, monad-logger, mtl, persistent, persistent-sqlite
+, persistent-template, resourcet, servant-server, stdenv, stm, text
+, thermoprint-spec, time, transformers, wai, warp
 }:
 mkDerivation {
   pname = "thermoprint-server";
@@ -12,7 +12,7 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     base conduit containers data-default-class deepseq dyre either
-    exceptions monad-control monad-logger mtl persistent
+    exceptions mmorph monad-control monad-logger mtl persistent
     persistent-template resourcet servant-server stm text
     thermoprint-spec time transformers wai warp
   ];