TimeRotatingFileHandler.hs

{-# 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

{-| A handler type which logs to a file and rotates the log at cerntain timed
intervals.

@since 0.7.0
-}
data TimeRotatingFileHandler  = TimeRotatingFileHandler
                                  { level       :: Level
                                  , filterer    :: Filterer
                                  , formatter   :: Format1
                                  , file        :: FilePath
                                  , encoding    :: TextEncoding
                                  , timezone    :: TimeZone
                                    -- ^ In most cases, it is the same value as
                                    -- 'Manager''s timezone, but it won't cause
                                    -- problems if you set a different value.
                                  , 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

-- | A datatype indicates a day of Monday-starting week.
--
data DayOfWeek = Monday
               | Tuesday
               | Wednesday
               | Thursday
               | Friday
               | Saturday
               | Sunday
               deriving Eq

-- | Monday-starting week means Monday is 1 and Sunday is 7
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


{-| A datatype indicates when to rotate file.

Note: This handler use @1970-01-01 00:00:00@ of the given timezone as the zero
time, all caculations of 'RotateTime' are based on this zero time.
Let's consider @Hour 5@ for example, if now is @2020-01-01 03:10:00@,
since there are 87658 @5 hours@ between now and zero time, the next rotating
time will be @2020-01-01 07:00:00@.
-}
data RotateTime = Minute Int        -- ^ Every n minute(s)
                | Hour Int          -- ^ Every n hour(s)
                | WeekDay DayOfWeek -- ^ At zero clock of a weekday
                | Day Int           -- ^ Every n day(s)
               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