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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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, ViewL(..), viewl, (|>), (<|))
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
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
import Data.Foldable
import Data.Monoid
-- | 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)
data QueueElem = Pending QueueEntry | Current QueueEntry | History QueueEntry (Maybe PrintingError)
instance Eq QueueElem where
(Pending a) == (Pending b) = a == b
(Current a) == (Current b) = a == b
(History a _) == (History b _) = a == b
_ == _ = False
instance Ord QueueElem where
(Pending _) <= _ = True
(Current _) <= (Pending _) = False
(Current _) <= _ = True
(History _ _) <= (History _ _) = True
(History _ _) <= _ = False
toSeq :: Queue -> Set (Int, QueueElem)
toSeq Queue{..} = fromSeq $ fmap Pending pending <> maybe Seq.empty (Seq.singleton . Current) current <> fmap (uncurry History) history
where
fromSeq = Set.fromAscList . toList . Seq.mapWithIndex ((,))
fromSeq :: Set (Int, QueueElem) -> Queue
fromSeq = foldr' (insert . snd) def
where
insert (Pending e) q@(Queue{..}) = q { pending = pending |> e }
insert (Current e) q = q { current = Just e }
insert (History e p) q@(Queue{..}) = q { history = history |> (e, p) }
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, Eq)
-- | 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
|
