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 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
fd <- openFd (pack logPath) WriteOnly (Just 0o0644) (defaultFileFlags { append = True })
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 ()
_ -> 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) == (fromIntegral len)
then return ()
else fdWrites fd (B.drop (fromIntegral c) bs)