From 36434c74792c50be759172d158be0e9e56e28849 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 1 Mar 2016 00:04:54 +0100
Subject: Thermoprint.Server.Queue.Utils

Reformulated from their flawed QMConfig-version
---
 server/src/Thermoprint/Server.hs             |  2 ++
 server/src/Thermoprint/Server/Queue/Utils.hs | 52 ++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+)
 create mode 100644 server/src/Thermoprint/Server/Queue/Utils.hs

(limited to 'server/src/Thermoprint')

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 446c63e..f73a418 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -16,6 +16,7 @@ module Thermoprint.Server
        , module Servant.Server.Internal.Enter
        , module Thermoprint.Server.Printer
        , module Thermoprint.Server.Queue
+       , module Thermoprint.Server.Queue.Utils
        ) where
 
 import Data.Default.Class
@@ -79,6 +80,7 @@ import Thermoprint.Server.Push
 import Thermoprint.Server.Database
 import Thermoprint.Server.Printer
 import Thermoprint.Server.Queue
+import Thermoprint.Server.Queue.Utils
 import qualified Thermoprint.Server.API as API (thermoprintServer)
 import Thermoprint.Server.API hiding (thermoprintServer)
 
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
-- 
cgit v1.2.3