diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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 diff --git a/co-log.cabal b/co-log.cabal --- a/co-log.cabal +++ b/co-log.cabal @@ -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 diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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 diff --git a/src/Colog.hs b/src/Colog.hs --- a/src/Colog.hs +++ b/src/Colog.hs @@ -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 diff --git a/src/Colog/Actions.hs b/src/Colog/Actions.hs --- a/src/Colog/Actions.hs +++ b/src/Colog/Actions.hs @@ -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 --} diff --git a/src/Colog/Concurrent.hs b/src/Colog/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Concurrent.hs @@ -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 +-- @ +-- diff --git a/src/Colog/Concurrent/Internal.hs b/src/Colog/Concurrent/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Concurrent/Internal.hs @@ -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 + } diff --git a/src/Colog/Contra.hs b/src/Colog/Contra.hs --- a/src/Colog/Contra.hs +++ b/src/Colog/Contra.hs @@ -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 diff --git a/src/Colog/Message.hs b/src/Colog/Message.hs --- a/src/Colog/Message.hs +++ b/src/Colog/Message.hs @@ -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. -} diff --git a/src/Colog/Monad.hs b/src/Colog/Monad.hs --- a/src/Colog/Monad.hs +++ b/src/Colog/Monad.hs @@ -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) diff --git a/src/Colog/Pure.hs b/src/Colog/Pure.hs --- a/src/Colog/Pure.hs +++ b/src/Colog/Pure.hs @@ -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]) diff --git a/src/Colog/Rotation.hs b/src/Colog/Rotation.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Rotation.hs @@ -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 diff --git a/src/Prelude.hs b/src/Prelude.hs deleted file mode 100644 --- a/src/Prelude.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Prelude - ( module Relude - ) where - -import Relude