diff --git a/micrologger.cabal b/micrologger.cabal --- a/micrologger.cabal +++ b/micrologger.cabal @@ -1,35 +1,47 @@ name: micrologger -version: 0.4.0.1 -synopsis: A super simple logging module. Only for use for very simple projects. -description: A super simple logging module. Only for use for very simple projects. +version: 0.5.0.0 +synopsis: A super simple logging module. +description: A super simple logging module that primarily outputs json-formatted messages. homepage: https://github.com/savannidgerinel/micrologger#readme license: BSD3 license-file: LICENSE author: Savanni D'Gerinel -maintainer: savanni@savannidgerinel.com -copyright: 2016 Savanni D'Gerinel +maintainer: savanni@luminescent-dreams.com +copyright: 2016 - 2017 Savanni D'Gerinel category: Web build-type: Simple -- extra-source-files: cabal-version: >=1.10 +flag dev + description: Turn on development settings + manual: True + default: False + + library - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 - exposed-modules: LuminescentDreams.Logger - LuminescentDreams.Logger.Internal + if flag(dev) + ghc-options: -Wall + else + ghc-options: -Wall -Werror + + exposed-modules: LuminescentDreams.Logger LuminescentDreams.Logger.JSON LuminescentDreams.Logger.Standard + LuminescentDreams.Logger.Types - build-depends: base >= 4.7 && < 5 - , aeson >= 1.0 && < 1.1 - , containers >= 0.5.6 && < 0.6 - , text >= 1.2 && < 1.3 - , text-format >= 0.3 && < 0.4 - , time >= 1.5 && < 1.7 - , transformers >= 0.4 && < 0.6 + build-depends: base >= 4.7 && < 5 + , aeson >= 1.0 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5.6 && < 0.6 + , lens >= 4.15 && < 4.16 + , text >= 1.2 && < 1.3 + , text-format >= 0.3 && < 0.4 + , time >= 1.5 && < 1.7 + , transformers >= 0.4 && < 0.6 test-suite micrologger-test type: exitcode-stdio-1.0 diff --git a/src/LuminescentDreams/Logger.hs b/src/LuminescentDreams/Logger.hs --- a/src/LuminescentDreams/Logger.hs +++ b/src/LuminescentDreams/Logger.hs @@ -11,27 +11,28 @@ ) where -import LuminescentDreams.Logger.Internal +import LuminescentDreams.Logger.Types import LuminescentDreams.Logger.JSON as X import LuminescentDreams.Logger.Standard as X import Data.Monoid import Data.IORef (IORef, modifyIORef) -import qualified Data.Text.Lazy as T +import qualified Data.Text as T import System.IO (IOMode(..), hPutStrLn, hFlush, withFile, stdout) {- | Ordinary configurations for a file-based logger. -} -data LogConfig = Stdout LogLevel - | Buffer (IORef T.Text) LogLevel - | FileLog FilePath LogLevel +data LogConfig = Stdout LogLevel T.Text [T.Text] + | Buffer (IORef T.Text) LogLevel T.Text [T.Text] + | FileLog FilePath LogLevel T.Text [T.Text] {- | Run an IO action with a log safely available. Logs will be properly closed in the case of an exception. Logging is meant to happen to a file, specified in LogConfig, so this may not be suitable if you want to log to a different resource. -} withLogger :: LogConfig -> (Logger -> IO a) -> IO a -withLogger (Stdout level) act = - act (Logger (\m -> putStrLn (T.unpack m) >> hFlush stdout) level) -withLogger (Buffer ref level) act = - act (Logger (\m -> modifyIORef ref (\buf -> buf <> m <> T.pack "\n")) level) -withLogger (FileLog path level) act = +withLogger (Stdout level app tags) act = + act (Logger (\m -> putStrLn (T.unpack m) >> hFlush stdout) level app tags) +withLogger (Buffer ref level app tags) act = + act (Logger (\m -> modifyIORef ref (\buf -> buf <> m <> T.pack "\n")) level app tags) +withLogger (FileLog path level app tags) act = withFile path AppendMode $ \h -> - act (Logger (\m -> hPutStrLn h (T.unpack m) >> hFlush h) level) + act (Logger (\m -> hPutStrLn h (T.unpack m) >> hFlush h) level app tags) + diff --git a/src/LuminescentDreams/Logger/Internal.hs b/src/LuminescentDreams/Logger/Internal.hs deleted file mode 100644 --- a/src/LuminescentDreams/Logger/Internal.hs +++ /dev/null @@ -1,31 +0,0 @@ -{- | Internal definitions. Do not import directly. -} -module LuminescentDreams.Logger.Internal where - -import qualified Data.Text.Buildable as TFB -import qualified Data.Text.Lazy as T - -{- | An ordinary hierarchy of logging priorities. -} -data LogLevel = LogDebug - | LogInfo - | LogWarning - | LogError - | LogEmergency - deriving (Eq, Ord, Show) - -tzFormat :: String -tzFormat = "%Y-%m-%dT%H:%M:%S%Q%z" - -{- | The primary data structure to contain a logger of any kind. -} -data Logger = Logger { logCmd_ :: (T.Text -> IO ()) - -- ^ Any IO action that accepts the log message - , lvl_ :: LogLevel - -- ^ The minimum level at which a log message should be accepted - } - -{- | Generate standard text representations of a log level. This is useful to the Standard logger but may not be interesting to any others. -} -instance TFB.Buildable LogLevel where - build LogDebug = TFB.build ("DEBUG" :: String) - build LogInfo = TFB.build ("INFO" :: String) - build LogWarning = TFB.build ("WARNING" :: String) - build LogError = TFB.build ("ERROR" :: String) - build LogEmergency = TFB.build ("EMERGENCY" :: String) diff --git a/src/LuminescentDreams/Logger/JSON.hs b/src/LuminescentDreams/Logger/JSON.hs --- a/src/LuminescentDreams/Logger/JSON.hs +++ b/src/LuminescentDreams/Logger/JSON.hs @@ -6,28 +6,32 @@ module LuminescentDreams.Logger.JSON ( logMsgJs, formatMsgJs ) where import Control.Monad (when) -import Data.Monoid +import qualified Data.ByteString.Lazy as BL import qualified Data.Aeson as Aeson import qualified Data.Map as M +import Data.Monoid import Data.String import qualified Data.Text.Format as TF -import qualified Data.Text.Lazy.Encoding as TEnc +import qualified Data.Text as T +import qualified Data.Text.Encoding as TEnc +import qualified Data.Text.Lazy as TL import qualified Data.Time as Time -import qualified Data.Text.Lazy as T -import LuminescentDreams.Logger.Internal +import LuminescentDreams.Logger.Types -{- | Log a message in LogZ format. This uses `formatMsgJs` to generate the actual format string. -} logMsgJs :: Logger -> LogLevel -> [(String, Aeson.Value)] -> IO () -logMsgJs (Logger writer pri) lvl msg = +logMsgJs (Logger writer pri app_ tags_) lvl msg = when (lvl >= pri) $ do t <- Time.getCurrentTime - writer $ formatMsgJs t lvl msg + writer $ formatMsgJs app_ tags_ t lvl msg {- | Format a message for LogZ JSON format. -} -formatMsgJs :: Time.UTCTime -> LogLevel -> [(String, Aeson.Value)] -> T.Text -formatMsgJs time level msg = +formatMsgJs :: T.Text -> [T.Text] -> Time.UTCTime -> LogLevel -> [(String, Aeson.Value)] -> T.Text +formatMsgJs application tags time level msg = let msg_ = msg <> [ ("@timestamp", fromString $ Time.formatTime Time.defaultTimeLocale tzFormat time) - , ("@level", Aeson.String $ T.toStrict $ TF.format "{}" (TF.Only level)) + , ("@level", Aeson.String $ TL.toStrict $ TF.format "{}" (TF.Only level)) + , ("@tags", Aeson.toJSON tags) + , ("@app", Aeson.String application) ] - in TEnc.decodeUtf8 $ Aeson.encode $ M.fromList msg_ + in TEnc.decodeUtf8 $ BL.toStrict $ Aeson.encode $ M.fromList msg_ + diff --git a/src/LuminescentDreams/Logger/Standard.hs b/src/LuminescentDreams/Logger/Standard.hs --- a/src/LuminescentDreams/Logger/Standard.hs +++ b/src/LuminescentDreams/Logger/Standard.hs @@ -2,17 +2,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module LuminescentDreams.Logger.Standard ( logMsgStd, formatMsgStd ) where +module LuminescentDreams.Logger.Standard where import Control.Monad (when) import Data.Monoid import qualified Data.Text.Format as TF -import qualified Data.Text.Lazy as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Buildable as TFB import qualified Data.Time as Time import qualified Data.List as List -import LuminescentDreams.Logger.Internal +import LuminescentDreams.Logger.Types data LogMsg = LogMsg LogLevel [(String, String)] String @@ -21,23 +22,28 @@ logMsgStd l lvl tags text = logMsg_ l (LogMsg lvl tags text) logMsg_ :: Logger -> LogMsg -> IO () -logMsg_ (Logger writer pri) msg@(LogMsg lvl _ _) = +logMsg_ (Logger writer pri app tags) msg@(LogMsg lvl _ _) = when (lvl >= pri) $ do t <- Time.getCurrentTime - writer $ formatMsgStd t msg + writer $ formatMsgStd app tags t msg -formatMsgStd :: Time.UTCTime -> LogMsg -> T.Text -formatMsgStd t (LogMsg lvl tags text) = - TF.format "{} {} {} {}" (Time.formatTime Time.defaultTimeLocale tzFormat t, lvl, tags, text) +formatMsgStd :: T.Text -> [T.Text] -> Time.UTCTime -> LogMsg -> T.Text +formatMsgStd _ _ t (LogMsg lvl tags text) = + TL.toStrict $ TF.format "{} {} {} {}" ( Time.formatTime Time.defaultTimeLocale tzFormat t + , lvl + , tags + , text + ) instance TFB.Buildable (String, String) where - build (name, value) = TFB.build $ "(" <> name <> ", " <> value <> ")" + build (name, value) = TFB.build $ "(" <> name <> ", " <> value <> ")" instance TFB.Buildable [(String, String)] where - -- build lst = TFB.build "[" <> TFB.build `fmap` lst "]" - build lst = - mconcat $ [TFB.build ("[" :: String)] - <> List.intersperse (TFB.build (", " :: String)) (TFB.build `fmap` lst) - <> [TFB.build ("]" :: String)] + -- build lst = TFB.build "[" <> TFB.build `fmap` lst "]" + build lst = + mconcat $ [TFB.build ("[" :: String)] + <> List.intersperse (TFB.build (", " :: String)) (TFB.build `fmap` lst) + <> [TFB.build ("]" :: String)] + diff --git a/src/LuminescentDreams/Logger/Types.hs b/src/LuminescentDreams/Logger/Types.hs new file mode 100644 --- /dev/null +++ b/src/LuminescentDreams/Logger/Types.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +{- | Logger type definitions -} +module LuminescentDreams.Logger.Types where + +import Control.Lens +import qualified Data.Text.Buildable as TFB +import qualified Data.Text as T + +{- | An ordinary hierarchy of logging priorities. -} +data LogLevel = LogDebug + | LogInfo + | LogWarning + | LogError + | LogEmergency + deriving (Eq, Ord, Show) + +tzFormat :: String +tzFormat = "%Y-%m-%dT%H:%M:%S%Q%z" + +{- | The primary data structure to contain a logger of any kind. -} +data Logger = Logger { _logCmd :: (T.Text -> IO ()) + -- ^ Any IO action that accepts the log message + , _logLvl :: LogLevel + , _logApp :: T.Text + , _logTags :: [T.Text] + -- ^ The minimum level at which a log message should be accepted + } + +{- | Generate standard text representations of a log level. This is useful to the Standard logger but may not be interesting to any others. -} +instance TFB.Buildable LogLevel where + build LogDebug = TFB.build ("DEBUG" :: String) + build LogInfo = TFB.build ("INFO" :: String) + build LogWarning = TFB.build ("WARNING" :: String) + build LogError = TFB.build ("ERROR" :: String) + build LogEmergency = TFB.build ("EMERGENCY" :: String) + +makeLenses ''Logger + diff --git a/test/LogSpec.hs b/test/LogSpec.hs --- a/test/LogSpec.hs +++ b/test/LogSpec.hs @@ -5,7 +5,7 @@ import Data.Aeson (Value(..), toJSON) import Data.Monoid import qualified Data.IORef as IORef -import qualified Data.Text.Lazy as T +import qualified Data.Text as T import Test.Hspec import LuminescentDreams.Logger @@ -13,11 +13,12 @@ writeBuffer :: IORef.IORef [T.Text] -> T.Text -> IO () writeBuffer buffer text = IORef.modifyIORef' buffer (\lst -> lst <> [text]) + basicLogger :: Spec basicLogger = describe "demonstrate IO output" $ do it "outputs in the standard format" $ do logRef <- IORef.newIORef [] - let l = Logger (writeBuffer logRef) LogDebug + let l = Logger (writeBuffer logRef) LogDebug "test" [] logMsgStd l LogInfo [("name", "value")] "message" logMsgStd l LogInfo [("name", "value")] "message2" IORef.readIORef logRef >>= flip forM_ (putStrLn . T.unpack) @@ -27,7 +28,7 @@ jsonLogger = describe "demonstrate the JSON logger with IO output" $ do it "outputs in the JSON format" $ do logRef <- IORef.newIORef [] - let l = Logger (writeBuffer logRef) LogDebug + let l = Logger (writeBuffer logRef) LogDebug "test" [] logMsgJs l LogInfo [("name", String "value"), ("timing", toJSON (0.5 :: Float)), ("msg", String "message")] logMsgJs l LogInfo [("name", String "value"), ("timing", toJSON (0.5 :: Float)), ("msg", String "message2")] IORef.readIORef logRef >>= flip forM_ (putStrLn . T.unpack) @@ -39,7 +40,7 @@ it "outputs to a file buffer" $ do logRef <- IORef.newIORef T.empty - withLogger (Buffer logRef LogInfo) $ \l -> do + withLogger (Buffer logRef LogInfo "test" []) $ \l -> do logMsgStd l LogInfo [("name", "value")] "message" logMsgStd l LogDebug [("name", "value")] "message2" logMsgJs l LogDebug [("name", String "value"), ("timing", toJSON (0.5 :: Float)), ("msg", String "message")]