{-# LANGUAGE OverloadedStrings #-}
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)
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 ()
_ -> () -> 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)