module System.Wlog.Roller
( InvalidRotation (..)
, RollerHandler (..)
, logIndex
, rotationFileHandler
) where
import Universum
import Control.Concurrent (MVar, modifyMVar_, newMVar)
import Formatting (sformat, shown, (%))
import qualified Prelude (show)
import System.Directory (removeFile, renameFile)
import System.FilePath ((<.>))
import System.IO (Handle, IOMode (AppendMode), hClose,
hFileSize)
import System.Log (Priority)
import System.Log.Formatter (LogFormatter, nullFormatter)
import System.Log.Handler (LogHandler (..))
import System.Log.Handler.Simple (GenericHandler (..), fileHandler)
import System.Wlog.FileUtils (whenExist)
import System.Wlog.LoggerConfig (RotationParameters (..), isValidRotation)
data RollerHandler = RollerHandler
{ rhPriority :: Priority
, rhFormatter :: LogFormatter RollerHandler
, rhFileHandle :: MVar Handle
, rhWriteAction :: Handle -> String -> IO ()
, rhCloseAction :: Handle -> IO ()
}
instance LogHandler RollerHandler where
setLevel rh p = rh { rhPriority = p }
setFormatter rh f = rh { rhFormatter = f }
getLevel = rhPriority
getFormatter = rhFormatter
emit rh (_, msg) _ = rhWriteAction rh (panic "Handler is used internally") msg
close RollerHandler{..} = withMVar rhFileHandle rhCloseAction
data InvalidRotation = InvalidRotation !Text
deriving (Show, Eq)
instance Exception InvalidRotation
logIndex :: FilePath -> Int -> FilePath
logIndex handlerPath i = handlerPath <.> Prelude.show i
rotationFileHandler
:: MonadIO m
=> RotationParameters
-> FilePath
-> Priority
-> m RollerHandler
rotationFileHandler rp@RotationParameters{..} _ _
| not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $
sformat ("Rotation parameters must be positive: "%shown) rp
rotationFileHandler RotationParameters{..} handlerPath rhPriority = liftIO $ do
GenericHandler{..} <- fileHandler handlerPath rhPriority
rhFileHandle <- newMVar privData
let rhWriteAction = rollerWriting writeFunc rhFileHandle
return RollerHandler{ rhFormatter = nullFormatter
, rhCloseAction = closeFunc
, ..
}
where
rollerWriting
:: (Handle -> String -> IO ())
-> MVar Handle
-> Handle
-> String
-> IO ()
rollerWriting loggingAction varHandle _ msg = modifyMVar_ varHandle $ \landle -> do
loggingAction landle msg
logFileSize <- fromIntegral <$> hFileSize landle
if logFileSize < rpLogLimit then
return landle
else do
hClose landle
let lastIndex = fromIntegral $ rpKeepFiles 1
for_ [lastIndex 1, lastIndex 2 .. 0] $ \i -> do
let oldLogFile = logIndex handlerPath i
let newLogFile = logIndex handlerPath (i + 1)
whenExist oldLogFile $ (`renameFile` newLogFile)
let zeroIndex = logIndex handlerPath 0
renameFile handlerPath zeroIndex
let lastLogFile = logIndex handlerPath lastIndex
whenExist lastLogFile removeFile
openFile handlerPath AppendMode