co-log 0.1.0 → 0.2.0

raw patch · 14 files changed

+623/−153 lines, 14 filesdep +directorydep +filepathdep +stmdep −base-nopreludedep −reludedep ~basedep ~co-log-coredep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, stm

Dependencies removed: base-noprelude, relude

Dependency ranges changed: base, co-log-core, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−7
• README.lhs +2/−0
• co-log.cabal +36/−20
• example/Main.hs +9/−11
• src/Colog.hs +2/−0
• src/Colog/Actions.hs +18/−86
• src/Colog/Concurrent.hs +322/−0
• src/Colog/Concurrent/Internal.hs +32/−0
• src/Colog/Contra.hs +5/−1
• src/Colog/Message.hs +28/−16
• src/Colog/Monad.hs +7/−4
• src/Colog/Pure.hs +9/−3
• src/Colog/Rotation.hs +131/−0
• src/Prelude.hs +0/−5

@@ -1,18 +1,33 @@-Change log-==========+# Change log -`co-log uses` [PVP Versioning][1].+`co-log` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. -0.1.0-=====+## 0.2.0 — Nov 15, 2018 +* [#45](https://github.com/kowainik/co-log/issues/45):+  Introduce approach for concurrent log writing.+* [#46](https://github.com/kowainik/co-log/issues/46):+  Moves `logStringStdout`, `logStringStderr`, `logStringHandle`,+  `withLogStringFile` from `Colog.Actions` to `Colog.Core.IO`+* [#77](https://github.com/kowainik/co-log/issues/77):+  Remove `relude` from dependencies.+  Add HLint check to Travis CI.+* [#64](https://github.com/kowainik/co-log/issues/64):+  Introduce basic benchmarks.+* [#20](https://github.com/kowainik/co-log/issues/20):+  Add experimental support for logger rotation (see `Colog.Rotation` module).+* [#39](https://github.com/kowainik/co-log/issues/39):+  Support GHC-8.2.2 and GHC-8.6.2.++## 0.1.0+ * [#37](https://github.com/kowainik/co-log/issues/37):   Add bounds to all dependencies. Move `Prelude` to the   `other-modules` section. -0.0.0-=====+## 0.0.0+ * Initially created.  [1]: https://pvp.haskell.org

@@ -31,8 +31,10 @@               usingLoggerT) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Semigroup ((<>)) import qualified Data.Text as Text import qualified Data.Text.IO as TextIO+ ```  ## Simple IO function example

@@ -1,19 +1,27 @@ cabal-version:       2.0 name:                co-log-version:             0.1.0-description:         Logging library-synopsis:            Logging library+version:             0.2.0+synopsis:            Composable Contravariant Comonadic Logging Library+description:+    The default implementation of logging based on [co-log-core](http://hackage.haskell.org/package/co-log-core).+    .+    The ideas behind this package are described in the following blog post:+    .+    * [co-log: Composable Contravariant Combinatorial Comonadic Configurable Convenient Logging](https://kowainik.github.io/posts/2018-09-25-co-log)+ homepage:            https://github.com/kowainik/co-log bug-reports:         https://github.com/kowainik/co-log/issues license:             MPL-2.0 license-file:        LICENSE-author:              Kowainik+author:              Kowainik, Alexander Vershilov maintainer:          xrom.xkov@gmail.com copyright:           2018 Kowainik category:            Logging build-type:          Simple extra-doc-files:     CHANGELOG.md-tested-with:         GHC == 8.4.3+tested-with:         GHC == 8.2.2+                   , GHC == 8.4.4+                   , GHC == 8.6.2  source-repository head   type:                git@@ -23,22 +31,26 @@   hs-source-dirs:      src   exposed-modules:     Colog                            Colog.Actions+                           Colog.Concurrent+                               Colog.Concurrent.Internal                            Colog.Contra                            Colog.Message                            Colog.Monad                            Colog.Pure-  other-modules:       Prelude+                           Colog.Rotation -  build-depends:       base-noprelude >= 4.11 && < 5+  build-depends:       base >= 4.10 && < 4.13                      , ansi-terminal ^>= 0.8                      , bytestring ^>= 0.10.8-                     , co-log-core ^>= 0.1.0+                     , co-log-core ^>= 0.1.1                      , containers >= 0.5.7 && < 0.7                      , contravariant ^>= 1.5+                     , directory ^>= 1.3.0+                     , filepath ^>= 1.4.1                      , mtl ^>= 2.2.2-                     , relude ^>= 0.3.0+                     , stm >= 2.4 && < 2.6                      , text ^>= 1.2.3-                     , time ^>= 1.9.2+                     , time >= 1.8 && < 1.10                      , transformers ^>= 0.5                      , typerep-map ^>= 0.3.0 @@ -51,21 +63,25 @@                        -fhide-source-paths                        -freverse-errors -  default-language:   Haskell2010-  default-extensions: DeriveGeneric-                      GeneralizedNewtypeDeriving-                      InstanceSigs-                      OverloadedStrings-                      RecordWildCards-                      TypeApplications+  default-language:    Haskell2010+  default-extensions:  ConstraintKinds+                       DeriveGeneric+                       GeneralizedNewtypeDeriving+                       LambdaCase+                       OverloadedStrings+                       RecordWildCards+                       ScopedTypeVariables+                       StandaloneDeriving+                       TupleSections+                       TypeApplications+                       ViewPatterns  executable play-colog   hs-source-dirs:      example   main-is:             Main.hs -  build-depends:       base >= 4.9 && < 5+  build-depends:       base                      , co-log-                     , relude                      , typerep-map    ghc-options:         -Wall@@ -84,7 +100,7 @@  executable readme   main-is:             README.lhs-  build-depends:       base >= 4.9 && < 5+  build-depends:       base                      , co-log                      , text 

@@ -1,22 +1,24 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms   #-} {-# LANGUAGE TypeApplications  #-}  module Main where -import Relude+import Prelude hiding (log)  import Control.Concurrent (threadDelay)+import Control.Exception (Exception)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Semigroup ((<>)) -import Colog (pattern D, LogAction, Message (..), PureLogger, WithLog, cmapM, cmap, defaultFieldMap,+import Colog (pattern D, LogAction, Message (..), PureLogger, WithLog, cmap, cmapM, defaultFieldMap,               fmtMessage, fmtRichMessageDefault, log, logException, logInfo, logMessagePure, logMsg,-              logMsgs, logStringStdout, logTextStderr, logTextStdout, logWarning, runPureLog,-              upgradeMessageAction, usingLoggerT, withLog, withLogTextFile, (*<), (>$), (>$<), (>*),-              (>*<), (>|<))+              logMsgs, logPrint, logStringStdout, logTextStderr, logTextStdout, logWarning,+              runPureLog, upgradeMessageAction, usingLoggerT, withLog, withLogTextFile, (*<), (>$),+              (>$<), (>*), (>*<), (>|<))  import qualified Data.TypeRepMap as TM @@ -72,16 +74,12 @@ stringL :: LogAction IO String stringL = logStringStdout --- Combinator that allows to log any showable value-showL :: Show a => LogAction IO a-showL = cmap show stringL- -- Returns log action that logs given string ignoring its input. constL :: String -> LogAction IO a constL s = s >$ stringL  intL :: LogAction IO Int-intL = showL+intL = logPrint  -- log actions that logs single car module carL :: LogAction IO Car

@@ -4,6 +4,7 @@        , module Colog.Message        , module Colog.Monad        , module Colog.Pure+       , module Colog.Rotation        ) where  import Colog.Actions@@ -12,3 +13,4 @@ import Colog.Message import Colog.Monad import Colog.Pure+import Colog.Rotation

@@ -1,12 +1,7 @@ module Colog.Actions-       ( -- * 'String' actions-         logStringStdout-       , logStringStderr-       , logStringHandle-       , withLogStringFile-+       (          -- * 'ByteString' actions-       , logByteStringStdout+         logByteStringStdout        , logByteStringStderr        , logByteStringHandle        , withLogByteStringFile@@ -18,57 +13,34 @@        , withLogTextFile        ) where -import System.IO (hPutStrLn)+import Control.Monad.IO.Class (MonadIO (..))+import System.IO (Handle, IOMode (AppendMode), stderr, withFile)  import Colog.Core.Action (LogAction (..)) -import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Text as T import qualified Data.Text.IO as TIO  ------------------------------------------------------------------------------- String-------------------------------------------------------------------------------{- | Action that prints 'String' to stdout. -}-logStringStdout :: MonadIO m => LogAction m String-logStringStdout = LogAction putStrLn--{- | Action that prints 'String' to stderr. -}-logStringStderr :: MonadIO m => LogAction m String-logStringStderr = logStringHandle stderr--{- | Action that prints 'String' to 'Handle'. -}-logStringHandle :: MonadIO m => Handle -> LogAction m String-logStringHandle handle = LogAction $ liftIO . hPutStrLn handle--{- | Action that prints 'String' to file. Instead of returning 'LogAction' it's-implemented in continuation-passing style because it's more efficient to open-file only once at the start of the application and write to 'Handle' instead of-opening file each time we need to write to it.--Opens file in 'AppendMode'.--}-withLogStringFile :: MonadIO m => FilePath -> (LogAction m String -> IO r) -> IO r-withLogStringFile path action = withFile path AppendMode $ action . logStringHandle------------------------------------------------------------------------------ -- ByteString ----------------------------------------------------------------------------  {- | Action that prints 'ByteString' to stdout. -}-logByteStringStdout :: MonadIO m => LogAction m ByteString-logByteStringStdout = LogAction putBSLn+logByteStringStdout :: MonadIO m => LogAction m BS.ByteString+logByteStringStdout = LogAction $ liftIO . BS8.putStrLn  {- | Action that prints 'ByteString' to stderr. -}-logByteStringStderr :: MonadIO m => LogAction m ByteString+logByteStringStderr :: MonadIO m => LogAction m BS.ByteString logByteStringStderr = logByteStringHandle stderr  {- | Action that prints 'ByteString' to 'Handle'. -}-logByteStringHandle :: MonadIO m => Handle -> LogAction m ByteString-logByteStringHandle handle = LogAction $ liftIO . BS.hPutStrLn handle+logByteStringHandle :: MonadIO m => Handle -> LogAction m BS.ByteString+logByteStringHandle handle = LogAction $ liftIO . BS8.hPutStrLn handle  {- | Action that prints 'ByteString' to file. See 'withLogStringFile' for details. -}-withLogByteStringFile :: MonadIO m => FilePath -> (LogAction m ByteString -> IO r) -> IO r+withLogByteStringFile :: MonadIO m => FilePath -> (LogAction m BS.ByteString -> IO r) -> IO r withLogByteStringFile path action = withFile path AppendMode $ action . logByteStringHandle  ----------------------------------------------------------------------------@@ -76,58 +48,18 @@ ----------------------------------------------------------------------------  {- | Action that prints 'Text' to stdout. -}-logTextStdout :: MonadIO m => LogAction m Text-logTextStdout = LogAction putTextLn+logTextStdout :: MonadIO m => LogAction m T.Text+logTextStdout = LogAction $ liftIO . TIO.putStrLn  {- | Action that prints 'Text' to stderr. -}-logTextStderr :: MonadIO m => LogAction m Text+logTextStderr :: MonadIO m => LogAction m T.Text logTextStderr = logTextHandle stderr  {- | Action that prints 'Text' to 'Handle'. -}-logTextHandle :: MonadIO m => Handle -> LogAction m Text+logTextHandle :: MonadIO m => Handle -> LogAction m T.Text logTextHandle handle = LogAction $ liftIO . TIO.hPutStrLn handle  {- | Action that prints 'Text' to file. See 'withLogStringFile' for details. -}-withLogTextFile :: MonadIO m => FilePath -> (LogAction m Text -> IO r) -> IO r+withLogTextFile :: MonadIO m => FilePath -> (LogAction m T.Text -> IO r) -> IO r withLogTextFile path action = withFile path AppendMode $ action . logTextHandle -------------------------------------------------------------------------------- Logger rotation-------------------------------------------------------------------------------{--data Limit = LimitTo Natural | Unlimited--{- | Logger rotation action. Takes name of the logging file @file.foo@. Always-writes new logs to file named @file.foo@ (given file name, also called as /hot log/).--* If the size of the file exceeds given limit for file sizes then this action-  renames @file.foo@ to @file.foo.(n + 1)@ (where @n@ is the number of latest-  renamed file).-* If the number of files on the filesystem is bigger than the files number limit-  then the given @FilePath -> IO ()@ action is called on the oldest file. As-  simple solution, you can pass @removeFile@ function to delete old files but-  you can also pass some archiving function if you don't want to loose old logs.--}-withLogRotation-    :: forall msg m .-       MonadIO m-    => Limit  -- TODO: use 'named' library here to distinguish limits?-    -- ^ Max allowed file size in bytes-    -> Limit-    -- ^ Max allowed number of files to have-    -> FilePath-    -- ^ File path to log-    -> (FilePath -> IO ())-    -- ^ What to do with old files; pass @removeFile@ here for deletion-    -> (Handle -> LogAction m msg)-    -- ^ Action that writes to file handle-    -> (LogAction m msg -> IO r)-    -- ^ Continuation action-    -> IO r-withLogRotation sizeLimit filesLimit path cleanup mkAction cont = cont rotationAction-  where-    rotationAction :: LogAction m msg-    rotationAction = LogAction $ \msg -> do-        withFile path AppendMode writeFileLoop--}

@@ -0,0 +1,322 @@+-- |+-- For the speed reasons you may want to dump logs asynchronously.+-- This is especially useful when application threads are CPU+-- bound while logs emitting is I/O bound. This approach+-- allows to mitigate bottlenecks from the I/O.+--+-- When writing an application user should be aware of the tradeoffs+-- that concurrent log system can provide, in this module we explain+-- potential tradeoffs and describe if certain building blocks are+-- affected or not.+--+--   1. Unbounded memory usage - if there is no backpressure mechanism+--   the user threads, they may generate more logs that can be+--   written in the same amount of time. In those cases messages will+--   be accumulated in memory. That will lead to extended GC times and+--   application may be killed by the operating systems mechanisms.+--+--   2. Persistence requirement - sometimes application may want to+--   ensure that logs were written before it can continue. This is not+--   a case with concurrent log systems in general, and some logs may+--   be lost when application exits before dumping all logs.+--+--   3. Non-precise logging - sometimes it may happen that there can be+--   logs reordering (in case if thread was moved to another capability).+--+-- In case if your application is a subject of those problems you may+-- consider not using concurrent logging system in other cases concurrent+-- logger may be a good default for you.+--+module Colog.Concurrent+       ( -- $general+         -- * Simple API.+         -- $simple-api+         withBackgroundLogger+       , defCapacity+         -- * Extended API+         -- $extended-api+         -- ** Background worker+         -- $background-worker+       , BackgroundWorker+       , backgroundWorkerWrite+       , killBackgroundLogger+         -- ** Background logger+       , forkBackgroundLogger+       , convertToLogAction+         -- ** Worker thread+         -- $worker-thread+       , mkBackgroundThread+       , runInBackgroundThread+         -- *** Usage example+         -- $worker-thread-usage+       ) where++import Control.Applicative (many)+import Control.Concurrent (forkFinally, killThread)+import Control.Concurrent.STM (atomically, check, newTVarIO, readTVar, writeTVar)+import Control.Concurrent.STM.TBQueue (newTBQueueIO, readTBQueue, writeTBQueue)+import Control.Exception (bracket, finally)+import Control.Monad (forever, join)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Foldable (for_)++import Colog.Concurrent.Internal (BackgroundWorker (..), Capacity (..))+import Colog.Core.Action (LogAction (..))+++-- $general+--+-- Concurrent logger consists of the basic parts (see schema below).+--+--   1. Logger in application thread. This logger is evaluated in the+--   application thread and has an access to all the context available+--   in that thread and monad, this logger can work in any `m`.+--+--   2. Communication channel with backpressure support. In addition to+--   the channel we have a converter that puts the user message to the+--   communication channel. This converter works in the user thread.+--   Such a logger usually works in `IO` but it's possible to make it+--   work in `STM` as well. At this point library provides only `IO`+--   version, but it can be lifted to any `MonadIO` by the user.+--+--   3. Logger thread. This is the thread that performs actual write to+--   the sinks. Loggers there do not have access to the users thread+--   state, unless that state was passed in the message.+--+--+-- @+--+--  +-------------------------+                  +--------------------------------++--  |                         |                  | Logger        |   Sink-1       |+--  |   Application Thread    |                  | Thread    +--->                |+--  |   -----------------     |  +-----------+   |           |   +----------------++--  |                         |  |           |   +---------+ |   +----------------++--  |           +-------------+  |  channel  |   | Shared  +----->   Sink-2       |+--  |           | application||  |          +----> logger  | |   |                |+--  |           | logger    +----->          |   +---------+ |   +----------------++--  |           +-------------+  |           |   |           |   +----------------++--  |                         |  +-----------+   |           +--->   Sink3        |+--  |                         |                  |               |                |+--  |                         |                  |               +----------------++--  |                         |                  |                                |+--  +-------------------------+                  +--------------------------------++-- @+--+-- So usually user should write the logging system in the way that all 'LogAction'+-- that populate and filter information should live in the application logger.+-- All loggers that do serialization and formatting should live in shared logger.+--+--+-- If more concurrency is needed it's possible to build multilayer systems:+--+--+-- @+--   +-------------+                         +-------++--   | application |---+                 +---| sink-1|+--   +-------------+   |   +---------+   |   +-------++--                     +---| logger  |---++--                         +---------+   |   +-------++--                                       +---| sink-2|+--                                           +-------++-- @+--+-- In this approach application will be concurrently write logs to the logger, then+-- logger will be concurrently writing to all sinks.+++-- $simple-api+--+-- Simple API provides a handy easy to use API that can be used directly+-- in application without dealing with internals. Based on users feedback+-- internal implementation of the simple API may change, especially in early+-- versions of the library. But the guarantee that we give is that no matter+-- what implementation is it will be kept with reasonable defaults and will+-- be applicable to a generic application.+--++-- | An exception safe way to create background logger.  This method will fork+-- a thread that will run 'shared worker', see schema above.+--+-- @Capacity@ - provides a backpressure mechanism and tells how many messages+-- in flight are allowed. In most cases 'defCapacity' will work well.+-- See 'forkBackgroundLogger' for more details.+--+-- @LogAction@ - provides a logger action, this action does not have access to the+-- application state or thread info, so you should only pass methods that serialize+-- and dump data there.+--+-- @+-- import qualified Data.Aeson as Aeson+--+-- main :: IO ()+-- main =+--   'withBackgroundLogger'+--      'defCapacity'+--      (Aeson.encode \``Colog.Core.Action.cmap`\` logger)+--      $ 'Colog.Monad.usingLoggerT' $ __do__+--         'Colog.Monad.logMsg' "Starting application..."+--   where+--     logger = 'Colog.Action.withLogByteStringFile' "\/var\/log\/myapp\/log"+-- @+withBackgroundLogger :: MonadIO m => Capacity -> LogAction IO msg -> (LogAction m msg -> IO a) -> IO a+withBackgroundLogger cap logger action =+   bracket (forkBackgroundLogger cap logger)+           killBackgroundLogger+           (action . convertToLogAction)++-- | Default capacity size, (4096)+defCapacity :: Capacity+defCapacity = Capacity 4096+++-- $extended-api+-- Extended API explains how asynchronous logging is working and provides basic+-- building blocks for writing your own combinators. This is the part of the public+-- API and will not change without prior notice.++-- $background-worker+-- The main abstraction for the concurrent worker is 'BackgroundWorker'. This+-- is a wrapper of the thread, that has communication channel to talk to, and threadId.+--+-- Background worker may provide a backpressure mechanism, but does not provide+-- notification of completeness unless it's included in the message itself.+++-- | Stop background logger thread.+--+-- The thread is blocked until background thread will finish processing+-- all messages that were written in the channel.+killBackgroundLogger :: BackgroundWorker msg -> IO ()+killBackgroundLogger bl = do+  killThread (backgroundWorkerThreadId bl)+  atomically $ readTVar (backgroundWorkerIsAlive bl) >>= check . not++-- $background-logger+--+-- Background logger is specialized version of the 'BackgroundWorker' process.+-- Instead of running any job it will accept @msg@ type+-- instead and process it with a single logger defined at creation time.++-- | Creates background logger with given @Capacity@,+-- takes a 'LogAction' that should describe how to write+-- logs.+--+-- @capacity@ - parameter tells how many in flight messages are allowed,+-- if that value is reached then user's thread that emits logs will be+-- blocked until any message will be written. Usually if value should be+-- chosen reasonably high and if this value is reached it means that+-- the application environment experience severe problems.+--+-- __N.B.__ The 'LogAction' will be run in the background+-- thread so that logger should not add any thread specific+-- context to the message.+--+-- __N.B.__ On exit, even in case of exception thread will dump all values+-- that are in the queue. But it will stop doing that in case if another+-- exception will happen.+forkBackgroundLogger :: Capacity -> LogAction IO msg -> IO (BackgroundWorker msg)+forkBackgroundLogger (Capacity cap) logAction = do+  queue <- newTBQueueIO cap+  isAlive <- newTVarIO True+  tid <- forkFinally+    (forever $ do+      msg <- atomically $ readTBQueue queue+      unLogAction logAction msg)+    (\_ ->+       (do msgs <- atomically $ many $ readTBQueue queue+           for_ msgs $ unLogAction logAction)+         `finally` atomically (writeTVar isAlive False))+  pure $ BackgroundWorker tid (writeTBQueue queue) isAlive+++-- | Convert a given 'BackgroundWorker msg' into a 'LogAction msg'+-- that will send log message to the background thread,+-- without blocking the thread.+--+-- If logger dies for any reason then thread that emits+-- logs will receive 'BlockedIndefinitelyOnSTM' exception.+--+-- You can extend result worker with all functionality available+-- with co-log. This logger will have an access to the thread+-- state.+convertToLogAction :: MonadIO m => BackgroundWorker msg -> LogAction m msg+convertToLogAction logger = LogAction $ \msg ->+  liftIO $ atomically $ backgroundWorkerWrite logger msg++-- $worker-thread+-- While generic background logger is enough for the most+-- of the usecases, sometimes you may want even more.+--+-- There are at least two cases where that may happen:+--+--   1. You need to modify logger, for example different+--   threads wants to write to different sources. Or you+--   want to change lgo mechanism in runtime.+--+--   2. You may want to implement some notification+--   machinery that allows you to guarantee that your+--   logs were written before processing further.+--+-- In order to solve those problems worker thread abstraction+-- was introduced. This is a worker that accepts any action+-- and performs that.++-- | Create a background worker with a given capacity.+-- If capacity is reached, then the thread that tries to+-- write logs will be blocked.+--+-- This method is more generic than 'forkBackgroundLogger' but+-- it's less effective, as you have to pass entire closure to+-- be run and that leads to extra memory usage and indirect calls+-- happening.+--+-- When closed it will dump all pending messages, unless+-- another asynchronous exception will arrive, or synchronous+-- exception will happen during the logging.+mkBackgroundThread :: Capacity -> IO (BackgroundWorker (IO ()))+mkBackgroundThread (Capacity cap) = do+  queue <- newTBQueueIO cap+  isAlive <- newTVarIO True+  tid <- forkFinally+    (forever $ join $ atomically $ readTBQueue queue)+    (\_ ->+       (sequence_ =<< atomically (many $ readTBQueue queue))+       `finally` atomically (writeTVar isAlive False))+  pure $ BackgroundWorker tid (writeTBQueue queue) isAlive++-- | Run logger action asynchronously in the worker thread.+-- Logger is executed in the other thread entirely, so if+-- logger takes any thread related context it will be+-- read from the other thread.+runInBackgroundThread :: BackgroundWorker (IO ()) -> LogAction IO msg -> LogAction IO msg+runInBackgroundThread bt logAction = LogAction $ \msg ->+  atomically $ backgroundWorkerWrite bt $ unLogAction logAction msg++-- $worker-thread-usage+--+-- Consider following example. (Leaving resource control aside).+--+-- @+-- data M msg = M (MVar ()) msg+--+-- notificationLogger :: MonadIO m => LoggerAction m msg -> LoggerAction m (M msg)+-- notificationLogger logger = 'LoggerAction' $ \(M lock msg) ->+--    (unLogger logger msg) `finally` (putMVar lock ())+--+-- example = __do__+--    worker <- 'mkBackgroundWorker' 'defCapacity'+--    lock <- newEmptyMVar+--    -- Log message with default logger.+--    'unLogger'+--       ('runInBackgroundThread' worker+--       (notificationLogger $ 'Colog.Action.withLogByteStringFile' "\/var\/log\/myapp\/log")+--       (M lock "my message")+--    -- Log message with a different logger.+--    'unLogger'+--       ('runInBackgroundThread' worker+--       ('Colog.Action.withLogByteStringFile' "/var/log/myapp/log")+--       ("another message")+--    -- Block until first message is logged.+--    _ <- takeMVar lock+-- @+--

@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}++{- | This is internal module, use it on your own risk. The implementation here+may be changed without a version bump.+-}++module Colog.Concurrent.Internal+       ( BackgroundWorker (..)+       , Capacity (..)+       ) where++import Control.Concurrent (ThreadId)+import Control.Concurrent.STM (STM, TVar)+import Numeric.Natural (Natural)++-- | A wrapper type that carries capacity. The internal+-- type may be differrent for the different GHC versions.+#if MIN_VERSION_stm(2,5,0)+newtype Capacity = Capacity Natural+#else+newtype Capacity = Capacity Int+#endif++-- | Wrapper for the background thread that may+-- receive messages to process.+data BackgroundWorker msg = BackgroundWorker+  { backgroundWorkerThreadId :: !ThreadId+    -- ^ Background 'ThreadId'.+  , backgroundWorkerWrite    :: msg -> STM ()+    -- ^ Method for communication with the thread.+  , backgroundWorkerIsAlive  :: TVar Bool+  }

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  {- | This module contains 'LogAction' instances of @contravariant@ classes.@@ -7,16 +8,19 @@        (        ) where +#if !MIN_VERSION_base(4,12,0) import Data.Functor.Contravariant (Contravariant (..))+#endif import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))  import Colog.Core.Action (LogAction)- import qualified Colog.Core.Action as LA +#if !MIN_VERSION_base(4,12,0) instance Contravariant (LogAction m) where     contramap = LA.cmap     (>$)      = (LA.>$)+#endif  instance (Applicative m) => Divisible (LogAction m) where     divide  = LA.divide

@@ -1,14 +1,12 @@+{-# LANGUAGE CPP                   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels      #-}-{-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ViewPatterns          #-}  {- | 'Message' with 'Severity', and logging functions for them. -}@@ -16,6 +14,7 @@ module Colog.Message        ( -- * Basic message type          Message (..)+       , unMessageField        , log        , logDebug        , logInfo@@ -35,13 +34,20 @@        , upgradeMessageAction        ) where +import Prelude hiding (log)+ import Control.Concurrent (ThreadId, myThreadId)-import Control.Exception (displayException)+import Control.Exception (Exception, displayException)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Kind (Type)+import Data.Semigroup ((<>))+import Data.Text (Text) import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.TypeRepMap (TypeRepMap)+import GHC.Exts (IsList (..)) import GHC.OverloadedLabels (IsLabel (..))-import GHC.Stack (SrcLoc (..))+import GHC.Stack (CallStack, SrcLoc (..), callStack, getCallStack, withFrozenCallStack) import GHC.TypeLits (KnownSymbol, Symbol) import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..),                             setSGRCode)@@ -49,6 +55,7 @@ import Colog.Core (LogAction, Severity (..), cmap) import Colog.Monad (WithLog, logMsg) +import qualified Data.Text as T import qualified Data.TypeRepMap as TM  ----------------------------------------------------------------------------@@ -85,7 +92,7 @@  -- | Logs 'Exception' message. logException :: forall e m env . (WithLog env Message m, Exception e) => e -> m ()-logException = withFrozenCallStack (logError . toText . displayException)+logException = withFrozenCallStack (logError . T.pack . displayException)  -- | Prettifies 'Message' type. fmtMessage :: Message -> Text@@ -103,9 +110,9 @@     Error   -> color Red    "[Error]   "  where     color :: Color -> Text -> Text-    color c txt = toText (setSGRCode [SetColor Foreground Vivid c])+    color c txt = T.pack (setSGRCode [SetColor Foreground Vivid c])         <> txt-        <> toText (setSGRCode [Reset])+        <> T.pack (setSGRCode [Reset])  square :: Text -> Text square t = "[" <> t <> "] "@@ -121,7 +128,7 @@      showLoc :: String -> SrcLoc -> Text     showLoc name SrcLoc{..} =-        toText srcLocModule <> "." <> toText name <> "#" <> show srcLocStartLine+        T.pack srcLocModule <> "." <> T.pack name <> "#" <> T.pack (show srcLocStartLine)  ---------------------------------------------------------------------------- -- Externally extensible message@@ -158,20 +165,25 @@ @ -} newtype MessageField (m :: Type -> Type) (fieldName :: Symbol) where-    MessageField-        :: forall fieldName m .-           { unMesssageField :: m (FieldType fieldName) }-        -> MessageField m fieldName+    MessageField :: forall fieldName m . m (FieldType fieldName) -> MessageField m fieldName +unMessageField :: forall fieldName m . MessageField m fieldName -> m (FieldType fieldName)+unMessageField (MessageField f) = f+ instance (KnownSymbol fieldName, a ~ m (FieldType fieldName))       => IsLabel fieldName (a -> TM.WrapTypeable (MessageField m)) where+#if MIN_VERSION_base(4,11,0)     fromLabel field = TM.WrapTypeable $ MessageField @fieldName field+#else+    fromLabel field = TM.WrapTypeable $ MessageField  @_ @fieldName field+#endif+    {-# INLINE fromLabel #-}  extractField     :: Applicative m     => Maybe (MessageField m fieldName)     -> m (Maybe (FieldType fieldName))-extractField = traverse unMesssageField+extractField = traverse unMessageField  -- same as: -- extractField = \case@@ -224,13 +236,13 @@      <> messageText      showTime :: UTCTime -> Text-    showTime t = square $ toText $+    showTime t = square $ T.pack $           formatTime defaultTimeLocale "%H:%M:%S." t        ++ take 3 (formatTime defaultTimeLocale "%q" t)        ++ formatTime defaultTimeLocale " %e %b %Y %Z" t      showThreadId :: ThreadId -> Text-    showThreadId = square . show+    showThreadId = square . T.pack . show  {- | Allows to extend basic 'Message' type with given dependent map of fields. -}

@@ -1,6 +1,4 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE InstanceSigs        #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs #-}  module Colog.Monad        ( LoggerT (..)@@ -12,8 +10,13 @@        , usingLoggerT        ) where -import Control.Monad.Reader (MonadReader (..), ReaderT)+import Prelude hiding (log)++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) import Control.Monad.Trans.Class (MonadTrans (..))+import Data.Foldable (traverse_)+import GHC.Stack (HasCallStack)  import Colog.Core (HasLog (..), LogAction (..), overLogAction) 

@@ -11,10 +11,16 @@        , logMessagePure        ) where -import Data.Sequence ((|>))+import Control.Monad.State (MonadState, StateT (..), modify')+import Control.Monad.Trans.Class (MonadTrans)+import Data.Bifunctor (second)+import Data.Foldable (toList)+import Data.Functor.Identity (Identity (..))+import Data.Sequence (Seq, (|>))  import Colog.Core.Action (LogAction (..)) + {- | Pure monad transformer for logging. Can log any @msg@ messages. Allows to log messages by storing them in the internal state. -}@@ -24,10 +30,10 @@  -- | Returns result value of 'PureLoggerT' and list of logged messages. runPureLogT :: Functor m => PureLoggerT msg m a -> m (a, [msg])-runPureLogT = fmap (second toList) . usingStateT mempty . runPureLoggerT+runPureLogT = fmap (second toList) . flip runStateT mempty . runPureLoggerT  -- | 'PureLoggerT' specialized to 'Identity'-type PureLogger msg a = PureLoggerT msg Identity a+type PureLogger msg = PureLoggerT msg Identity  -- | Returns result value of 'PureLogger' and list of logged messages. runPureLog :: PureLogger msg a -> (a, [msg])

@@ -0,0 +1,131 @@+-- |+-- This functionality is not to be considered stable+-- or ready for production use. While we enourage you+-- to try it out and report bugs, we cannot assure you+-- that everything will work as advertised :)++module Colog.Rotation+       ( Limit(..)+       , withLogRotation+       ) where++import Control.Monad (when, (>=>))+import Control.Monad.IO.Class (MonadIO (..))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List.NonEmpty (nonEmpty)+import Data.Maybe (fromMaybe, mapMaybe)+import Numeric.Natural (Natural)+import System.FilePath.Posix ((<.>))+import System.IO (Handle, IOMode (AppendMode), hClose, hFileSize, openFile)+import Text.Read (readMaybe)++import Colog.Core.Action (LogAction (..), (<&))++import qualified Data.List.NonEmpty as NE+import qualified System.Directory as D+import qualified System.FilePath.Posix as POS+++data Limit = LimitTo Natural | Unlimited deriving (Eq, Ord)++{- | Logger rotation action. Takes name of the logging file @file.foo@. Always+writes new logs to file named @file.foo@ (given file name, also called as /hot log/).++* If the size of the file exceeds given limit for file sizes then this action+  renames @file.foo@ to @file.foo.(n + 1)@ (where @n@ is the number of latest+  renamed file).+* If the number of files on the filesystem is bigger than the files number limit+  then the given @FilePath -> IO ()@ action is called on the oldest file. As+  simple solution, you can pass @removeFile@ function to delete old files but+  you can also pass some archiving function if you don't want to lose old logs.+-}+withLogRotation+    :: forall r msg m .+       MonadIO m+    => Limit+    -- ^ Max allowed file size in bytes+    -> Limit+    -- ^ Max allowed number of files to have+    -> FilePath+    -- ^ File path to log+    -> (FilePath -> IO ())+    -- ^ What to do with old files; pass @removeFile@ here for deletion+    -> (Handle -> LogAction m msg)+    -- ^ Action that writes to file handle+    -> (LogAction m msg -> IO r)+    -- ^ Continuation action+    -> IO r+withLogRotation sizeLimit filesLimit path cleanup mkAction cont = do+    -- TODO: figure out how to use bracket to safely manage+    -- possible exceptions+    handle <- openFile path AppendMode+    handleRef <- newIORef handle+    cont $ rotationAction handleRef+  where+    rotationAction :: IORef Handle -> LogAction m msg+    rotationAction refHandle = LogAction $ \msg -> do+        handle <- liftIO $ readIORef refHandle+        mkAction handle <& msg++        isLimitReached <- isFileSizeLimitReached sizeLimit handle+        when isLimitReached $ cleanupAndRotate refHandle++    cleanupAndRotate :: IORef Handle -> m ()+    cleanupAndRotate refHandle = liftIO $ do+      readIORef refHandle >>= hClose+      maxN <- maxFileIndex path+      renameFileToNumber (maxN + 1) path+      oldFiles <- getOldFiles filesLimit path+      mapM_ cleanup oldFiles+      newHandle <- openFile path AppendMode+      writeIORef refHandle newHandle++-- Checks whether an input is strictly larger than the limit+isLimitedBy :: Integer -> Limit -> Bool+isLimitedBy _ Unlimited = False+isLimitedBy size (LimitTo limit)+  | size <= 0 = False+  | otherwise = toInteger limit > size++isFileSizeLimitReached :: forall m . MonadIO m => Limit -> Handle -> m Bool+isFileSizeLimitReached limit handle = liftIO $ do+  fileSize <- hFileSize handle+  pure $ isLimitedBy fileSize limit++-- if you have files node.log.0, node.log.1 and node.log.2 then this function+-- will return `2` if you give it `node.log`+maxFileIndex :: FilePath -> IO Natural+maxFileIndex path = do+  files <- D.listDirectory (POS.takeDirectory path)+  let logFiles = filter (== POS.takeBaseName path) files+  let maxFile = maximum <$> nonEmpty (mapMaybe logFileIndex logFiles)+  pure $ fromMaybe 0 maxFile++-- given number 4 and path `node.log` renames file `node.log` to `node.log.4`+renameFileToNumber :: Natural -> FilePath -> IO ()+renameFileToNumber n path = D.renameFile path (path <.> show n)++-- if you give it name like `node.log.4` then it returns `Just 4`+logFileIndex :: FilePath -> Maybe Natural+logFileIndex path =+    nonEmpty (POS.takeExtension path) >>= readMaybe . NE.tail++-- creates list of files with indices who are older on given Limit than the latest one+getOldFiles :: Limit -> FilePath -> IO [FilePath]+getOldFiles limit path = do+    currentMaxN <- maxFileIndex path+    files <- D.listDirectory (POS.takeDirectory path)+    pure $ mapMaybe (takeFileIndex >=> guardFileIndex currentMaxN) files+  where+    takeFileIndex  :: FilePath -> Maybe (FilePath, Natural)+    takeFileIndex p = (p,) <$> logFileIndex path++    guardFileIndex :: Natural -> (FilePath, Natural) -> Maybe FilePath+    guardFileIndex maxN (p, n)+      | isOldFile maxN n = Nothing+      | otherwise       = Just p++    isOldFile :: Natural -> Natural -> Bool+    isOldFile maxN n = case limit of+                         Unlimited -> False+                         LimitTo l -> n < maxN - l

@@ -1,5 +0,0 @@-module Prelude-       ( module Relude-       ) where--import Relude