{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Logging.Handler.TimeRotatingFileHandler
( TimeRotatingFileHandler(..)
, DayOfWeek(..)
, RotateTime(..)
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Aeson
import Data.Char
import Data.IORef
import Data.List
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import GHC.Generics
import System.Directory
import System.FilePath
import System.IO
import Text.Format
import Logging.Class hiding (filter)
import Logging.Filter
import Logging.Level
import Logging.Prelude
import Logging.Record
data TimeRotatingFileHandler = TimeRotatingFileHandler
{ level :: Level
, filterer :: Filterer
, formatter :: Format1
, file :: FilePath
, encoding :: TextEncoding
, timezone :: TimeZone
, rotateTime :: RotateTime
, backupCount :: Int
, rotateAt :: IORef UTCTime
, stream :: MVar Handle
} deriving (Generic, Eq)
instance Handler TimeRotatingFileHandler where
open TimeRotatingFileHandler{..} = do
now <- (utcToZonedTime timezone) <$> (lastModifyTime file)
atomicWriteIORef rotateAt $ nextRotateAt rotateTime now
isEmptyMVar stream >>= safeOpen
where
safeOpen True = void $ tryPutMVar stream =<< openLogFile file encoding
safeOpen False = modifyMVar_ stream $ \h -> do
hClose h
openLogFile file encoding
emit TimeRotatingFileHandler{..} rcd = do
let msg = format1 formatter rcd
modifyMVar_ stream $ \stream' -> do
at <- readIORef rotateAt
h <- rollover (backupCount > 0) (utctime rcd >= at) at stream'
hPutStrLn h msg
hFlush h
return h
where
rollover :: Bool -> Bool -> UTCTime -> Handle -> IO Handle
rollover True True at h = do
hClose h
files <- listDirectory $ takeDirectory file
removeExpired $ sort $ filter (matchSuffix rotateTime file) files
tryRenameFile file $ appendBaseName file $ format (suffix rotateTime) $
utcToZonedTime timezone $ prevRotateAt rotateTime at
now <- utcToZonedTime timezone <$> getCurrentTime
writeIORef rotateAt $ nextRotateAt rotateTime now
openLogFile file encoding
rollover _ _ _ h = return h
removeExpired :: [FilePath] -> IO ()
removeExpired fs = forM_ (drop (backupCount - 1) (reverse fs)) $ \fn ->
removeFile $ replaceFileName file fn
close TimeRotatingFileHandler{..} = withMVar stream hClose
data DayOfWeek = Monday
| Tuesday
| Wednesday
| Thursday
| Friday
| Saturday
| Sunday
deriving Eq
instance Enum DayOfWeek where
toEnum 1 = Monday
toEnum 2 = Tuesday
toEnum 3 = Wednesday
toEnum 4 = Thursday
toEnum 5 = Friday
toEnum 6 = Saturday
toEnum 7 = Sunday
fromEnum Monday = 1
fromEnum Tuesday = 2
fromEnum Wednesday = 3
fromEnum Thursday = 4
fromEnum Friday = 5
fromEnum Saturday = 6
fromEnum Sunday = 7
data RotateTime = Minute Int
| Hour Int
| WeekDay DayOfWeek
| Day Int
deriving Eq
instance Read RotateTime where
readsPrec _ ('M' : cs) = [(Minute $ read cs, "")]
readsPrec _ ('H' : cs) = [(Hour $ read cs, "")]
readsPrec _ ('D' : cs) = [(Day $ read cs, "")]
readsPrec _ ('W' : cs) = [(WeekDay $ toEnum $ read cs, "")]
readsPrec _ _ = []
instance Show RotateTime where
show (Minute n) = 'M' : (show n)
show (Hour n) = 'H' : (show n)
show (WeekDay n) = 'W' : (show $ fromEnum n)
show (Day n) = 'D' : (show n)
instance FromJSON RotateTime where
parseJSON = (fmap read) . parseJSON
interval :: RotateTime -> NominalDiffTime
interval (Minute n) = 60 * fromInteger (toInteger n)
interval (Hour n) = 60 * 60 * fromInteger (toInteger n)
interval (WeekDay _) = 60 * 60 * 24 * 7
interval (Day n) = 60 * 60 * 24 * fromInteger (toInteger n)
nextRotateAt :: RotateTime -> ZonedTime -> UTCTime
nextRotateAt rt now = posixSecondsToUTCTime $ fixDay rt $ quot * unit
where
unit = interval rt
total = zonedTimeToPOSIXSeconds now
quot = fromInteger $ 1 + (truncate $ total / unit)
diff = 60 * (fromInteger $ toInteger $ timeZoneMinutes $ zonedTimeZone now)
fixDay :: RotateTime -> NominalDiffTime -> NominalDiffTime
fixDay (WeekDay d) = (+) (interval (Day ((3 + fromEnum d) `mod` 7)) - diff)
fixDay (Day _) = subtract diff
fixDay _ = id
prevRotateAt :: RotateTime -> UTCTime -> UTCTime
prevRotateAt = addUTCTime . negate . interval
suffix :: RotateTime -> Format
suffix (Minute _) = ".{:%Y-%m-%d_%H-%M}"
suffix (Hour _) = ".{:%Y-%m-%d_%H}"
suffix _ = ".{:%Y-%m-%d}"
matchSuffix :: RotateTime -> FilePath -> FilePath -> Bool
matchSuffix rt base src
| Just cs <- stripPrefix (takeBaseName base) (takeBaseName src) =
matchDay (take 11 cs) && matchTime rt (drop 11 cs)
| otherwise = False
where
matchD2 :: Int -> String -> Bool
matchD2 0 "" = True
matchD2 1 (x:y:"") = isDigit x && isDigit y
matchD2 n (x:y:'-':cs) = isDigit x && isDigit y && matchD2 (n - 1) cs
matchD2 _ _ = False
matchDay :: String -> Bool
matchDay ('.':x:y:cs) = isDigit x && isDigit y && matchD2 3 cs
matchDay _ = False
matchTime :: RotateTime -> String -> Bool
matchTime (Minute _) ('_':cs) = matchD2 2 cs
matchTime (Hour _) ('_':cs) = matchD2 1 cs
matchTime _ cs = matchD2 0 cs