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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE IncoherentInstances #-}
module Thermoprint.Server.QMConfig
( QMConfig(..)
, nullQM
, idQM
, standardSleep
, limitHistorySize
, limitHistoryAge
) where
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Control.Monad.Trans.Identity
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Monad.Trans.Compose
import Control.Monad.State
import Control.Category
import Servant.Server.Internal.Enter
import Data.Constraint
import Data.Constraint.Forall
import Data.Default.Class
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Time
import Data.Foldable
import Control.Concurrent.STM
import Thermoprint.Server.Queue hiding (idQM, intersection, nullQM, union, runQM)
import qualified Thermoprint.Server.Queue as Q
import Thermoprint.Server.Database (JobId)
import Prelude hiding (length, maximum, id, (.))
type QMTrans t = ( MonadTrans t
, MFunctor t
, Monad (t STM)
, MonadIO (t IO)
, Monad (QueueManagerM t)
, MonadState Queue (QueueManagerM t)
)
class QMTrans1 (t :: (* -> *) -> * -> *) (t' :: (* -> *) -> * -> *)
instance QMTrans (ComposeT t t') => QMTrans1 t t'
type QMTrans' t = (QMTrans t, Forall (QMTrans1 t))
data QMConfig where
QMConfig :: QMTrans' t => QueueManager t -> (forall m. (t m) :~> m) -> QMConfig
QMConfig' :: ( forall t . QMTrans' t => QueueManager t
) -> QMConfig
instance Default QMConfig where
def = idQM
intersection :: Foldable f => f QMConfig -> QMConfig
intersection = foldr' (qmCombine Q.intersection) idQM
idQM :: QMConfig
idQM = QMConfig' Q.idQM
union :: Foldable f => f QMConfig -> QMConfig
union = foldr' (qmCombine Q.union) idQM
nullQM :: QMConfig
nullQM = QMConfig' Q.nullQM
qmCombine :: (forall f t. (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t) -> QMConfig -> QMConfig -> QMConfig
qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = (QMConfig (qmCombine' [a', b']) (natComp natA natB)) \\ (inst :: Forall (QMTrans1 t) :- QMTrans (ComposeT t t'))
where
a' = mapComposeT (hoist $ ComposeT . hoist lift) a
b' = mapComposeT (hoist $ ComposeT . lift) b
natComp :: (forall m. t m :~> m)
-> (forall m. t' m :~> m)
-> (forall m. (MFunctor t
, Monad (t' m)
) => ComposeT t t' m :~> m
)
natComp natA natB = natA . hoistNat natB . Nat getComposeT
runQM :: ( HasQueue q ) => TChan JobId -> QMConfig -> q -> IO ()
runQM gcChan (QMConfig qm nat) q = unNat nat $ Q.runQM gcChan qm q
runQM gcChan (QMConfig' qm) q = runIdentityT $ Q.runQM gcChan qm q
standardSleep :: Monad (QueueManagerM t) => QueueManager t
-- ^ Instruct 'runQM' to sleep some standard amount of time
--
-- /TODO/: Investigate implementing a smarter algorithm (PID-controller)
standardSleep = return $ 20
limitHistorySize :: Int -> QMConfig
-- ^ Limit a 'Queue's 'history's size to some number of 'QueueEntry's
limitHistorySize max = QMConfig' $ modify' limitSize >> standardSleep
where
limitSize :: Queue -> Queue
limitSize q@Queue{..} = q { history = Seq.take max history }
limitHistoryAge :: NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
-> QMConfig
-- ^ Limit a 'Queue's 'history's contents to 'QueueEntry's below a certain age
limitHistoryAge maxAge = QMConfig' $ modify' limitAge >> standardSleep
where
limitAge :: Queue -> Queue
limitAge q@Queue{..} = q { history = Seq.filter (filterAge . created . fst) history}
where
youngest :: UTCTime
youngest = maximum $ created . fst <$> history
filterAge :: UTCTime -> Bool
filterAge time = not $ (youngest `diffUTCTime` time) > maxAge
|
