1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE ExistentialQuantification #-}
module Thermoprint.Server.Queue
( Queue(..), QueueEntry(..)
, HasQueue(..)
, QueueManager(..), runQM
) where
import Thermoprint.API (PrintingError(..), Printout)
import qualified Thermoprint.API as API (JobStatus(..))
import Thermoprint.Server.Database
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
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
, current :: Maybe QueueEntry
, history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first
}
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
, current = Nothing
, history = Seq.empty
}
data QueueEntry = QueueEntry
{ jobId :: JobId
, created :: UTCTime
}
deriving (Typeable, Generic, NFData)
-- | A queue manager periodically modifies a 'Queue', e.g. for cleanup of old jobs
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 ()
-- ^ Periodically modify a 'Queue'
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
|
