{-# LANGUAGE CPP #-}
{-# 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(..), 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)
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
(Just FilePath
logDir) ->
do let logPath :: FilePath
logPath = FilePath
logDir FilePath -> FilePath -> FilePath
</> (forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale ((forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'#') (ByteString -> FilePath
unpack ByteString
channel)) forall a. [a] -> [a] -> [a]
++ FilePath
"-%Y-%m-%d.txt") UTCTime
now)
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
logDir
#if MIN_VERSION_unix(2,8,0)
fd <- openFd (pack logPath) WriteOnly (defaultFileFlags { append = True, creat = Just 0o0644 })
#else
Fd
fd <- ByteString -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd (FilePath -> ByteString
pack FilePath
logPath) OpenMode
WriteOnly (forall a. a -> Maybe a
Just FileMode
0o0644) (OpenFileFlags
defaultFileFlags { append :: Bool
append = Bool
True })
#endif
forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall (m :: * -> *) a. Monad m => a -> m a
return (Day
logDay, forall a. Maybe a
Nothing)
updateLogHandle UTCTime
now Day
logDay (Just Fd
logFd)
| Day
logDay forall a. Eq a => a -> a -> Bool
== (UTCTime -> Day
utctDay UTCTime
now) = forall (m :: * -> *) a. Monad m => a -> m a
return (Day
logDay, 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
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 <- 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 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 (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just Fd
logFd') -> Fd -> ByteString -> IO ()
fdWrites Fd
logFd' ByteString
logMsg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe PrivMsg
_ -> 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 =
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.useAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstring, Int
len) ->
if Int
len forall a. Ord a => a -> a -> Bool
<= Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do ByteCount
c <- forall a. (Eq a, Num a) => FilePath -> IO a -> IO a
C.throwErrnoIfMinus1Retry FilePath
"fdWrites" forall a b. (a -> b) -> a -> b
$ Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cstring) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
if (forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c :: Int) forall a. Eq a => a -> a -> Bool
== (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Fd -> ByteString -> IO ()
fdWrites Fd
fd (Int -> ByteString -> ByteString
B.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c) ByteString
bs)