1 files changed, 52 insertions, 0 deletions

diff --git a/server/src/Thermoprint/Server/Queue/Utils.hs b/server/src/Thermoprint/Server/Queue/Utils.hs
new file mode 100644
index 0000000..86b0162
--- /dev/null
+++ b/server/src/Thermoprint/Server/Queue/Utils.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Thermoprint.Server.Queue.Utils
+       ( standardCollapse
+       , standardSleep
+       , limitHistorySize
+       , limitHistoryAge
+       ) where
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Data.Time
+
+import Control.Monad.State
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Identity
+import Servant.Server.Internal.Enter
+
+import Thermoprint.Server.Queue
+
+standardCollapse :: MonadIO m => IdentityT IO :~> m
+standardCollapse = Nat $ liftIO . runIdentityT
+
+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 :: MonadState Queue (QueueManagerM t) => Int -> QueueManager t
+-- ^ Limit a 'Queue's 'history's size to some number of 'QueueEntry's
+limitHistorySize max = modify' limitSize >> standardSleep
+  where
+    limitSize :: Queue -> Queue
+    limitSize q@Queue{..} = q { history = Seq.take max history }
+
+limitHistoryAge :: ( MonadState Queue (QueueManagerM t)
+                   ) => NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
+                   -> QueueManager t
+-- ^ Limit a 'Queue's 'history's contents to 'QueueEntry's below a certain age
+limitHistoryAge  maxAge = 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