[CBR-211] log rotation checks for size and age of files

pkgs/default.nix

@@ -17323,6 +17323,7 @@ license = stdenv.lib.licenses.mit;
   mkDerivation
 , aeson
 , async
+, auto-update
 , base
 , bytestring
 , canonical-json
@@ -17385,6 +17386,7 @@ configureFlags = [
 ];
 libraryHaskellDepends = [
 aeson
+auto-update
 base
 canonical-json
 cborg

util/cardano-sl-util.cabal

@@ -56,8 +56,10 @@ library
   other-modules:
                        Pos.Util.CompileInfoGit
                        Pos.Util.Log.Scribes
+                       Pos.Util.Log.Rotator
 
   build-depends:       aeson
+                     , auto-update
                      , base
                      , canonical-json
                      , cborg

util/src/Pos/Util/Log.hs

@@ -3,15 +3,15 @@
 module Pos.Util.Log
        (
        -- * Logging
-         Severity(..)
+         Severity (..)
        , LogContext
        , LogContextT
        , LoggingHandler
        -- * Compatibility
-       , CanLog(..)
+       , CanLog (..)
        , WithLogger
        -- * Configuration
-       , LoggerConfig(..)
+       , LoggerConfig (..)
        , parseLoggerConfig
        , retrieveLogFiles
        -- * Startup
@@ -37,7 +37,6 @@ import           Universum
 
 import           Control.Lens (each)
 
-
 import qualified Data.Text as T
 import           Data.Text.Lazy.Builder
 
@@ -116,28 +115,39 @@ setupLogging lc = do
     liftIO $ Internal.registerBackends lh scribes
     return lh
       where
+        -- returns a list of: (name, Scribe, finalizer)
         meta :: LoggingHandler -> LoggerConfig -> IO [(T.Text, K.Scribe)]
         meta _lh _lc = do
             -- setup scribes according to configuration
             let lhs = _lc ^. lcLoggerTree ^. ltHandlers ^.. each
                 basepath = _lc ^. lcBasePath
+                -- default rotation parameters: max. 24 hours, max. 10 files kept, max. size 5 MB
+                rotation = fromMaybe (RotationParameters {_rpMaxAgeHours=24,_rpKeepFilesNum=10,_rpLogLimitBytes=5*1000*1000})
+                                     (_lc ^. lcRotation)
             forM lhs (\lh -> case (lh ^. lhBackend) of
                     FileJsonBE -> do
-                        putStrLn ("creating JSON backend ..." :: Text)
+                        let bp = fromMaybe "." basepath
+                            fp = fromMaybe "node.json" $ lh ^. lhFpath
+                            fdesc = Internal.mkFileDescription bp fp
+                            nm = lh ^. lhName
                         scribe <- mkJsonFileScribe
-                                      (fromMaybe "." basepath)
-                                      (fromMaybe "<unk>" $ lh ^. lhFpath)
+                                      rotation
+                                      fdesc
                                       (Internal.sev2klog $ fromMaybe Debug $ lh ^. lhMinSeverity)
                                       K.V0
-                        return (lh ^. lhName, scribe)
+                        return (nm, scribe)
                     FileTextBE -> do
-                        scribe <- mkFileScribe
-                                      (fromMaybe "." basepath)
-                                      (fromMaybe "<unk>" $ lh ^. lhFpath)
+                        let bp = fromMaybe "." basepath
+                            fp = (fromMaybe "node.log" $ lh ^. lhFpath)
+                            fdesc = Internal.mkFileDescription bp fp
+                            nm = lh ^. lhName
+                        scribe <- mkTextFileScribe
+                                      rotation
+                                      fdesc
                                       True
                                       (Internal.sev2klog $ fromMaybe Debug $ lh ^. lhMinSeverity)
                                       K.V0
-                        return (lh ^. lhName, scribe)
+                        return (nm, scribe)
                     StdoutBE -> do
                         scribe <- mkStdoutScribe
                                       (Internal.sev2klog $ fromMaybe Debug $ lh ^. lhMinSeverity)
@@ -155,7 +165,6 @@ setupLogging lc = do
                         return (lh ^. lhName, scribe)
                  )
 
-
 {-| provide logging in IO
 
 * example

util/src/Pos/Util/Log/Internal.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
+
 -- | internal definitions for "Pos.Util.Log"
+
 module Pos.Util.Log.Internal
        ( newConfig
        , registerBackends
@@ -13,15 +15,21 @@ module Pos.Util.Log.Internal
        , incrementLinesLogged
        , modifyLinesLogged
        , LoggingHandler      --  only export name
+       , FileDescription (..)
+       , mkFileDescription
        ) where
 
+import           Control.AutoUpdate (UpdateSettings (..), defaultUpdateSettings,
+                     mkAutoUpdate)
 import           Control.Concurrent.MVar (modifyMVar_, newMVar, withMVar)
 
 import qualified Data.Text as T
 import           Data.Time (UTCTime, getCurrentTime)
+import           System.FilePath (splitFileName, (</>))
 import           Universum hiding (newMVar)
 
 import qualified Katip as K
+import qualified Katip.Core as KC
 
 import           Pos.Util.Log.LoggerConfig (LoggerConfig (..))
 import           Pos.Util.Log.Severity
@@ -42,6 +50,20 @@ s2kname s = K.Namespace [s]
 s2knames :: [Text] -> K.Namespace
 s2knames s = K.Namespace s
 
+-- | log files have a prefix and a name
+data FileDescription = FileDescription {
+                         prefixpath :: FilePath,
+                         filename   :: FilePath }
+                       deriving (Show)
+
+mkFileDescription :: FilePath -> FilePath -> FileDescription
+mkFileDescription bp fp =
+    -- if fp contains a filename in a directory path
+    --    move this path to the prefix and only keep the name
+    let (extbp, fname) = splitFileName fp
+    in
+    FileDescription { prefixpath = bp </> extbp
+                    , filename = fname }
 
 -- | Our internal state
 data LoggingHandlerInternal = LoggingHandlerInternal
@@ -89,13 +111,23 @@ registerBackends :: LoggingHandler -> [(T.Text, K.Scribe)] -> IO ()
 registerBackends lh scribes = do
     LoggingHandlerInternal cfg _ counter <- takeMVar (getLSI lh)
     le0 <- K.initLogEnv (s2kname "cardano-sl") "production"
-    let le1 = updateEnv le0 getCurrentTime
+    -- use 'getCurrentTime' to get a more precise timestamp
+    -- as katip uses per default some internal buffered time variable
+    timer <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime, updateFreq = 10000 }
+    let le1 = updateEnv le0 timer
     le <- register scribes le1
     putMVar (getLSI lh) $ LoggingHandlerInternal cfg (Just le) counter
       where
         register :: [(T.Text, K.Scribe)] -> K.LogEnv -> IO K.LogEnv
         register [] le = return le
         register ((n, s):scs) le =
-            register scs =<< K.registerScribe n s K.defaultScribeSettings le
+            register scs =<< K.registerScribe n s scribeSettings le
         updateEnv :: K.LogEnv -> IO UTCTime -> K.LogEnv
-        updateEnv le f = le { K._logEnvTimer = f }
+        -- request a new time 'getCurrentTime' at most 100 times a second
+        updateEnv le timer =
+            le { K._logEnvTimer = timer, K._logEnvHost = "hostname" }
+
+scribeSettings :: KC.ScribeSettings
+scribeSettings = KC.ScribeSettings bufferSize
+  where
+    bufferSize = 5000   -- size of the queue (in log items)

util/src/Pos/Util/Log/LoggerConfig.hs

@@ -20,8 +20,9 @@ module Pos.Util.Log.LoggerConfig
        , lcBasePath
        , ltHandlers
        , ltMinSeverity
-       , rpKeepFiles
-       , rpLogLimit
+       , rpKeepFilesNum
+       , rpLogLimitBytes
+       , rpMaxAgeHours
        , lhBackend
        , lhName
        , lhFpath
@@ -58,15 +59,17 @@ deriving instance FromJSON BackendKind
 -- | @'RotationParameters'@ one of the two categories  used in the
 --   logging config, specifying the log rotation parameters
 data RotationParameters = RotationParameters
-    { _rpLogLimit  :: !Word64  -- ^ max size of file in bytes
-    , _rpKeepFiles :: !Word    -- ^ number of files to keep
+    { _rpLogLimitBytes :: !Word64  -- ^ max size of file in bytes
+    , _rpMaxAgeHours   :: !Word    -- ^ hours
+    , _rpKeepFilesNum  :: !Word    -- ^ number of files to keep
     } deriving (Generic, Show, Eq)
 
 instance ToJSON RotationParameters
 instance FromJSON RotationParameters where
     parseJSON = withObject "rotation params" $ \o -> do
-        _rpLogLimit  <- o .: "logLimit"
-        _rpKeepFiles <- o .: "keepFiles"
+        _rpLogLimitBytes  <- o .: "logLimit"
+        _rpMaxAgeHours    <- o .:? "maxAge" .!= 24
+        _rpKeepFilesNum   <- o .: "keepFiles"
         return RotationParameters{..}
 
 makeLenses ''RotationParameters
@@ -193,8 +196,9 @@ instance Semigroup LoggerConfig where
                 }
 instance Monoid LoggerConfig where
     mempty = LoggerConfig { _lcRotation = Just RotationParameters {
-                                            _rpLogLimit = 10 * 1024 * 1024,
-                                            _rpKeepFiles = 10 }
+                                            _rpLogLimitBytes = 5 * 1024 * 1024,
+                                            _rpKeepFilesNum  = 10,
+                                            _rpMaxAgeHours   = 24 }
                      , _lcLoggerTree = mempty
                      , _lcBasePath = Nothing
                      }

util/src/Pos/Util/Log/Rotator.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | monitor log files for max age and max size
+
+module Pos.Util.Log.Rotator
+       ( cleanupRotator
+       , evalRotator
+       , initializeRotator
+       ) where
+
+import           Universum
+
+import           Control.Exception.Safe (Exception (..), catchIO)
+
+import qualified Data.List.NonEmpty as NE
+import           Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime,
+                     parseTimeM)
+import           Data.Time.Format (defaultTimeLocale, formatTime)
+
+import           Pos.Util.Log.Internal (FileDescription (..))
+import           Pos.Util.Log.LoggerConfig
+
+import           System.Directory (listDirectory, removeFile)
+import           System.FilePath ((</>))
+import           System.IO (BufferMode (LineBuffering), Handle,
+                     IOMode (WriteMode), hFileSize, hSetBuffering, stdout)
+
+
+-- | format of a timestamp
+tsformat :: String
+tsformat = "%Y%m%d%H%M%S"
+
+-- | get file path to a log file with current time
+nameLogFile :: FileDescription -> IO FilePath
+nameLogFile FileDescription{..} = do
+    now <- getCurrentTime
+    let tsnow = formatTime defaultTimeLocale tsformat now
+    return $ prefixpath </> filename ++ "-" ++ tsnow
+
+-- | open a new log file
+evalRotator :: RotationParameters -> FileDescription -> IO (Handle, Integer, UTCTime)
+evalRotator rotation fdesc = do
+    let maxAge   = toInteger $ rotation ^. rpMaxAgeHours
+        maxSize  = toInteger $ rotation ^. rpLogLimitBytes
+
+    -- open new log file
+    fpath <- nameLogFile fdesc
+    hdl <- catchIO (openFile fpath WriteMode) $
+               \e -> do
+                   prtoutException fpath e
+                   return stdout    -- fallback to standard output in case of exception
+    hSetBuffering hdl LineBuffering
+
+    -- compute next rotation time
+    now <- getCurrentTime
+    let rottime = addUTCTime (fromInteger $ maxAge * 3600) now
+
+    return (hdl, maxSize, rottime)
+
+prtoutException :: Exception e => FilePath -> e -> IO ()
+prtoutException fp e = do
+    putStrLn $ "error while opening log @ " ++ fp
+    putStrLn $ "exception: " ++ displayException e
+
+-- | list filenames in prefix dir which match 'filename'
+listLogFiles :: FileDescription -> IO (Maybe (NonEmpty FilePath))
+listLogFiles FileDescription{..} = do
+    -- find files in bp which begin with fp
+    files <- listDirectory $ prefixpath
+    return $ nonEmpty $ sort $ filter fpredicate files
+  where
+    tslen = 14  -- length of a timestamp
+    fplen = length filename
+    fpredicate path = take fplen path == filename
+                      && take 1 (drop fplen path) == "-"
+                      && length (drop (fplen + 1) path) == tslen
+
+-- | latest log file in prefix dir which matches 'filename'
+latestLogFile :: FileDescription -> IO (Maybe FilePath)
+latestLogFile fdesc =
+    listLogFiles fdesc >>= \fs -> return $ latestLogFile' fs
+  where
+    latestLogFile' :: Maybe (NonEmpty FilePath) -> Maybe FilePath
+    latestLogFile' Nothing      = Nothing
+    latestLogFile' (Just flist) = Just $ last flist
+
+-- | initialize log file at startup
+--   may append to existing file
+initializeRotator :: RotationParameters -> FileDescription -> IO (Handle, Integer, UTCTime)
+initializeRotator rotation fdesc = do
+    let maxAge   = toInteger $ rotation ^. rpMaxAgeHours
+        maxSize  = toInteger $ rotation ^. rpLogLimitBytes
+
+    latest <- latestLogFile fdesc
+    case latest of
+        Nothing -> -- no file to append, return new
+            evalRotator rotation fdesc
+        Just fname -> do
+            -- check date
+            now <- getCurrentTime
+            tsfp <- parseTimeM True defaultTimeLocale tsformat $ drop (fplen + 1) fname
+            if (round $ diffUTCTime now tsfp) > (3600 * maxAge)
+               then do  -- file is too old, return new
+                  evalRotator rotation fdesc
+               else do
+                  hdl <- catchIO (openFile (prefixpath fdesc </> fname) AppendMode) $
+                             \e -> do
+                                 prtoutException fname e
+                                 return stdout    -- fallback to standard output in case of exception
+                  hSetBuffering hdl LineBuffering
+                  cursize <- hFileSize hdl
+                  let rottime = addUTCTime (fromInteger $ maxAge * 3600) now
+                  return (hdl, (maxSize - cursize), rottime)
+  where
+    fplen = length $ filename fdesc
+
+-- | remove old files; count them and only keep n (from config)
+cleanupRotator :: RotationParameters -> FileDescription -> IO ()
+cleanupRotator rotation fdesc = do
+    let keepN0 = fromIntegral (rotation ^. rpKeepFilesNum) :: Int
+        keepN = max 1 $ min keepN0 99
+    listLogFiles fdesc >>= removeOldFiles keepN
+  where
+    removeOldFiles :: Int -> Maybe (NonEmpty FilePath) -> IO ()
+    removeOldFiles _ Nothing = return ()
+    removeOldFiles n (Just flist) = do
+        putStrLn $ "dropping " ++ (show n) ++ " from " ++ (show flist)
+        removeFiles $ reverse $ NE.drop n $ NE.reverse flist
+    removeFiles [] = return ()
+    removeFiles (fp : fps) = do
+        let bp = prefixpath fdesc
+            filepath = bp </> fp
+        putStrLn $ "removing file " ++ filepath
+        removeFile filepath   -- destructive
+        removeFiles fps
+
+{-
+
+  testing:
+
+  lc0 <- parseLoggerConfig "../log-configs/testing.yaml"
+  lc <- setLogPrefix (Just "/tmp/testlog/") lc0
+  lh <- setupLogging lc
+
+  usingLoggerName lh "testing" $ do { forM_ [1..299] (\n -> logDebug $ T.pack $ "hello world " ++ (show n)) }
+-}