{-# 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(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 Maybe FilePath
mLogDir ByteString
channel 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 UTCTime
now =
          case Maybe FilePath
mLogDir of
            Maybe FilePath
Nothing -> Maybe Fd -> IO (Maybe Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fd
forall a. Maybe a
Nothing
            (Just 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
== Char
'#') (ByteString -> FilePath
unpack ByteString
channel)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-%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 FileMode
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 UTCTime
_now Day
logDay Maybe Fd
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 UTCTime
now Day
logDay (Just 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 Day
logDay 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
           (Day
logDay', 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 ByteString
nick Maybe ByteString
_user Maybe ByteString
_server)) [ByteString]
receivers 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 FilePath
"%X " UTCTime
now)
                                       , ByteString
"<" , ByteString
nick , ByteString
"> "
                                       , ByteString
msg'
                                       , ByteString
"\n"
                                       ]
                      case Maybe Fd
mLogFd' of
                        Maybe Fd
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        (Just 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
             Maybe PrivMsg
_ -> () -> 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 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
$ \(Ptr CChar
cstring, Int
len) ->
        if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
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 FilePath
"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 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c :: Int) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> Int
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)