simple-logging 0.2.0.1 → 0.2.0.2
raw patch · 5 files changed
+190/−90 lines, 5 filesdep +directorydep +filepathdep +hscolourdep ~aesondep ~basedep ~bytestring
Dependencies added: directory, filepath, hscolour, uuid
Dependency ranges changed: aeson, base, bytestring, exceptions, iso8601-time, lens, mtl, simple-effects, simple-logging, string-conv, text, time, vector
Files
- simple-logging.cabal +67/−54
- src/Control/Effects/Logging.hs +105/−18
- src/Interlude.hs +1/−0
- test/Module1.hs +0/−16
- test/Spec.hs +17/−2
simple-logging.cabal view
@@ -1,58 +1,71 @@-name: simple-logging-version: 0.2.0.1-cabal-version: >=1.10-build-type: Simple-license: MIT-license-file: LICENSE-copyright: 2017 Luka Horvat-maintainer: luka.horvat9@gmail.com-homepage: https://gitlab.com/haskell-hr/logging-synopsis: Logging effect to plug into the simple-effects framework-category: Logging-author: Luka Horvat-extra-source-files:- CHANGELOG.md--source-repository head- type: git- location: https://gitlab.com/haskell-hr/logging.git+name: simple-logging+version: 0.2.0.2+synopsis: Logging effect to plug into the simple-effects framework+homepage: https://gitlab.com/haskell-hr/logging+license: MIT+license-file: LICENSE+author: Luka Horvat+maintainer: luka.horvat9@gmail.com+copyright: 2017 Luka Horvat+category: Logging+build-type: Simple+extra-source-files: CHANGELOG.md+cabal-version: >=1.10 library- exposed-modules:- Control.Effects.Logging- build-depends:- base >=4.7 && <5,- aeson >=1.0.2.1,- vector >=0.11.0.0,- time >=1.6.0.1,- bytestring >=0.10.8.1,- iso8601-time >=0.1.4,- text >=1.2.2.1,- simple-effects >=0.9.0.0,- exceptions >=0.8.3,- mtl >=2.2.1,- string-conv >=0.1.2,- lens >=4.15.1- default-language: Haskell2010- default-extensions: NoImplicitPrelude OverloadedStrings- TypeFamilies- hs-source-dirs: src- other-modules:- Interlude- ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Control.Effects.Logging+ other-modules: Interlude+ build-depends: base >= 4.7 && < 5+ , aeson+ , vector+ , time+ , bytestring+ , iso8601-time+ , text+ , simple-effects+ , exceptions+ , mtl+ , string-conv+ , lens+ , hscolour+ , directory+ , filepath+ , uuid+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: NoImplicitPrelude+ OverloadedStrings+ TypeFamilies test-suite logging-test- type: exitcode-stdio-1.0- main-is: Spec.hs- build-depends:- base >=4.9.1.0,- simple-logging >=0.2.0.1,- simple-effects >=0.9.0.0- default-language: Haskell2010- default-extensions: MultiParamTypeClasses OverloadedStrings- TypeFamilies NoMonomorphismRestriction FlexibleContexts- NoImplicitPrelude- hs-source-dirs: test- other-modules:- Module1- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ other-modules: Interlude+ type: exitcode-stdio-1.0+ hs-source-dirs: test, src+ main-is: Spec.hs+ build-depends: base+ , simple-logging+ , aeson+ , vector+ , time+ , bytestring+ , iso8601-time+ , text+ , simple-effects+ , exceptions+ , mtl+ , string-conv+ , lens+ , hscolour+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ default-extensions: MultiParamTypeClasses+ OverloadedStrings+ TypeFamilies+ NoMonomorphismRestriction+ FlexibleContexts+ NoImplicitPrelude++source-repository head+ type: git+ location: https://gitlab.com/haskell-hr/logging.git
src/Control/Effects/Logging.hs view
@@ -13,17 +13,26 @@ -- Read the documentation of individual functions to get a feel for what you can do. module Control.Effects.Logging (module Control.Effects.Logging) where -import Interlude +import Interlude hiding (truncate) import Control.Effects as Control.Effects.Logging import Control.Effects.Signal -import Data.Text hiding (length) +import qualified Data.Text as Text import Data.Time.ISO8601 -import qualified Data.ByteString as BS import GHC.Stack import Data.Time (UTCTime, getCurrentTime) +import Language.Haskell.HsColour.ANSI +import System.Directory +import System.FilePath +import Data.UUID.V4 + +import Data.String + +import Control.Effects.Early +import Data.UUID + -- | The logging effect. data Logging = Logging data instance Effect Logging method mr where @@ -38,7 +47,7 @@ newtype Context = Context { getContext :: Text } deriving (Eq, Ord, Read, Show) -- | The severity of the log. -data Level = Fatal | Error | Warning | Info | Debug deriving (Eq, Ord, Read, Show) +data Level = Debug | Info | Warning | Error | Fatal deriving (Eq, Ord, Read, Show) -- | If a notion of a user exists for your application, you can add this information to your logs. data LogUser = LogUser { logUserId :: Text @@ -91,13 +100,21 @@ , "data" .= crumbData ] & addIfExists "message" (String <$> crumbMessage) +-- | Logs can hold arbitrary data serialized as a 'ByteString'. Additionally, a summary can be +-- provided which is intended to be displayed fully in log summaries. +data LogData = LogData { dataPayload :: ByteString + , dataSummary :: Text } + deriving (Eq, Ord, Read, Show) +instance IsString LogData where + fromString s = LogData (toS s) "" + data Log = Log { logMessage :: Text , logLevel :: Level , logTags :: [Tag] , logContext :: [Context] , logUser :: Maybe LogUser , logCrumbs :: [Crumb] - , logData :: ByteString + , logData :: LogData , logTimestamp :: Maybe UTCTime , logCallStack :: CallStack } deriving (Show) @@ -116,18 +133,24 @@ handleLogging f = handleEffect (\(LoggingMsg l) -> LoggingRes <$ f l) -- | Add a new context on top of every log that comes from the given computation. -layerLogs :: MonadEffect Logging m => Context -> EffectHandler Logging m a -> m a +layerLogs :: (HasCallStack, MonadEffect Logging m) => Context -> EffectHandler Logging m a -> m a layerLogs ctx = handleLogging (\log' -> logEffect (log' { logContext = ctx : logContext log' })) -- | Get the bottom-most context if it exists. originContext :: Log -> Maybe Context originContext Log{..} = listToMaybe (Interlude.reverse logContext) -logInfo, logWarning, logError :: (HasCallStack, MonadEffect Logging m) => Text -> m () -logInfo msg = logEffect $ Log msg Info [] [] Nothing [] "" Nothing callStack -logWarning msg = logEffect $ Log msg Warning [] [] Nothing [] "" Nothing callStack -logError msg = logEffect $ Log msg Error [] [] Nothing [] "" Nothing callStack +logWithLevel :: (HasCallStack, MonadEffect Logging m) => Level -> Text -> m () +logWithLevel lvl msg = logEffect $ Log msg lvl [] [] Nothing [] "" Nothing callStack +logInfo, logWarning, logError, logDebug, logFatal + :: (HasCallStack, MonadEffect Logging m) => Text -> m () +logInfo = logWithLevel Info +logWarning = logWithLevel Warning +logError = logWithLevel Error +logDebug = logWithLevel Debug +logFatal = logWithLevel Fatal + -- | Log an error and then throw the given exception. logAndError :: (Exception e, MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> e -> m a logAndError msg err = logError msg >> throwM err @@ -179,7 +202,7 @@ messagesToCrumbs :: (MonadIO m, MonadEffect Logging m) => EffectHandler Logging m a -> m a messagesToCrumbs = mapLogs $ \l@Log{..} -> do time <- liftIO getCurrentTime - let cat = Data.Text.intercalate "." (fmap getContext logContext) + let cat = Text.intercalate "." (fmap getContext logContext) return (l { logCrumbs = logCrumbs ++ [Crumb time (Just logMessage) cat (DefaultCrumb [])] }) -- | Each log that passes through will get all of the crumbs of the previous logs added. @@ -201,10 +224,15 @@ addCrumbToLogs :: MonadEffect Logging m => Crumb -> EffectHandler Logging m a -> m a addCrumbToLogs crumb = mapLogs (\l -> return (l { logCrumbs = logCrumbs l ++ [crumb] })) +-- | Attach arbitrary data to every log. Typically you want to use this handler on +-- 'logX' functions directly like @setDataWithSummary "some data" (logInfo "some info")@ +setDataWithSummary :: MonadEffect Logging m => LogData -> EffectHandler Logging m a -> m a +setDataWithSummary dat = mapLogs (\l -> return (l { logData = dat })) + -- | Attach an arbitrary 'ByteString' to every log. Typically you want to use this handler on -- 'logX' functions directly like @setDataTo "some data" (logInfo "some info")@ setDataTo :: MonadEffect Logging m => ByteString -> EffectHandler Logging m a -> m a -setDataTo bs = mapLogs (\l -> return (l { logData = bs })) +setDataTo bs = setDataWithSummary (LogData bs "") -- | Attach an arbitrary value to every log using it's 'ToJSON' instance. -- Typically you want to use this handler on 'logX' functions directly like @@ -224,21 +252,80 @@ time <- liftIO getCurrentTime return (l { logTimestamp = Just time }) +highlightT :: [Highlight] -> Text -> Text +highlightT hs = toS . highlight hs . toS + +yellow :: Text -> Text +yellow = highlightT [Foreground Yellow] + +colorFromLevel :: Level -> [Highlight] +colorFromLevel Debug = [Foreground Cyan] +colorFromLevel Info = [Foreground White] +colorFromLevel Warning = [Foreground Yellow] +colorFromLevel Error = [Foreground Red] +colorFromLevel Fatal = [Foreground Black, Background Red] + +-- | Puts data of each log into a separate file inside of a given directory. Replaces the data of +-- the logs with the path to the files. +writeDataToFiles :: + ( MonadEffect Logging m, MonadIO m ) + => FilePath -> EffectHandler Logging m a -> m a +writeDataToFiles path m = do + liftIO (createDirectoryIfMissing True path) + m & mapLogs ( \l@Log{..} -> do + uuid <- liftIO nextRandom + let fp = path </> toString uuid <.> "txt" + let LogData{..} = logData + liftIO $ + writeFile fp + (toS dataSummary <> "\n" + <> toSL dataPayload <> "\n" + <> pshow logCrumbs <> "\n" + <> prettyCallStack logCallStack) + return (l { logData = LogData "" (toS fp) }) ) + +truncate :: Int -> Text -> Text +truncate at txt = if Text.length txt > at then Text.take (at - 4) txt <> " ..." else txt + +manyLines :: Int -> Text -> Text +manyLines trunc = + Text.lines + >>> fmap (truncate trunc) + >>> zip [0 :: Int ..] + >>> fmap (\(i, l) -> if i == 0 then l else "│ " <> l) + >>> Text.intercalate "\n" + -- | Print out the logs in rich format. Truncates at the given length. -- Logs will contain: message, timestamp, data, user and the call stack. prettyPrintSummary :: MonadIO m => Int -> EffectHandler Logging m a -> m a prettyPrintSummary trunc h = do lock <- liftIO (newMVar ()) flip handleLogging h $ \Log{..} -> liftIO $ withMVar lock $ \_ -> do + let callStackSection = manyLines trunc (toS (prettyCallStack logCallStack)) + let LogData{..} = logData + let dataSection = + if dataSummary == "" then truncate trunc (toSL dataPayload) + else manyLines trunc dataSummary putText "┌" - putText ("| " <> pshow logLevel <> " Log") - putText ("| Message: " <> logMessage) - putText ("| Time: " <> pshow logTimestamp) - putText ("| Data: " <> toS (BS.take trunc logData) <> "...") + putText ("│ " <> highlightT (colorFromLevel logLevel) (pshow logLevel <> " Log")) + putText ("│ " <> yellow "Message: " <> logMessage) + handleEarly $ do + ts <- ifNothingEarlyReturn () logTimestamp + putText ("│ " <> yellow "Time: " <> pshow ts) + unless (Text.null dataSection) $ + putText ("│ " <> yellow "Data: " <> dataSection) when (isJust logUser) $ do let Just LogUser{..} = logUser - putText ("| User: " <> logUserId <> ", " + putText ("│ " <> yellow "User: " <> logUserId <> ", " <> fromMaybe " - " logUserEmail <> ", " <> fromMaybe " - " logUserUsername) - putText ("| Stack: " <> toS (BS.take trunc (pshow logCallStack)) <> "...") + putText ("│ " <> yellow "Stack: " <> callStackSection) putText "└" + +-- | Catches all IO exceptions, logs them and throws them back. The callstack in the log is __not__ +-- the callstack of the exception. +logIOExceptions :: (MonadEffect Logging m, MonadCatch m) => m a -> m a +logIOExceptions = handleAll $ \(SomeException e) -> do + logError "An IO exception occurred" + & setDataWithSummary (LogData (pshow e) (toS (displayException e))) + throwM e
src/Interlude.hs view
@@ -17,6 +17,7 @@ import Data.Aeson as X hiding (Error) import Data.Char as X import Control.Concurrent as X +import Control.Arrow as X pshow :: (StringConv String b, Show a) => a -> b pshow = toS . show
− test/Module1.hs
@@ -1,16 +0,0 @@-module Module1 where - -import Interlude - -import Control.Effects.Logging - -main :: IO () -main = prettyPrintSummary 100 $ - collectCrumbs $ messagesToCrumbs $ do - layerLogs (Context "layer1") $ do - logInfo "Hello from layer1" - addUserToLogs (LogUser "id" (Just "email@email.com") (Just "username")) $ layerLogs (Context "layer2") $ do - logInfo "Hello from layer2" - setDataToShowOf (Just (5 :: Int)) $ logInfo "This message has a data" - setDataToJsonOf [1, 2, 3 :: Int] $ logInfo "This message has data but is in layer1" - logWarning "No layers but should still have crumbs"
test/Spec.hs view
@@ -1,2 +1,17 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"+module Spec where + +import Interlude + +import Control.Effects.Logging + +main :: IO () +main = prettyPrintSummary 100 $ setTimestampToNow $ logIOExceptions $ + collectCrumbs $ messagesToCrumbs $ do + layerLogs (Context "layer1") $ do + logInfo "Hello from layer1" + addUserToLogs (LogUser "id" (Just "email@email.com") (Just "username")) $ layerLogs (Context "layer2") $ do + logError "Hello from layer2" + setDataToShowOf (Just (5 :: Int)) $ logFatal "This message has a data" + setDataToJsonOf [1, 2, 3 :: Int] $ logDebug "This message has data but is in layer1" + logWarning "No layers but should still have crumbs" + error "test"