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
|
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
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.State
import Control.Category
import Servant.Server.Internal.Enter (enter, (:~>)(..))
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 Prelude hiding (length, maximum, id, (.))
data QMConfig m where
QMConfig :: ( MonadTrans t
, MFunctor t
, Monad (t STM)
, MonadIO (t IO)
) => QueueManager t -> (t IO) :~> m -> QMConfig m
QMConfig' :: ( MonadIO m
) => ( forall t. ( MonadTrans t
, MFunctor t
, Monad (t STM)
, MonadIO (t IO)
, Monad (QueueManagerM t)
) => QueueManager t
) -> QMConfig m
instance MonadIO m => Default (QMConfig m) where
def = idQM
intersection :: (Functor f, Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m
intersection = foldr' (qmCombine Q.intersection) idQM
idQM :: MonadIO m => QMConfig m
idQM = QMConfig' Q.idQM
union :: (Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m
union = foldr' (qmCombine Q.union) idQM
nullQM :: MonadIO m => QMConfig m
nullQM = QMConfig' Q.nullQM
qmCombine :: ([QueueManager t] -> QueueManager t) -> QMConfig m -> QMConfig m -> QMConfig m
qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = undefined
where
natA :: t IO :~> m
natB :: t' IO :~> m
---
hoistNat natB :: t (t' IO) :~> t m
--
? :: t m :~> m
natAB :: ComposeT t t' IO :~> m
runQM :: ( HasQueue q ) => TChan JobId -> QMConfig m -> q -> t IO ()
runQM gcChan (QMConfig qm nat) q = unNat nat $ runQM gcChan qm q
runQM gcChan (QMConfig' qm) q = hoist liftIO $ 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 :: MonadIO m => Int -> QMConfig m
-- ^ 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 :: MonadIO m => NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
-> QMConfig m
-- ^ 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
|
