QMConfig tools stuck at combineQM

3 files changed, 77 insertions, 8 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index cd3a4ed..49f3e82 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -14,8 +14,8 @@ module Thermoprint.Server
        , module Data.Default.Class
        , module Servant.Server.Internal.Enter
        , module Thermoprint.Server.Printer
-       , module Thermoprint.Server.Queue
        , module Thermoprint.Server.QMConfig
+       , Queue(..), QueueEntry(..)
        ) where
 
 import Data.Default.Class
@@ -78,7 +78,7 @@ import Thermoprint.Server.Push
 
 import Thermoprint.Server.Database
 import Thermoprint.Server.Printer
-import Thermoprint.Server.Queue
+import Thermoprint.Server.Queue hiding (intersection, idQM, union, nullQM, runQM)
 import Thermoprint.Server.QMConfig
 import qualified Thermoprint.Server.API as API (thermoprintServer)
 import Thermoprint.Server.API hiding (thermoprintServer)
@@ -140,8 +140,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
           gcChan <- liftIO newTChanIO
           fork tMgr $ jobGC gcChan
           let
-            runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
-            runQM' (queueManagers -> QMConfig' qm) printer = hoist liftIO $ runQM gcChan qm printer
+            runQM' = runQM gcChan . queueManagers
           mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
           nChan <- liftIO $ newBroadcastTChanIO
           let
diff --git a/server/src/Thermoprint/Server/QMConfig.hs b/server/src/Thermoprint/Server/QMConfig.hs
index 0cf7beb..8f08faf 100644
--- a/server/src/Thermoprint/Server/QMConfig.hs
+++ b/server/src/Thermoprint/Server/QMConfig.hs
@@ -2,9 +2,16 @@
 {-# 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
@@ -14,15 +21,23 @@ 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 Prelude hiding (id, (.))
 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
+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
@@ -35,8 +50,62 @@ data QMConfig m where
                                 , MFunctor t
                                 , Monad (t STM)
                                 , MonadIO (t IO)
+                                , Monad (QueueManagerM t)
                                 ) => QueueManager t
                     ) -> QMConfig m
 
 instance MonadIO m => Default (QMConfig m) where
-  def = QMConfig idQM $ Nat (liftIO . runIdentityT)
+  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
diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs
index 028ba2d..6407c3c 100644
--- a/server/test/Thermoprint/ServerSpec.hs
+++ b/server/test/Thermoprint/ServerSpec.hs
@@ -13,7 +13,8 @@ import qualified Test.Hspec as Hspec
 import           Test.QuickCheck
 
 import           Thermoprint.API
-import qualified Thermoprint.Server as S
+import qualified Thermoprint.Server as S hiding (intersection, idQM, union, nullQM)
+import qualified Thermoprint.Server.Queue as S
 import           Thermoprint.Client
 
 import           Data.Monoid