\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
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
Handle -> BufferMode -> IO ()
hSetBuffering Handle
hdl BufferMode
LineBuffering
#ifdef POSIX
let symLinkPath :: String
symLinkPath = String
filename
let logfilePath :: String
logfilePath = String -> String
takeFileName String
fpath
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
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
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
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
fext :: String
fext = String -> String
takeExtension String
file
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 ->
RotationParameters -> String -> IO (Handle, Integer, UTCTime)
evalRotator RotationParameters
rotation String
filename
Just String
fname -> do
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
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
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
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}