{-# 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(..), addUTCTime, getCurrentTime)
import Data.Time.Format   (defaultTimeLocale, formatTime)
import qualified Foreign.C.Error as C
import Foreign.Ptr        (castPtr)
import Network.IRC        (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user)
import Network.IRC.Bot.Commands
import System.Directory   (createDirectoryIfMissing)
import System.FilePath    ((</>))
import System.Posix.ByteString ( Fd, OpenMode(WriteOnly), OpenFileFlags(append), 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 :: Maybe FilePath -> ByteString -> Chan Message -> IO ()
posixLogger mLogDir :: Maybe FilePath
mLogDir channel :: ByteString
channel logChan :: Chan Message
logChan =
  do UTCTime
now <- IO UTCTime
getCurrentTime
     let logDay :: Day
logDay = UTCTime -> Day
utctDay UTCTime
now
     Maybe Fd
logFd <- UTCTime -> IO (Maybe Fd)
openLog UTCTime
now
     Day -> Maybe Fd -> IO ()
logLoop Day
logDay Maybe Fd
logFd
    where
      openLog :: UTCTime -> IO (Maybe Fd)
      openLog :: UTCTime -> IO (Maybe Fd)
openLog now :: UTCTime
now =
          case Maybe FilePath
mLogDir of
            Nothing -> Maybe Fd -> IO (Maybe Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fd
forall a. Maybe a
Nothing
            (Just logDir :: FilePath
logDir) ->
                do let logPath :: FilePath
logPath = FilePath
logDir FilePath -> FilePath -> FilePath
</> (TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale (((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#') (ByteString -> FilePath
unpack ByteString
channel)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "-%Y-%m-%d.txt") UTCTime
now)
                   Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
logDir
                   Fd
fd <- ByteString -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd (FilePath -> ByteString
pack FilePath
logPath) OpenMode
WriteOnly (FileMode -> Maybe FileMode
forall a. a -> Maybe a
Just 0o0644) (OpenFileFlags
defaultFileFlags { append :: Bool
append = Bool
True })
                   Maybe Fd -> IO (Maybe Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
fd)
      updateLogHandle :: UTCTime -> Day -> Maybe Fd -> IO (Day, Maybe Fd)
      updateLogHandle :: UTCTime -> Day -> Maybe Fd -> IO (Day, Maybe Fd)
updateLogHandle now :: UTCTime
now logDay :: Day
logDay Nothing = (Day, Maybe Fd) -> IO (Day, Maybe Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return (Day
logDay, Maybe Fd
forall a. Maybe a
Nothing)
      updateLogHandle now :: UTCTime
now logDay :: Day
logDay (Just logFd :: Fd
logFd)
        | Day
logDay Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== (UTCTime -> Day
utctDay UTCTime
now) = (Day, Maybe Fd) -> IO (Day, Maybe Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return (Day
logDay, Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
logFd)
        | Bool
otherwise = do Fd -> IO ()
closeFd Fd
logFd
                         Maybe Fd
nowHandle <- UTCTime -> IO (Maybe Fd)
openLog UTCTime
now
                         (Day, Maybe Fd) -> IO (Day, Maybe Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Day
utctDay UTCTime
now, Maybe Fd
nowHandle)

      logLoop :: Day -> Maybe Fd -> IO ()
      logLoop :: Day -> Maybe Fd -> IO ()
logLoop logDay :: Day
logDay mLogFd :: Maybe Fd
mLogFd =
        do Message
msg <- Chan Message -> IO Message
forall a. Chan a -> IO a
readChan Chan Message
logChan
           UTCTime
now <- IO UTCTime
getCurrentTime
           (logDay' :: Day
logDay', mLogFd' :: Maybe Fd
mLogFd') <- UTCTime -> Day -> Maybe Fd -> IO (Day, Maybe Fd)
updateLogHandle UTCTime
now Day
logDay Maybe Fd
mLogFd
           let mPrivMsg :: Maybe PrivMsg
mPrivMsg = Message -> Maybe PrivMsg
toPrivMsg Message
msg
           case Maybe PrivMsg
mPrivMsg of
             (Just (PrivMsg (Just (NickName nick :: ByteString
nick _user :: Maybe ByteString
_user _server :: Maybe ByteString
_server)) receivers :: [ByteString]
receivers msg :: ByteString
msg)) | ByteString
channel ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
receivers ->
                   do let logMsg :: ByteString
logMsg =
                              [ByteString] -> ByteString
B.concat [ FilePath -> ByteString
pack (TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale "%X " UTCTime
now)
                                       , "<" , ByteString
nick , "> "
                                       , ByteString
msg
                                       , "\n"
                                       ]
                      case Maybe Fd
mLogFd' of
                        Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        (Just logFd' :: Fd
logFd') -> Fd -> ByteString -> IO ()
fdWrites Fd
logFd' ByteString
logMsg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      -- hPutStrLn logFd logMsg
             _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Day -> Maybe Fd -> IO ()
logLoop Day
logDay' Maybe Fd
mLogFd'

fdWrites :: Fd
         -> ByteString
         -> IO ()
fdWrites :: Fd -> ByteString -> IO ()
fdWrites fd :: Fd
fd bs :: ByteString
bs =
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.useAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(cstring :: Ptr CChar
cstring, len :: Int
len) ->
        if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
           then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           else do ByteCount
c <- FilePath -> IO ByteCount -> IO ByteCount
forall a. (Eq a, Num a) => FilePath -> IO a -> IO a
C.throwErrnoIfMinus1Retry "fdWrites" (IO ByteCount -> IO ByteCount) -> IO ByteCount -> IO ByteCount
forall a b. (a -> b) -> a -> b
$ Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cstring) (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                   if (ByteCount -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                      then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      else Fd -> ByteString -> IO ()
fdWrites Fd
fd (Int -> ByteString -> ByteString
B.drop (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c) ByteString
bs)