Queue managers

2 files changed, 35 insertions, 1 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