PosixLogger.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-

Use the 'unix' library to write the log file. Why not 'Handles' you
ask? I believe it is because 'Handles' lock the file, and we want to
be able to serve the file while it is still being written.

-}
module Network.IRC.Bot.PosixLogger where

import Control.Concurrent.Chan
import Data.ByteString    (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (pack, unpack)
import Data.Time.Calendar    (Day(..))
import Data.Time.Clock    (UTCTime(..), getCurrentTime)
import Data.Time.Format   (defaultTimeLocale, formatTime)
import qualified Foreign.C.Error as C
import Foreign.Ptr        (castPtr)
import Network.IRC        (Message, Prefix(NickName))
import Network.IRC.Bot.Commands (PrivMsg(PrivMsg), toPrivMsg)
import System.Directory   (createDirectoryIfMissing)
import System.FilePath    ((</>))
import System.Posix.ByteString ( Fd, OpenMode(WriteOnly), OpenFileFlags(..), closeFd, defaultFileFlags
                               , openFd
                               )
import System.Posix.IO.ByteString (fdWriteBuf)

-- TODO: This should be modified so that a formatting filter can be applied to the log messages
-- TODO: should be updated so that log file name matches channel
-- TODO: should support multiple channels
posixLogger :: Maybe FilePath -> ByteString -> Chan Message -> IO ()
posixLogger mLogDir channel logChan =
  do now <- getCurrentTime
     let logDay = utctDay now
     logFd <- openLog now
     logLoop logDay logFd
    where
      openLog :: UTCTime -> IO (Maybe Fd)
      openLog now =
          case mLogDir of
            Nothing -> return Nothing
            (Just logDir) ->
                do let logPath = logDir </> (formatTime defaultTimeLocale ((dropWhile (== '#') (unpack channel)) ++ "-%Y-%m-%d.txt") now)
                   createDirectoryIfMissing True logDir
#if MIN_VERSION_unix(2,8,0)
                   fd <- openFd (pack logPath) WriteOnly (defaultFileFlags { append = True, creat = Just 0o0644 })
#else
                   fd <- openFd (pack logPath) WriteOnly (Just 0o0644) (defaultFileFlags { append = True })
#endif
                   return (Just fd)
      updateLogHandle :: UTCTime -> Day -> Maybe Fd -> IO (Day, Maybe Fd)
      updateLogHandle _now logDay Nothing = return (logDay, Nothing)
      updateLogHandle now logDay (Just logFd)
        | logDay == (utctDay now) = return (logDay, Just logFd)
        | otherwise = do closeFd logFd
                         nowHandle <- openLog now
                         return (utctDay now, nowHandle)

      logLoop :: Day -> Maybe Fd -> IO ()
      logLoop logDay mLogFd =
        do msg <- readChan logChan
           now <- getCurrentTime
           (logDay', mLogFd') <- updateLogHandle now logDay mLogFd
           let mPrivMsg = toPrivMsg msg
           case mPrivMsg of
             (Just (PrivMsg (Just (NickName nick _user _server)) receivers msg')) | channel `elem` receivers ->
                   do let logMsg =
                              B.concat [ pack (formatTime defaultTimeLocale "%X " now)
                                       , "<" , nick , "> "
                                       , msg'
                                       , "\n"
                                       ]
                      case mLogFd' of
                        Nothing -> return ()
                        (Just logFd') -> fdWrites logFd' logMsg >> return ()
                      return ()
                      -- hPutStrLn logFd logMsg
             _ -> return ()
           logLoop logDay' mLogFd'

fdWrites :: Fd
         -> ByteString
         -> IO ()
fdWrites fd bs =
    B.useAsCStringLen bs $ \(cstring, len) ->
        if len <= 0
           then return ()
           else do c <- C.throwErrnoIfMinus1Retry "fdWrites" $ fdWriteBuf fd (castPtr cstring) (fromIntegral len)
                   if (fromIntegral c :: Int) == (fromIntegral len)
                      then return ()
                      else fdWrites fd (B.drop (fromIntegral c) bs)