From 8dc71c2a4219f2e820e4c55ee7754e184574e8e5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 29 Feb 2016 22:18:53 +0100 Subject: Revert work on QMConfig & associated tools This reverts commit f64e26726ce5468069093aa86fe973ad4be4816c. --- server/src/Thermoprint/Server.hs | 24 ++++-- server/src/Thermoprint/Server/QMConfig.hs | 129 ------------------------------ server/test/Thermoprint/ServerSpec.hs | 3 +- server/thermoprint-server.cabal | 2 - server/thermoprint-server.nix | 19 +++-- 5 files changed, 27 insertions(+), 150 deletions(-) delete mode 100644 server/src/Thermoprint/Server/QMConfig.hs diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index c2a4972..446c63e 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} @@ -14,8 +15,7 @@ module Thermoprint.Server , module Data.Default.Class , module Servant.Server.Internal.Enter , module Thermoprint.Server.Printer - , module Thermoprint.Server.QMConfig - , Queue(..), QueueEntry(..) + , module Thermoprint.Server.Queue ) where import Data.Default.Class @@ -78,8 +78,7 @@ import Thermoprint.Server.Push import Thermoprint.Server.Database import Thermoprint.Server.Printer -import Thermoprint.Server.Queue hiding (intersection, idQM, union, nullQM, runQM) -import Thermoprint.Server.QMConfig +import Thermoprint.Server.Queue import qualified Thermoprint.Server.API as API (thermoprintServer) import Thermoprint.Server.API hiding (thermoprintServer) @@ -89,9 +88,17 @@ 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 + , queueManagers :: API.PrinterId -> QMConfig m } +data QMConfig m = forall t. ( MonadTrans t + , MFunctor t + , Monad (t STM) + , MonadIO (t IO) + ) => QMConfig { manager :: QueueManager t + , collapse :: (t IO) :~> m + } + instance MonadIO m => Default (Config m) where def = Config { dyreError = Nothing , warpSettings = Warp.defaultSettings @@ -99,7 +106,10 @@ instance MonadIO m => Default (Config m) where , queueManagers = const def } -withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig)] -> m (Config m) +instance MonadIO m => Default (QMConfig m) where + def = QMConfig idQM $ Nat (liftIO . runIdentityT) + +withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> 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 +150,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams gcChan <- liftIO newTChanIO fork tMgr $ jobGC gcChan let - runQM' = liftIO . runQM gcChan . queueManagers + runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer 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 deleted file mode 100644 index 7255c8c..0000000 --- a/server/src/Thermoprint/Server/QMConfig.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE IncoherentInstances #-} - -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.Trans.Compose -import Control.Monad.State -import Control.Category -import Servant.Server.Internal.Enter - -import Data.Constraint -import Data.Constraint.Forall - -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 Thermoprint.Server.Database (JobId) - -import Prelude hiding (length, maximum, id, (.)) - -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 :: Foldable f => f QMConfig -> QMConfig -intersection = foldr' (qmCombine Q.intersection) idQM - -idQM :: QMConfig -idQM = QMConfig' Q.idQM - -union :: Foldable f => f QMConfig -> QMConfig -union = foldr' (qmCombine Q.union) idQM - -nullQM :: QMConfig -nullQM = QMConfig' Q.nullQM - -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 - 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 --- --- /TODO/: Investigate implementing a smarter algorithm (PID-controller) -standardSleep = return $ 20 - -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 :: 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 - 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 6407c3c..028ba2d 100644 --- a/server/test/Thermoprint/ServerSpec.hs +++ b/server/test/Thermoprint/ServerSpec.hs @@ -13,8 +13,7 @@ import qualified Test.Hspec as Hspec import Test.QuickCheck import Thermoprint.API -import qualified Thermoprint.Server as S hiding (intersection, idQM, union, nullQM) -import qualified Thermoprint.Server.Queue as S +import qualified Thermoprint.Server as S import Thermoprint.Client import Data.Monoid diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 0a5690e..3f0f832 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -18,7 +18,6 @@ cabal-version: >=1.10 library exposed-modules: Thermoprint.Server - , Thermoprint.Server.QMConfig , Thermoprint.Server.Fork , Thermoprint.Server.Database , Thermoprint.Server.API @@ -66,7 +65,6 @@ 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 ff8ebd4..6ff8b10 100644 --- a/server/thermoprint-server.nix +++ b/server/thermoprint-server.nix @@ -1,7 +1,7 @@ { mkDerivation, async, base, binary, bytestring, conduit -, constraints, containers, data-default-class, deepseq, dyre -, either, encoding, exceptions, extended-reals, filelock, hspec -, mmorph, monad-control, monad-logger, mtl, network-uri, persistent +, 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,13 +14,12 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - 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 + 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 ]; executableHaskellDepends = [ base monad-logger mtl persistent-sqlite resourcet -- cgit v1.2.3