From d07c1cf5d04f802501a98ce986b78d42b7329901 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 29 Feb 2016 22:14:57 +0100 Subject: Further work on QMConfig tools --- server/src/Thermoprint/Server.hs | 6 +- server/src/Thermoprint/Server/QMConfig.hs | 92 ++++++++++++++++++------------- server/thermoprint-server.cabal | 1 + server/thermoprint-server.nix | 19 ++++--- 4 files changed, 69 insertions(+), 49 deletions(-) diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 49f3e82..c2a4972 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -89,7 +89,7 @@ import Debug.Trace data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour , printers :: Map API.PrinterId Printer - , queueManagers :: API.PrinterId -> QMConfig m + , queueManagers :: API.PrinterId -> QMConfig } instance MonadIO m => Default (Config m) where @@ -99,7 +99,7 @@ instance MonadIO m => Default (Config m) where , queueManagers = const def } -withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m) +withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig)] -> m (Config m) -- ^ Add a list of printers to a 'Config' withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg) where @@ -140,7 +140,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams gcChan <- liftIO newTChanIO fork tMgr $ jobGC gcChan let - runQM' = runQM gcChan . queueManagers + runQM' = liftIO . 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 8f08faf..7255c8c 100644 --- a/server/src/Thermoprint/Server/QMConfig.hs +++ b/server/src/Thermoprint/Server/QMConfig.hs @@ -4,6 +4,12 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE IncoherentInstances #-} module Thermoprint.Server.QMConfig ( QMConfig(..) @@ -21,9 +27,13 @@ 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 (enter, (:~>)(..)) +import Servant.Server.Internal.Enter + +import Data.Constraint +import Data.Constraint.Forall import Data.Default.Class @@ -37,52 +47,60 @@ 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, (.)) -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 +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 :: (Functor f, Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m +intersection :: Foldable f => f QMConfig -> QMConfig intersection = foldr' (qmCombine Q.intersection) idQM -idQM :: MonadIO m => QMConfig m +idQM :: QMConfig idQM = QMConfig' Q.idQM -union :: (Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m +union :: Foldable f => f QMConfig -> QMConfig union = foldr' (qmCombine Q.union) idQM -nullQM :: MonadIO m => QMConfig m +nullQM :: QMConfig nullQM = QMConfig' Q.nullQM -qmCombine :: ([QueueManager t] -> QueueManager t) -> QMConfig m -> QMConfig m -> QMConfig m -qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = undefined +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 - 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 + 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 @@ -90,15 +108,15 @@ standardSleep :: Monad (QueueManagerM t) => QueueManager t -- /TODO/: Investigate implementing a smarter algorithm (PID-controller) standardSleep = return $ 20 -limitHistorySize :: MonadIO m => Int -> QMConfig m +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 :: MonadIO m => NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry' - -> QMConfig m +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 diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 2fa04c5..0a5690e 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -66,6 +66,7 @@ library , wai-websockets >=3.0.0 && <4 , wai >=3.0.5 && <4 , network-uri >=2.6.0 && <3 + , constraints >=0.8 && <1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix index 6ff8b10..ff8ebd4 100644 --- a/server/thermoprint-server.nix +++ b/server/thermoprint-server.nix @@ -1,7 +1,7 @@ { mkDerivation, async, base, binary, bytestring, conduit -, containers, data-default-class, deepseq, dyre, either, encoding -, exceptions, extended-reals, filelock, hspec, mmorph -, monad-control, monad-logger, mtl, network-uri, persistent +, constraints, containers, data-default-class, deepseq, dyre +, either, encoding, exceptions, extended-reals, filelock, hspec +, mmorph, monad-control, monad-logger, mtl, network-uri, persistent , persistent-sqlite, persistent-template, QuickCheck , quickcheck-instances, resourcet, servant, servant-server, stdenv , stm, temporary, text, thermoprint-client, thermoprint-spec, time @@ -14,12 +14,13 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - base binary bytestring conduit containers data-default-class - deepseq dyre either encoding exceptions extended-reals filelock - mmorph monad-control monad-logger mtl network-uri persistent - persistent-template QuickCheck quickcheck-instances resourcet - servant servant-server stm text thermoprint-spec time transformers - wai wai-websockets warp websockets + base binary bytestring conduit constraints containers + data-default-class deepseq dyre either encoding exceptions + extended-reals filelock mmorph monad-control monad-logger mtl + network-uri persistent persistent-template QuickCheck + quickcheck-instances resourcet servant servant-server stm text + thermoprint-spec time transformers wai wai-websockets warp + websockets ]; executableHaskellDepends = [ base monad-logger mtl persistent-sqlite resourcet -- cgit v1.2.3