diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +Change log +========== + +co-log uses [PVP Versioning][1]. +The change log is available [on GitHub][2]. + +0.0.0 +===== +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/kowainik/co-log/releases + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,101 @@ +# co-log + +[![Hackage](https://img.shields.io/hackage/v/co-log.svg)](https://hackage.haskell.org/package/co-log) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/co-log/blob/master/LICENSE) +[![Build status](https://secure.travis-ci.org/kowainik/co-log.svg)](https://travis-ci.org/kowainik/co-log) + + +Logging library based on [`co-log-core`](../co-log-core) package. Provides +ready-to-go implementation of logging. This README contains _How to_ tutorial on +using this library. This tutorial explains step by step how to integrate +`co-log` into small basic project, specifically how to replace `putStrLn` used +for logging with library provided logging. + +All code below can be compiled and run with the following commands: + +```shell +$ cabal new-build co-log +$ cabal new-exec readme +``` + +## Preamble: imports and language extensions + +Since this is a literate haskell file, we need to specify all our language +extensions and imports up front. + +```haskell +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +import Colog (Message, WithLog, cmap, fmtMessage, logDebug, logInfo, logTextStdout, logWarning, + usingLoggerT) +import Control.Monad.IO.Class (MonadIO, liftIO) + +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +``` + +## Simple IO function example + +Consider the following function that reads lines from `stdin` and outputs +different feedback depending on the line size. + +```haskell +processLinesBasic :: IO () +processLinesBasic = do + line <- TextIO.getLine + case Text.length line of + 0 -> do + -- here goes logging + TextIO.putStrLn ">>>> Empty input" + processLinesBasic + n -> do + TextIO.putStrLn ">>>> Correct input" + TextIO.putStrLn $ "Line length: " <> Text.pack (show n) +``` + +This code mixes application logic with logging of the steps. It's convenient to +have logging to observe behavior of the application. But `putStrLn` is very +simple and primitive way to log things. + +## Using `co-log` library + +In order to use `co-log` library, we need to refactor `processLinesBasic` +function in the following way: + +```haskell +processLinesLog :: (WithLog env Message m, MonadIO m) => m () +processLinesLog = do + line <- liftIO TextIO.getLine + case Text.length line of + 0 -> do + -- here goes logging + logWarning "Empty input" + processLinesLog + n -> do + logDebug "Correct line" + logInfo $ "Line length: " <> Text.pack (show n) +``` + +Let's summarize required changes: + +1. Make type more polymorphic: `(WithLog env Message m, MonadIO m) => m ()` +2. Add `liftIO` to all `IO` functions. +3. Replace `putStrLn` with proper `log*` function. + +## Running actions + +Let's run both functions: + +```haskell +main :: IO () +main = do + processLinesBasic + + let action = cmap fmtMessage logTextStdout + usingLoggerT action processLinesLog +``` + +And here is how output looks like: + +![screenshot from 2018-09-17 20-52-01](https://user-images.githubusercontent.com/4276606/45623973-8bafb900-babb-11e8-9e20-4369a5a8e5ff.png) diff --git a/co-log.cabal b/co-log.cabal new file mode 100644 --- /dev/null +++ b/co-log.cabal @@ -0,0 +1,93 @@ +cabal-version: 2.0 +name: co-log +version: 0.0.0 +description: Logging library +synopsis: Logging library +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 +maintainer: xrom.xkov@gmail.com +copyright: 2018 Kowainik +category: Logging +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC == 8.4.3 + +source-repository head + type: git + location: https://github.com/kowainik/co-log.git + +library + hs-source-dirs: src + exposed-modules: Colog + Colog.Actions + Colog.Contra + Colog.Message + Colog.Monad + Colog.Pure + Prelude + + build-depends: base-noprelude >= 4.11 && < 5 + , ansi-terminal ^>= 0.8 + , bytestring + , co-log-core + , containers >= 0.5.7 && < 0.7 + , contravariant ^>= 1.5 + , mtl + , relude ^>= 0.3.0 + , text + , time + , transformers >= 0.5 + , typerep-map ^>= 0.3.0 + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -freverse-errors + + default-language: Haskell2010 + default-extensions: DeriveGeneric + GeneralizedNewtypeDeriving + InstanceSigs + OverloadedStrings + RecordWildCards + TypeApplications + +executable play-colog + hs-source-dirs: example + main-is: Main.hs + + build-depends: base-noprelude + , co-log + , relude + , typerep-map + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -freverse-errors + -threaded + -rtsopts + -with-rtsopts=-N + + default-language: Haskell2010 + +executable readme + main-is: README.lhs + build-depends: base-noprelude + , co-log + , text + + build-tool-depends: markdown-unlit:markdown-unlit + ghc-options: -Wall -pgmL markdown-unlit + default-language: Haskell2010 diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.Concurrent (threadDelay) + +import Colog (pattern D, LogAction, Message (..), PureLogger, WithLog, cbind, cmap, defaultFieldMap, + fmtMessage, fmtRichMessageDefault, log, logException, logInfo, logMessagePure, logMsg, + logMsgs, logStringStdout, logTextStderr, logTextStdout, logWarning, runPureLog, + upgradeMessageAction, usingLoggerT, withLog, withLogTextFile, (*<), (>$), (>$<), (>*), + (>*<), (>|<)) + +import qualified Data.TypeRepMap as TM + +example :: WithLog env Message m => m () +example = do + log D "First message..." + logInfo "Second message..." + +app :: (WithLog env Message m, MonadIO m) => m () +app = do + logWarning "Starting application..." + liftIO $ threadDelay $ 10^(6 :: Int) + withLog (cmap addApp) $ do + example + exceptionL + logInfo "Application finished..." + where + addApp :: Message -> Message + addApp msg = msg { messageText = "app: " <> messageText msg } + + +foo :: (WithLog env String m, WithLog env Int m) => m () +foo = do + logMsg ("String message..." :: String) + logMsg @Int 42 + +data ExampleException = ExampleException + deriving (Show, Exception) + +exceptionL :: (WithLog env Message m) => m () +exceptionL = logException ExampleException + +---------------------------------------------------------------------------- +-- Section with contravariant combinators example +---------------------------------------------------------------------------- + +data Engine = Pistons Int | Rocket + +engineToEither :: Engine -> Either Int () +engineToEither e = case e of + Pistons i -> Left i + Rocket -> Right () + +data Car = Car + { carMake :: String + , carModel :: String + , carEngine :: Engine + } + +carToTuple :: Car -> (String, (String, Engine)) +carToTuple (Car make model engine) = (make, (model, engine)) + +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 + +-- log actions that logs single car module +carL :: LogAction IO Car +carL = carToTuple + >$< (constL "Logging make..." *< stringL >* constL "Finished logging make...") + >*< (constL "Logging model.." *< stringL >* constL "Finished logging model...") + >*< ( engineToEither + >$< constL "Logging pistons..." *< intL + >|< constL "Logging rocket..." + ) + +---------------------------------------------------------------------------- +-- main runner +---------------------------------------------------------------------------- + +main :: IO () +main = withLogTextFile "co-log/example/example.log" $ \logTextFile -> do + let runApp :: LogAction IO Message -> IO () + runApp action = usingLoggerT action app + + let textAction = logTextStdout <> logTextStderr <> logTextFile + + let simpleMessageAction = cmap fmtMessage textAction + let richMessageAction = cbind fmtRichMessageDefault textAction + + let fullMessageAction = upgradeMessageAction defaultFieldMap richMessageAction + let semiMessageAction = upgradeMessageAction + (TM.delete @"threadId" defaultFieldMap) + richMessageAction + + runApp simpleMessageAction + runApp fullMessageAction + runApp semiMessageAction + + usingLoggerT carL $ logMsg $ Car "Toyota" "Corolla" (Pistons 4) + + let pureAction :: PureLogger Message () + pureAction = usingLoggerT logMessagePure example + let ((), msgs) = runPureLog pureAction + usingLoggerT simpleMessageAction $ logMsgs msgs diff --git a/src/Colog.hs b/src/Colog.hs new file mode 100644 --- /dev/null +++ b/src/Colog.hs @@ -0,0 +1,14 @@ +module Colog + ( module Colog.Actions + , module Colog.Core + , module Colog.Message + , module Colog.Monad + , module Colog.Pure + ) where + +import Colog.Actions +import Colog.Contra () +import Colog.Core +import Colog.Message +import Colog.Monad +import Colog.Pure diff --git a/src/Colog/Actions.hs b/src/Colog/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Actions.hs @@ -0,0 +1,133 @@ +module Colog.Actions + ( -- * 'String' actions + logStringStdout + , logStringStderr + , logStringHandle + , withLogStringFile + + -- * 'ByteString' actions + , logByteStringStdout + , logByteStringStderr + , logByteStringHandle + , withLogByteStringFile + + -- * 'Text' actions + , logTextStdout + , logTextStderr + , logTextHandle + , withLogTextFile + ) where + +import System.IO (hPutStrLn) + +import Colog.Core.Action (LogAction (..)) + +import qualified Data.ByteString.Char8 as BS +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 + +{- | Action that prints 'ByteString' to stderr. -} +logByteStringStderr :: MonadIO m => LogAction m ByteString +logByteStringStderr = logByteStringHandle stderr + +{- | Action that prints 'ByteString' to 'Handle'. -} +logByteStringHandle :: MonadIO m => Handle -> LogAction m ByteString +logByteStringHandle handle = LogAction $ liftIO . BS.hPutStrLn handle + +{- | Action that prints 'ByteString' to file. See 'withLogStringFile' for details. -} +withLogByteStringFile :: MonadIO m => FilePath -> (LogAction m ByteString -> IO r) -> IO r +withLogByteStringFile path action = withFile path AppendMode $ action . logByteStringHandle + +---------------------------------------------------------------------------- +-- Text +---------------------------------------------------------------------------- + +{- | Action that prints 'Text' to stdout. -} +logTextStdout :: MonadIO m => LogAction m Text +logTextStdout = LogAction putTextLn + +{- | Action that prints 'Text' to stderr. -} +logTextStderr :: MonadIO m => LogAction m Text +logTextStderr = logTextHandle stderr + +{- | Action that prints 'Text' to 'Handle'. -} +logTextHandle :: MonadIO m => Handle -> LogAction m 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 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/Contra.hs b/src/Colog/Contra.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Contra.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- | This module contains 'LogAction' instances of @contravariant@ classes. +-} + +module Colog.Contra + ( + ) where + +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..)) + +import Colog.Core.Action (LogAction) + +import qualified Colog.Core.Action as LA + +instance Contravariant (LogAction m) where + contramap = LA.cmap + (>$) = (LA.>$) + +instance (Applicative m) => Divisible (LogAction m) where + divide = LA.divide + conquer = LA.conquer + +instance (Applicative m) => Decidable (LogAction m) where + lose = LA.lose + choose = LA.choose diff --git a/src/Colog/Message.hs b/src/Colog/Message.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Message.hs @@ -0,0 +1,245 @@ +{-# 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. +-} + +module Colog.Message + ( -- * Basic message type + Message (..) + , log + , logDebug + , logInfo + , logWarning + , logError + , logException + , fmtMessage + + -- * Externally extensible message type + , FieldType + , MessageField (..) + , FieldMap + , defaultFieldMap + + , RichMessage + , fmtRichMessageDefault + , upgradeMessageAction + ) where + +import Control.Concurrent (ThreadId, myThreadId) +import Control.Exception (displayException) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.TypeRepMap (TypeRepMap) +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.Stack (SrcLoc (..)) +import GHC.TypeLits (KnownSymbol, Symbol) +import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..), + setSGRCode) + +import Colog.Core (LogAction, Severity (..), cmap) +import Colog.Monad (WithLog, logMsg) + +import qualified Data.TypeRepMap as TM + +---------------------------------------------------------------------------- +-- Plain message +---------------------------------------------------------------------------- + +-- | Consist of the message 'Severity' level and the message itself. +data Message = Message + { messageSeverity :: !Severity + , messageStack :: !CallStack + , messageText :: !Text + } + +-- | Logs the message with given 'Severity'. +log :: WithLog env Message m => Severity -> Text -> m () +log messageSeverity messageText = + withFrozenCallStack (logMsg Message{ messageStack = callStack, .. }) + +-- | Logs the message with 'Debug' severity. +logDebug :: WithLog env Message m => Text -> m () +logDebug = withFrozenCallStack (log Debug) + +-- | Logs the message with 'Info' severity. +logInfo :: WithLog env Message m => Text -> m () +logInfo = withFrozenCallStack (log Info) + +-- | Logs the message with 'Warning' severity. +logWarning :: WithLog env Message m => Text -> m () +logWarning = withFrozenCallStack (log Warning) + +-- | Logs the message with 'Error' severity. +logError :: WithLog env Message m => Text -> m () +logError = withFrozenCallStack (log Error) + +-- | Logs 'Exception' message. +logException :: forall e m env . (WithLog env Message m, Exception e) => e -> m () +logException = withFrozenCallStack (logError . toText . displayException) + +-- | Prettifies 'Message' type. +fmtMessage :: Message -> Text +fmtMessage Message{..} = + showSeverity messageSeverity + <> showSourceLoc messageStack + <> messageText + +-- | Prints severity in different colours +showSeverity :: Severity -> Text +showSeverity = \case + Debug -> color Green "[Debug] " + Info -> color Blue "[Info] " + Warning -> color Yellow "[Warning] " + Error -> color Red "[Error] " + where + color :: Color -> Text -> Text + color c txt = toText (setSGRCode [SetColor Foreground Vivid c]) + <> txt + <> toText (setSGRCode [Reset]) + +square :: Text -> Text +square t = "[" <> t <> "] " + +showSourceLoc :: CallStack -> Text +showSourceLoc cs = square showCallStack + where + showCallStack :: Text + showCallStack = case getCallStack cs of + [] -> "" + [(name, loc)] -> showLoc name loc + (_, loc) : (callerName, _) : _ -> showLoc callerName loc + + showLoc :: String -> SrcLoc -> Text + showLoc name SrcLoc{..} = + toText srcLocModule <> "." <> toText name <> "#" <> show srcLocStartLine + +---------------------------------------------------------------------------- +-- Externally extensible message +---------------------------------------------------------------------------- + +{- | Open type family that maps some user defined tags (type names) to actual +types. The type family is open so you can add new instances. +-} +type family FieldType (fieldName :: Symbol) :: Type +type instance FieldType "threadId" = ThreadId +type instance FieldType "utcTime" = UTCTime + +{- | @newtype@ wrapper. Stores monadic ability to extract value of 'FieldType'. + +__Implementation detail:__ this exotic writing of 'MessageField' is required in +order to use it nicer with type applications. So users can write + +@ +MessageField @"threadId" myThreadId +@ + +instead of + +@ +MessageField @_ @"threadId" myThreadId +@ + +Simpler version of this @newtype@: + +@ +newtype MessageField m fieldName = MessageField + { unMesssageField :: m (FieldType fieldName) + } +@ +-} +newtype MessageField (m :: Type -> Type) (fieldName :: Symbol) where + MessageField + :: forall fieldName m . + { unMesssageField :: m (FieldType fieldName) } + -> MessageField m fieldName + +instance (KnownSymbol fieldName, a ~ m (FieldType fieldName)) + => IsLabel fieldName (a -> TM.WrapTypeable (MessageField m)) where + fromLabel field = TM.WrapTypeable $ MessageField @fieldName field + +extractField + :: Applicative m + => Maybe (MessageField m fieldName) + -> m (Maybe (FieldType fieldName)) +extractField = traverse unMesssageField + +-- same as: +-- extractField = \case +-- Nothing -> pure Nothing +-- Just (MessageField field) -> Just <$> field + +{- | Depedent map from type level strings to the corresponding types. See +'FieldType' for mapping between names and types. +-} +type FieldMap (m :: Type -> Type) = TypeRepMap (MessageField m) + +{- | Default message map that contains actions to extract 'ThreadId' and +'UTCTime'. Basically, the following mapping: + +@ +"threadId" -> myThreadId +"utcTime" -> getCurrentTime +@ +-} +defaultFieldMap :: MonadIO m => FieldMap m +defaultFieldMap = fromList + [ #threadId (liftIO myThreadId) + , #utcTime (liftIO getCurrentTime) + ] + +-- | Contains additional data to 'Message' to display more verbose information. +data RichMessage (m :: Type -> Type) = RichMessage + { richMessageMsg :: {-# UNPACK #-} !Message + , richMessageMap :: {-# UNPACK #-} !(FieldMap m) + } + +{- | Formats 'RichMessage' in the following way: + +@ +[Severity] [Time] [SourceLocation] [ThreadId] +@ +-} +fmtRichMessageDefault :: MonadIO m => RichMessage m -> m Text +fmtRichMessageDefault RichMessage{..} = do + maybeThreadId <- extractField $ TM.lookup @"threadId" richMessageMap + maybeUtcTime <- extractField $ TM.lookup @"utcTime" richMessageMap + pure $ formatRichMessage maybeThreadId maybeUtcTime richMessageMsg + where + formatRichMessage :: Maybe ThreadId -> Maybe UTCTime -> Message -> Text + formatRichMessage (maybe "" showThreadId -> thread) (maybe "" showTime -> time) Message{..} = + showSeverity messageSeverity + <> time + <> showSourceLoc messageStack + <> thread + <> messageText + + showTime :: UTCTime -> Text + showTime t = square $ toText $ + 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 + +{- | Allows to extend basic 'Message' type with given dependent map of fields. +-} +upgradeMessageAction + :: forall m . + FieldMap m + -> LogAction m (RichMessage m) + -> LogAction m Message +upgradeMessageAction fieldMap = cmap addMap + where + addMap :: Message -> RichMessage m + addMap msg = RichMessage msg fieldMap diff --git a/src/Colog/Monad.hs b/src/Colog/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Monad.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Colog.Monad + ( LoggerT (..) + , WithLog + , logMsg + , logMsgs + , withLog + , liftLogAction + , usingLoggerT + ) where + +import Control.Monad.Reader (MonadReader (..), ReaderT) +import Control.Monad.Trans.Class (MonadTrans (..)) + +import Colog.Core (HasLog (..), LogAction (..), overLogAction) + +{- | @newtype@ wrapper 'ReaderT' that keeps 'LogAction' in its context. +-} +newtype LoggerT msg m a = LoggerT + { runLoggerT :: ReaderT (LogAction (LoggerT msg m) msg) m a + } deriving (Functor, Applicative, Monad, MonadIO, MonadReader (LogAction (LoggerT msg m) msg)) + +instance MonadTrans (LoggerT msg) where + lift :: Monad m => m a -> LoggerT msg m a + lift = LoggerT . lift + +type WithLog env msg m = (MonadReader env m, HasLog env msg m, HasCallStack) + +{- | Perform logging action with given message @msg@. This function works for +monads that have access to 'LogAction'. + +You can use this function like this: + +@ +example :: 'WithLog' env 'String' m => m () +example = __do__ + 'logMsg' "First message..." + 'logMsg' "Second message..." +@ +-} +logMsg :: forall msg env m . WithLog env msg m => msg -> m () +logMsg msg = do + LogAction log <- asks getLogAction + log msg + +-- | Logs multiple messages. +logMsgs :: forall msg env f m . (Foldable f, WithLog env msg m) => f msg -> m () +logMsgs = traverse_ logMsg + +{- | Performs given monadic logging action by applying function to every logging record. + +@ +app :: 'WithLog' env 'String' m => m () +app = 'withLog' ('cmap' ("app:" ++)) $ __do__ + 'logMsg' "First message..." + 'logMsg' "Second message..." +@ +-} +withLog :: WithLog env msg m => (LogAction m msg -> LogAction m msg) -> m a -> m a +withLog = local . overLogAction + +liftLogAction :: (Monad m, MonadTrans t) => LogAction m msg -> LogAction (t m) msg +liftLogAction (LogAction action) = LogAction (lift . action) + +{- | Runner for 'LoggerT' monad. Let's consider one simple example of monadic +action you have: + +@ +app :: 'WithLog' env 'String' m => m () +app = __do__ + 'logMsg' "Starting application..." + 'withLog' ('cmap' ("app:" ++)) $ __do__ + 'logMsg' "Application started." + 'logMsg' "Application finished." +@ + +You can use the following way of running such example: + +@ +'usingLoggerT' ('LogAction' 'putStrLn') app +@ + +And you will see this output: + +@ +Starting application... +app:Application started. +app:Application finished. +@ +-} +usingLoggerT :: Monad m => LogAction m msg -> LoggerT msg m a -> m a +usingLoggerT action = flip runReaderT (liftLogAction action) . runLoggerT diff --git a/src/Colog/Pure.hs b/src/Colog/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Colog/Pure.hs @@ -0,0 +1,38 @@ +{- | Pure implementation of logging action. +-} + +module Colog.Pure + ( PureLoggerT (..) + , runPureLogT + + , PureLogger + , runPureLog + + , logMessagePure + ) where + +import Data.Sequence ((|>)) + +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. +-} +newtype PureLoggerT msg m a = PureLoggerT + { runPureLoggerT :: StateT (Seq msg) m a + } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (Seq msg)) + +-- | 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 + +-- | 'PureLoggerT' specialized to 'Identity' +type PureLogger msg a = PureLoggerT msg Identity a + +-- | Returns result value of 'PureLogger' and list of logged messages. +runPureLog :: PureLogger msg a -> (a, [msg]) +runPureLog = runIdentity . runPureLogT + +-- | 'LogAction' that prints @msg@ by appending it to the end of the sequence. +logMessagePure :: Monad m => LogAction (PureLoggerT msg m) msg +logMessagePure = LogAction $ \msg -> modify' (|> msg) diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,5 @@ +module Prelude + ( module Relude + ) where + +import Relude