log-warper 1.8.6 → 1.8.7
raw patch · 5 files changed
+152/−1 lines, 5 filesdep +lifted-asyncdep +o-clock
Dependencies added: lifted-async, o-clock
Files
- CHANGES.md +7/−0
- examples/Playground.hs +26/−0
- log-warper.cabal +10/−1
- src/System/Wlog.hs +8/−0
- src/System/Wlog/Concurrent.hs +101/−0
CHANGES.md view
@@ -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 =====
examples/Playground.hs view
@@ -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
log-warper.cabal view
@@ -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
src/System/Wlog.hs view
@@ -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
+ src/System/Wlog/Concurrent.hs view
@@ -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))