log-warper 0.4.2 → 0.4.3

raw patch · 6 files changed

+150/−11 lines, 6 filesdep +containersdep +monad-loopsnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, monad-loops

API changes (from Hackage documentation)

Files

• log-warper.cabal +4/−1
• src/System/Wlog/CanLog.hs +37/−7
• src/System/Wlog/Formatter.hs +17/−2
• src/System/Wlog/Launcher.hs +7/−0
• src/System/Wlog/LoggerConfig.hs +14/−1
• src/System/Wlog/MemoryQueue.hs +71/−0

@@ -1,5 +1,5 @@ name:                log-warper-version:             0.4.2+version:             0.4.3 synopsis:            Flexible, configurable, monadic and pretty logging homepage:            https://github.com/serokell/log-warper license:             MIT@@ -32,11 +32,13 @@    other-modules:       System.Wlog.Color                        System.Wlog.Formatter+                       System.Wlog.MemoryQueue    build-depends:       aeson                >= 0.11.2.1                      , ansi-terminal        >= 0.6.2.3                      , base                 >= 4.7 && < 5                      , bytestring           >= 0.10.8.1+                     , containers                      , directory            >= 1.2.6.2                      , dlist                >= 0.8.0.2                      , errors               >= 2.1.2@@ -48,6 +50,7 @@                      , hslogger             >= 1.2.10                      , lens                 >= 4.14                      , monad-control        >= 1.0.1.0+                     , monad-loops                      , mtl                  >= 2.2.1                      , safecopy             >= 0.9.1                      , text                 >= 1.2.2.0

@@ -1,7 +1,9 @@+{-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DefaultSignatures     #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedLists       #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-}@@ -15,6 +17,8 @@ module System.Wlog.CanLog        ( CanLog (..)        , WithLogger+       , memoryLogs+       , readMemoryLogs           -- * Pure logging manipulation        , PureLogger (..)@@ -31,6 +35,7 @@        , logMessage        ) where +import           Control.Concurrent        (MVar, modifyMVar_, newMVar) import           Control.Monad.Base        (MonadBase) import           Control.Monad.Except      (ExceptT, MonadError) import           Control.Monad.Reader      (MonadReader, ReaderT)@@ -41,17 +46,25 @@ import           Control.Monad.Writer      (MonadWriter (tell), WriterT (runWriterT))  import           Data.Bifunctor            (second)-import           Data.DList                (DList, toList)+import qualified Data.DList                as DL (DList) import           Data.SafeCopy             (base, deriveSafeCopySimple) import           Data.Text                 (Text) import qualified Data.Text                 as T+import           Data.Time                 (getCurrentTime) +import           System.IO.Unsafe          (unsafePerformIO) import           System.Log.Logger         (logM) +import           Universum++import           System.Wlog.Formatter     (formatLogMessageColors) import           System.Wlog.LoggerName    (LoggerName (..)) import           System.Wlog.LoggerNameBox (HasLoggerName (..), LoggerNameBox (..))+import           System.Wlog.MemoryQueue   (MemoryQueue)+import qualified System.Wlog.MemoryQueue   as MQ import           System.Wlog.Severity      (Severity (..), convertSeverity) + -- | Type alias for constraints 'CanLog' and 'HasLoggerName'. -- We need two different type classes to support more flexible interface -- but in practice we usually use them both.@@ -70,12 +83,25 @@                             -> t n ()     dispatchMessage name sev t = lift $ dispatchMessage name sev t +type LogMemoryQueue = MemoryQueue Text++-- TODO: dirty hack to have in-memory logs. Maybe will be refactored+-- later.  Maybe not.+memoryLogs :: MVar (Maybe LogMemoryQueue)+memoryLogs = unsafePerformIO $ newMVar Nothing+{-# NOINLINE memoryLogs #-}++-- | Retrieves memory logs in reversed order (newest are head).+readMemoryLogs :: (MonadIO m) => m [Text]+readMemoryLogs = do+    liftIO (readMVar memoryLogs) <&> maybe (pure []) MQ.toList+ instance CanLog IO where     dispatchMessage         (loggerName      -> name)         (convertSeverity -> prior)-        (T.unpack        -> t)-      = logM name prior t+        msg+      = logM name prior (T.unpack msg)  instance CanLog m => CanLog (LoggerNameBox m) instance CanLog m => CanLog (ReaderT r m)@@ -101,8 +127,8 @@ -- TODO: Should we use some @Data.Tree@-like structure to observe message only -- by chosen logger names? newtype PureLogger m a = PureLogger-    { runPureLogger :: WriterT (DList LogEvent) m a-    } deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DList LogEvent),+    { runPureLogger :: WriterT (DL.DList LogEvent) m a+    } deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DL.DList LogEvent),                 MonadBase b, MonadState s, MonadReader r, MonadError e, HasLoggerName)  instance Monad m => CanLog (PureLogger m) where@@ -122,8 +148,7 @@ -- | Shortcut for 'logMessage' to use according severity. logDebug, logInfo, logNotice, logWarning, logError     :: WithLogger m-    => Text-    -> m ()+    => Text -> m () logDebug   = logMessage Debug logInfo    = logMessage Info logNotice  = logMessage Notice@@ -139,3 +164,8 @@ logMessage severity t = do     name <- getLoggerName     dispatchMessage name severity t+    !() <- pure $ unsafePerformIO $ do+        curTime <- getCurrentTime+        let formatted = formatLogMessageColors name severity curTime t+        modifyMVar_ memoryLogs (pure . (MQ.pushFront formatted <$>))+    pure ()

@@ -1,3 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-}+ -- | -- Module      : System.Wlog.Formatter -- Copyright   : (c) Serokell, 2016@@ -10,13 +12,14 @@  module System.Wlog.Formatter        ( formatLogMessage+       , formatLogMessageColors        , setStderrFormatter        , setStdoutFormatter        ) where  import           Data.Monoid            (mconcat) import           Data.String            (IsString)-import           Data.Text              (Text)+import           Data.Text              (Text, pack, unpack) import           Data.Time.Clock        (UTCTime) import           Formatting             (Format, sformat, shown, stext, (%)) @@ -26,8 +29,10 @@  import           System.Wlog.Color      (colorizer) import           System.Wlog.LoggerName (LoggerName, loggerNameF)-import           System.Wlog.Severity   (Severity)+import           System.Wlog.Severity   (Severity, convertSeverity) +import           Universum+ timeFmt :: IsString s => s timeFmt = "[$time] " @@ -59,5 +64,15 @@ formatLogMessage :: LoggerName -> Severity -> UTCTime -> Text -> Text formatLogMessage = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"] "%stext)   where+    utcTimeF :: Format r (UTCTime -> r)+    utcTimeF = shown++-- | Same as 'formatLogMessage', but with colorful output+formatLogMessageColors :: LoggerName -> Severity -> UTCTime -> Text -> Text+formatLogMessageColors lname severity time msg =+    pack (colorizer pr $ unpack prefix) <> " " <> msg+  where+    pr = convertSeverity severity+    prefix = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"]") lname severity time     utcTimeF :: Format r (UTCTime -> r)     utcTimeF = shown

@@ -56,9 +56,11 @@ import           System.Log.Handler.Simple (fileHandler) import           System.Log.Logger         (addHandler, updateGlobalLogger) +import           System.Wlog.CanLog        (memoryLogs) import           System.Wlog.Formatter     (setStdoutFormatter) import           System.Wlog.LoggerConfig  (LoggerConfig (..), LoggerTree (..)) import           System.Wlog.LoggerName    (LoggerName (..))+import           System.Wlog.MemoryQueue   (newMemoryQueue) import           System.Wlog.Roller        (rotationFileHandler) import           System.Wlog.Wrapper       (Severity (Debug), convertSeverity,                                             initTerminalLogging, setSeverityMaybe)@@ -73,6 +75,11 @@ setupLogging LoggerConfig{..} = do     liftIO $ createDirectoryIfMissing True handlerPrefix     when consoleOutput $ initTerminalLogging isShowTime _lcTermSeverity+    -- TODO: use lifted version here+    whenJust _lcMemModeLimit $ \limit -> do+        putText "Initializing logs"+        let cpj = const . pure . Just -- just for lulz+        liftIO $ modifyMVar_ memoryLogs $ cpj $ newMemoryQueue limit     processLoggers mempty _lcTree   where     handlerPrefix = _lcFilePrefix ?: "."

@@ -31,6 +31,7 @@        , lcConsoleOutput        , lcFilePrefix        , lcMapper+       , lcMemModeLimit        , lcRotation        , lcShowTime        , lcTermSeverity@@ -40,6 +41,7 @@          -- ** Builders for 'LoggerConfig'        , consoleOutB        , mapperB+       , memoryB        , prefixB        , productionB        , showTimeB@@ -172,6 +174,9 @@       -- | Path prefix to add for each logger file     , _lcFilePrefix    :: Maybe FilePath +      -- | Limit for queue in memory mode.+    , _lcMemModeLimit  :: Maybe Word64+       -- | Hierarchical tree of loggers.     , _lcTree          :: LoggerTree     }@@ -187,6 +192,7 @@         , _lcConsoleOutput = mempty         , _lcMapper        = mempty         , _lcFilePrefix    = mempty+        , _lcMemModeLimit  = Nothing         , _lcTree          = mempty         } @@ -197,11 +203,12 @@         , _lcConsoleOutput = _lcConsoleOutput lc1  <> _lcConsoleOutput lc2         , _lcMapper        = _lcMapper        lc1  <> _lcMapper        lc2         , _lcFilePrefix    = _lcFilePrefix    lc1 <|> _lcFilePrefix    lc2+        , _lcMemModeLimit  = _lcMemModeLimit  lc1 <|> _lcMemModeLimit  lc2         , _lcTree          = _lcTree          lc1  <> _lcTree          lc2         }  topLevelParams :: [Text]-topLevelParams = ["rotation", "showTime", "printOutput", "filePrefix"]+topLevelParams = ["rotation", "showTime", "printOutput", "filePrefix", "memModeLimit"]  instance FromJSON LoggerConfig where     parseJSON = withObject "rotation params" $ \o -> do@@ -210,6 +217,7 @@         _lcShowTime      <- Any <$> o .:? "showTime"    .!= False         _lcConsoleOutput <- Any <$> o .:? "printOutput" .!= False         _lcFilePrefix    <-         o .:? "filePrefix"+        _lcMemModeLimit  <-         o .:? "memModeLimit"         _lcTree          <- parseJSON $ Object $ filterObject topLevelParams o         let _lcMapper     = mempty         return LoggerConfig{..}@@ -223,6 +231,7 @@             , "showTime"     .= getAny _lcShowTime             , "printOutput"  .= getAny _lcConsoleOutput             , "filePrefix"   .= _lcFilePrefix+            , "memModeLimit" .= _lcMemModeLimit             , ("logTree", toJSON _lcTree)             ] @@ -247,3 +256,7 @@ -- | Setup 'lcFilePrefix' inside 'LoggerConfig'. prefixB :: FilePath -> LoggerConfig prefixB filePrefix = mempty { _lcFilePrefix = Just filePrefix }++-- | Setup memory logger with certain limit+memoryB :: Word64 -> LoggerConfig+memoryB limit = mempty { _lcMemModeLimit = Just limit }

@@ -0,0 +1,71 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Queue for in-memory logs. Rolls out old logging if size of queue+-- is bigger than predefined limit.++module System.Wlog.MemoryQueue+       ( Sized(..)+       , MemoryQueue(..)+       , newMemoryQueue+       , popLast+       , pushFront+       , toList+       ) where++import           Control.Lens        (to)+import           Data.Sequence       (Seq, ViewR (..), viewr, (<|))+import           Universum           hiding (toList)+import qualified Universum           as U++import           Control.Lens        (makeLenses, (%=), (+=))+import           Control.Monad.Loops (whileM_)++-- | Class for objects that have size. Implementations can take size+-- as amount of memory items take, as amount of items in container,+-- etc.+class Sized e where+    getSize :: e -> Word64++-- Instance for text size that takes number of chars in text as size+-- (not actual bytes).+instance Sized Text where+    getSize = fromIntegral . length+++-- | Data structure similar to queue but pops out elements after+-- 'pushFront' if 'mqMemSize' > 'mqLimit'.+data MemoryQueue a = MemoryQueue+    { _mqLimit   :: !Word64+    , _mqMemSize :: !Word64+    , _mqQueue   :: !(Seq a)+    } deriving (Show)++makeLenses ''MemoryQueue++-- | Creates new memory queue.+newMemoryQueue :: (Sized a) => Word64 -> MemoryQueue a+newMemoryQueue _mqLimit = MemoryQueue { _mqMemSize = 0, _mqQueue = mempty, .. }++-- | Removes last element from 'MemoryQueue'.+popLast :: (Sized a) => MemoryQueue a -> (Maybe a, MemoryQueue a)+popLast mq@MemoryQueue{..} = case viewr _mqQueue of+    EmptyR         -> (Nothing, mq)+    rest :> popped ->+        let newMemSize = _mqMemSize - getSize popped+        in (Just popped, MemoryQueue{ _mqMemSize = newMemSize, _mqQueue = rest, .. })++-- | Add new element at the beginning removing elements from the end+-- untill size become not greater than limit.+pushFront :: (Sized a) => a -> MemoryQueue a -> MemoryQueue a+pushFront msg mq = executingState mq $ do+    mqMemSize += getSize msg+    mqQueue   %= (msg <|)+    whileM_ isLimitExceeded $+        modify (snd . popLast)+  where+    isLimitExceeded = liftA2 (<) (use mqLimit) (use mqMemSize)++-- | Converts queue to list of messages.+toList :: (Sized a) => MemoryQueue a -> [a]+toList = view $ mqQueue . to U.toList