\subsection{Cardano.BM.Rotator}
\label{code:Cardano.BM.Rotator}

Implementation of rotation of logging files.

Monitor log files for max age and max size. This test only works on POSIX platforms.

\begin{code}

{-# LANGUAGE CPP             #-}

#if !defined(mingw32_HOST_OS)
#define POSIX
#endif

module Cardano.BM.Rotator
       ( cleanupRotator
       , evalRotator
       , initializeRotator
       , latestLogFile
       , prtoutException
       , nameLogFile
       , tsformat
       , listLogFiles
       ) where

import           Control.Exception.Safe (Exception (..), catchIO)
#ifdef POSIX
import           Control.Monad (when)
#endif
import           Data.List (sort)
import qualified Data.List.NonEmpty as NE
import           Data.List.NonEmpty (NonEmpty)
import           Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime,
                     parseTimeM)
import           Data.Time.Format (defaultTimeLocale, formatTime)
#ifdef POSIX
import           System.Directory (doesFileExist)
#endif
import           System.Directory (listDirectory, removeFile)
import           System.FilePath ((</>), splitExtension, takeBaseName,
                     takeDirectory, takeExtension)
import           System.IO (BufferMode (LineBuffering), Handle,
                     IOMode (AppendMode, WriteMode), hFileSize, hSetBuffering,
                     openFile, stdout)

#ifdef POSIX
import           System.Directory (createFileLink)
import           System.FilePath (takeFileName)
#endif

import           Cardano.BM.Data.Rotation (RotationParameters (..))

\end{code}

\subsubsection{Format of a timestamp to be appended to the name of a file.}
\begin{code}
tsformat :: String
tsformat :: String
tsformat = String
"%Y%m%d%H%M%S"

\end{code}

\subsubsection{Add current time to name of log file.}\label{code:nameLogFile}\index{nameLogFile}
\begin{code}
nameLogFile :: FilePath -> IO FilePath
nameLogFile :: String -> IO String
nameLogFile String
filename = do
    let (String
fstem, String
fext) = String -> (String, String)
splitExtension String
filename
    UTCTime
now <- IO UTCTime
getCurrentTime
    let tsnow :: String
tsnow = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
tsformat UTCTime
now
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
fstem String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tsnow String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fext

\end{code}

\subsubsection{Open a new log file.}\label{code:evalRotator}\index{evalRotator}
\begin{code}
evalRotator :: RotationParameters -> FilePath -> IO (Handle, Integer, UTCTime)
evalRotator :: RotationParameters -> String -> IO (Handle, Integer, UTCTime)
evalRotator RotationParameters
rotation String
filename = do
    let maxAge :: Integer
maxAge  = Word -> Integer
forall a. Integral a => a -> Integer
toInteger (Word -> Integer) -> Word -> Integer
forall a b. (a -> b) -> a -> b
$ RotationParameters -> Word
rpMaxAgeHours   RotationParameters
rotation
        maxSize :: Integer
maxSize = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ RotationParameters -> Word64
rpLogLimitBytes RotationParameters
rotation

    -- open new log file
    String
fpath <- String -> IO String
nameLogFile String
filename
    Handle
hdl <- IO Handle -> (IOException -> IO Handle) -> IO Handle
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO (String -> IOMode -> IO Handle
openFile String
fpath IOMode
WriteMode) ((IOException -> IO Handle) -> IO Handle)
-> (IOException -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$
               \IOException
e -> do
                   String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException (String
"rot: error while opening log: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fpath) IOException
e
                   Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout    -- fallback to standard output in case of exception
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
hdl BufferMode
LineBuffering

#ifdef POSIX
    -- restrict symbolic links only for unix-like OS
    let symLinkPath :: String
symLinkPath = String
filename
    let logfilePath :: String
logfilePath = String -> String
takeFileName String
fpath
    -- delete a symlink if it already exists and create a new
    -- one that points to the correct file.
    Bool
symLinkExists <- String -> IO Bool
doesFileExist String
symLinkPath
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
symLinkExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      (String -> IO ()
removeFile String
symLinkPath)
        IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` (String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException (String
"cannot remove symlink: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symLinkPath))
    (String -> String -> IO ()
createFileLink String
logfilePath String
symLinkPath)
        IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` (String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException (String
"cannot create symlink: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symLinkPath))
#endif

    -- compute next rotation time
    UTCTime
now <- IO UTCTime
getCurrentTime
    let rottime :: UTCTime
rottime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime) -> Integer -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Integer
maxAge Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
3600) UTCTime
now

    (Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hdl, Integer
maxSize, UTCTime
rottime)

\end{code}

\subsubsection{List log files in dir which match with the given filename ignoring date.}\label{code:listLogFiles}\index{listLogFiles}
\begin{code}
listLogFiles :: FilePath -> IO (Maybe (NonEmpty FilePath))
listLogFiles :: String -> IO (Maybe (NonEmpty String))
listLogFiles String
file = do
    -- find files in the same directory which begin with
    -- the same name
    let directoryPath :: String
directoryPath = String -> String
takeDirectory String
file

    [String]
files <- String -> IO [String]
listDirectory String
directoryPath
    Maybe (NonEmpty String) -> IO (Maybe (NonEmpty String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (NonEmpty String) -> IO (Maybe (NonEmpty String)))
-> Maybe (NonEmpty String) -> IO (Maybe (NonEmpty String))
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([String] -> Maybe (NonEmpty String))
-> [String] -> Maybe (NonEmpty String)
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
directoryPath String -> String -> String
</> ) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
fpredicate [String]
files
  where
    tslen :: Int
tslen = Int
14  -- length of a timestamp
    filename :: String
filename = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
takeBaseName String
file  -- only stem of filename
    fext :: String
fext = String -> String
takeExtension String
file  -- only file extension
    fplen :: Int
fplen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
filename
    fxlen :: Int
fxlen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fext
    fpredicate :: String -> Bool
fpredicate String
path = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
fplen String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
filename
                      Bool -> Bool -> Bool
&& Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
fplen String
path) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"
                      Bool -> Bool -> Bool
&& Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
fxlen (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (Int
fplen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tslen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
path) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fext

\end{code}

\subsubsection{Latest log file which matches filename.}\label{code:latestLogFile}\index{latestLogFile}
\begin{code}
latestLogFile :: FilePath -> IO (Maybe FilePath)
latestLogFile :: String -> IO (Maybe String)
latestLogFile String
filename =
    String -> IO (Maybe (NonEmpty String))
listLogFiles String
filename IO (Maybe (NonEmpty String))
-> (Maybe (NonEmpty String) -> IO (Maybe String))
-> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe (NonEmpty String)
fs -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe (NonEmpty String) -> Maybe String
latestLogFile' Maybe (NonEmpty String)
fs
  where
    latestLogFile' :: Maybe (NonEmpty FilePath) -> Maybe FilePath
    latestLogFile' :: Maybe (NonEmpty String) -> Maybe String
latestLogFile' Maybe (NonEmpty String)
Nothing      = Maybe String
forall a. Maybe a
Nothing
    latestLogFile' (Just NonEmpty String
flist) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> String
forall a. NonEmpty a -> a
NE.last NonEmpty String
flist

\end{code}

\subsubsection{Initialize log file at startup; may append to existing file.}\label{code:initializeRotator}\index{initializeRotator}
\begin{code}
initializeRotator :: RotationParameters -> FilePath -> IO (Handle, Integer, UTCTime)
initializeRotator :: RotationParameters -> String -> IO (Handle, Integer, UTCTime)
initializeRotator RotationParameters
rotation String
filename = do
    let maxAge :: Integer
maxAge  = Word -> Integer
forall a. Integral a => a -> Integer
toInteger (Word -> Integer) -> Word -> Integer
forall a b. (a -> b) -> a -> b
$ RotationParameters -> Word
rpMaxAgeHours   RotationParameters
rotation
        maxSize :: Integer
maxSize = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ RotationParameters -> Word64
rpLogLimitBytes RotationParameters
rotation

    Maybe String
latest <- String -> IO (Maybe String)
latestLogFile String
filename
    case Maybe String
latest of
        Maybe String
Nothing -> -- no file to append, return new
            RotationParameters -> String -> IO (Handle, Integer, UTCTime)
evalRotator RotationParameters
rotation String
filename
        Just String
fname -> do
            -- check date
            UTCTime
now <- IO UTCTime
getCurrentTime
            UTCTime
tsfp <- Bool -> TimeLocale -> String -> String -> IO UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
tsformat (String -> String
timestamp String
fname)
            let age :: Integer
age = NominalDiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Integer) -> NominalDiffTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
tsfp
            if Integer
age Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> (Integer
3600 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
maxAge)
               then do  -- file is too old, return new
                  RotationParameters -> String -> IO (Handle, Integer, UTCTime)
evalRotator RotationParameters
rotation String
filename
               else do
                  Handle
hdl <- IO Handle -> (IOException -> IO Handle) -> IO Handle
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO (String -> IOMode -> IO Handle
openFile String
fname IOMode
AppendMode) ((IOException -> IO Handle) -> IO Handle)
-> (IOException -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$
                             \IOException
e -> do
                                 String -> IOException -> IO ()
forall e. Exception e => String -> e -> IO ()
prtoutException String
fname IOException
e
                                 Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout    -- fallback to standard output in case of exception
                  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hdl BufferMode
LineBuffering
                  Integer
cursize <- Handle -> IO Integer
hFileSize Handle
hdl
                  let rotationTime :: UTCTime
rotationTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime) -> Integer -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Integer
maxAge Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
3600) UTCTime
tsfp
                  (Handle, Integer, UTCTime) -> IO (Handle, Integer, UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hdl, (Integer
maxSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
cursize), UTCTime
rotationTime)
  where
    tslen :: Int
tslen = Int
14  -- length of timestamp
    timestamp :: String -> String
timestamp String
fname = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
tslen (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
takeBaseName String
fname

\end{code}

\subsubsection{Remove old files; count them and only keep n (from config).}\label{code:cleanupRotator}\index{cleanupRotator}
\begin{code}
cleanupRotator :: RotationParameters -> FilePath -> IO ()
cleanupRotator :: RotationParameters -> String -> IO ()
cleanupRotator RotationParameters
rotation String
filename = do
    let keepN0 :: Int
keepN0 = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RotationParameters -> Word
rpKeepFilesNum RotationParameters
rotation) :: Int
        keepN :: Int
keepN = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
keepN0 Int
99
    String -> IO (Maybe (NonEmpty String))
listLogFiles String
filename IO (Maybe (NonEmpty String))
-> (Maybe (NonEmpty String) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe (NonEmpty String) -> IO ()
removeOldFiles Int
keepN
  where
    removeOldFiles :: Int -> Maybe (NonEmpty FilePath) -> IO ()
    removeOldFiles :: Int -> Maybe (NonEmpty String) -> IO ()
removeOldFiles Int
_ Maybe (NonEmpty String)
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    removeOldFiles Int
n (Just NonEmpty String
flist) =
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
removeFile ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> NonEmpty String -> [String]
forall a. Int -> NonEmpty a -> [a]
NE.drop Int
n (NonEmpty String -> [String]) -> NonEmpty String -> [String]
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> NonEmpty String
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty String
flist

\end{code}

\subsubsection{Display message and stack trace of exception on stdout.}\label{code:prtoutException}\index{prtoutException}
\begin{code}
prtoutException :: Exception e => String -> e -> IO ()
prtoutException :: String -> e -> IO ()
prtoutException String
msg e
e = do
    String -> IO ()
putStrLn String
msg
    String -> IO ()
putStrLn (String
"exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall e. Exception e => e -> String
displayException e
e)

\end{code}