diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +1.8.7 +===== + +* [#52](https://github.com/serokell/log-warper/issues/52): + Add `System.Wlog.Concurrent` module for `ghc-8.2.2` which + allows to run action in parallel with logging. + 1.8.6 ===== diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -1,15 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | Testing module to play with logging. module Main where import Universum +#if ( __GLASGOW_HASKELL__ >= 802 ) +import Control.Monad.Trans.Control (MonadBaseControl) +#endif import Data.Yaml.Pretty (defConfig, encodePretty) import Lens.Micro ((?~)) +#if ( __GLASGOW_HASKELL__ >= 802 ) +import Time (sec, threadDelay) +#endif import System.Wlog (CanLog, atLogger, defaultConfig, infoPlus, launchFromFile, launchWithConfig, logDebug, logError, logInfo, logNotice, logWarning, ltSeverity, modifyLoggerName, parseLoggerConfig, productionB, usingLoggerName) +#if ( __GLASGOW_HASKELL__ >= 802 ) +import System.Wlog (WithLoggerIO, launchSimpleLogging, logWarningWaitInf) +#endif testLoggerConfigPath :: FilePath testLoggerConfigPath = "logger-config-example.yaml" @@ -52,3 +66,15 @@ putTextLn "\nFrom file configurations.." launchFromFile testLoggerConfigPath "node" runPlayLog + +#if ( __GLASGOW_HASKELL__ >= 802 ) + launchSimpleLogging "concurrent" concurrentActions + +concurrentActions :: forall m . (WithLoggerIO m, MonadBaseControl IO m) => m () +concurrentActions = logWarningWaitInf 2 "stupid action" someStupidAction + where + someStupidAction :: m () + someStupidAction = replicateM_ 10 $ do + threadDelay $ sec 1 + liftIO $ putTextLn "HEYYEYAAEYAAAEYAEYAA" +#endif diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -1,5 +1,5 @@ name: log-warper -version: 1.8.6 +version: 1.8.7 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT @@ -39,6 +39,8 @@ System.Wlog.PureLogging System.Wlog.Severity System.Wlog.Terminal + if impl(ghc >= 8.2.2) + exposed-modules: System.Wlog.Concurrent other-modules: System.Wlog.Color System.Wlog.MemoryQueue @@ -51,6 +53,7 @@ , directory ^>= 1.3 , filepath ^>= 1.4.1 , fmt ^>= 0.5.0.0 + , lifted-async ^>= 0.9 , microlens-platform ^>= 0.3.9 , monad-control ^>= 1.0.1.0 , monad-loops ^>= 0.4.3 @@ -64,6 +67,9 @@ , unordered-containers >= 0.2.7.1 && < 0.2.9 , vector ^>= 0.12 , yaml ^>= 0.8.20 + if impl(ghc >= 8.2.2) + build-depends: o-clock ^>= 0.0 + if !os(windows) build-depends: unix @@ -86,7 +92,10 @@ build-depends: log-warper , universum >= 1.0.2 , microlens >= 0.4 + , monad-control ^>= 1.0.1.0 , yaml >= 0.8.20 + if impl(ghc >= 8.2.2) + build-depends: o-clock ^>= 0.0 hs-source-dirs: examples default-language: Haskell2010 diff --git a/src/System/Wlog.hs b/src/System/Wlog.hs --- a/src/System/Wlog.hs +++ b/src/System/Wlog.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | -- Module : System.Wlog -- Copyright : (c) Serokell, 2016 @@ -13,6 +15,9 @@ module System.Wlog ( module System.Wlog.CanLog +#if ( __GLASGOW_HASKELL__ >= 802 ) + , module System.Wlog.Concurrent +#endif , module System.Wlog.Exception , module System.Wlog.FileUtils , module System.Wlog.HasLoggerName @@ -29,6 +34,9 @@ ) where import System.Wlog.CanLog +#if ( __GLASGOW_HASKELL__ >= 802 ) +import System.Wlog.Concurrent +#endif import System.Wlog.Exception import System.Wlog.FileUtils import System.Wlog.HasLoggerName diff --git a/src/System/Wlog/Concurrent.hs b/src/System/Wlog/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Concurrent.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module introduces functions that allow to run action in parallel with logging. + +module System.Wlog.Concurrent + ( WaitingDelta (..) + , CanLogInParallel + , logWarningLongAction + , logWarningWaitOnce + , logWarningWaitLinear + , logWarningWaitInf + ) where + +import Universum + +import Control.Concurrent.Async.Lifted (withAsyncWithUnmask) +import Control.Monad.Trans.Control (MonadBaseControl) +import Fmt ((+|), (+||), (|+), (||+)) +import GHC.Real ((%)) +import Time (RatioNat, Second, Time, threadDelay, timeMul) + +import System.Wlog.CanLog (WithLoggerIO, logWarning) + +-- | Data type to represent waiting strategy for printing warnings +-- if action take too much time. +data WaitingDelta + -- | wait s seconds and stop execution + = WaitOnce (Time Second) + -- | wait s, s * 2, s * 3 , s * 4 , ... seconds + | WaitLinear (Time Second) + -- | wait m, m * q, m * q^2, m * q^3, ... microseconds + | WaitGeometric (Time Second) RatioNat + deriving (Show) + + +-- | Constraint for something that can be logged in parallel with other action. +type CanLogInParallel m = (MonadBaseControl IO m, WithLoggerIO m) + +-- | Run action and print warning if it takes more time than expected. +logWarningLongAction :: forall m a . CanLogInParallel m + => (Text -> m ()) -> WaitingDelta -> Text -> m a -> m a +logWarningLongAction logFunc delta actionTag action = + -- Previous implementation was + -- + -- bracket (fork $ waitAndWarn delta) killThread (const action) + -- + -- but this has a subtle problem: 'killThread' can be interrupted even + -- when exceptions are masked, so it's possible that the forked thread is + -- left running, polluting the logs with misinformation. + -- + -- 'withAsync' is assumed to take care of this, and indeed it does for + -- 'Production's implementation, which uses the definition from the async + -- package: 'uninterruptibleCancel' is used to kill the thread. + -- + -- thinking even more about it, unmasking auxilary thread is crucial if + -- this function is going to be called under 'mask'. + withAsyncWithUnmask (\unmask -> unmask $ waitAndWarn delta) (const action) + where + printWarning :: Time Second -> m () + printWarning t = logFunc $ "Action `"+|actionTag|+"` took more than "+||t||+"" + + waitAndWarn :: WaitingDelta -> m () + waitAndWarn (WaitOnce s) = delayAndPrint s s + waitAndWarn (WaitLinear s) = + let waitLoop :: Time Second -> m () + waitLoop acc = do + delayAndPrint s acc + waitLoop (acc + s) + in waitLoop s + waitAndWarn (WaitGeometric ms k) = + let waitLoop :: Time Second -> Time Second -> m () + waitLoop acc delayT = do + let newAcc = acc + delayT + let newDelayT = k `timeMul` delayT + delayAndPrint delayT newAcc + waitLoop newAcc newDelayT + in waitLoop 0 ms + + delayAndPrint :: Time Second -> Time Second -> m () + delayAndPrint delayT printT = do + threadDelay delayT + printWarning printT + +{- Helper functions to avoid dealing with data type -} + +-- | Specialization of 'logWarningLongAction' with 'WaitOnce'. +logWarningWaitOnce :: CanLogInParallel m => Time Second -> Text -> m a -> m a +logWarningWaitOnce = logWarningLongAction logWarning . WaitOnce + +-- | Specialization of 'logWarningLongAction' with 'WaiLinear'. +logWarningWaitLinear :: CanLogInParallel m => Time Second -> Text -> m a -> m a +logWarningWaitLinear = logWarningLongAction logWarning . WaitLinear + +-- | Specialization of 'logWarningLongAction' with 'WaitGeometric' +-- with parameter @1.3@. Accepts 'Second'. +logWarningWaitInf :: CanLogInParallel m => Time Second -> Text -> m a -> m a +logWarningWaitInf = logWarningLongAction logWarning + . (`WaitGeometric` (13 % 10))