diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -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 diff --git a/src/System/Wlog/CanLog.hs b/src/System/Wlog/CanLog.hs --- a/src/System/Wlog/CanLog.hs +++ b/src/System/Wlog/CanLog.hs @@ -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 () diff --git a/src/System/Wlog/Formatter.hs b/src/System/Wlog/Formatter.hs --- a/src/System/Wlog/Formatter.hs +++ b/src/System/Wlog/Formatter.hs @@ -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 diff --git a/src/System/Wlog/Launcher.hs b/src/System/Wlog/Launcher.hs --- a/src/System/Wlog/Launcher.hs +++ b/src/System/Wlog/Launcher.hs @@ -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 ?: "." diff --git a/src/System/Wlog/LoggerConfig.hs b/src/System/Wlog/LoggerConfig.hs --- a/src/System/Wlog/LoggerConfig.hs +++ b/src/System/Wlog/LoggerConfig.hs @@ -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 } diff --git a/src/System/Wlog/MemoryQueue.hs b/src/System/Wlog/MemoryQueue.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/MemoryQueue.hs @@ -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