-- Copyright (c) 2004 Thomas Jaeger
-- Copyright (c) 2005 Simon Winwood
-- Copyright (c) 2005 Don Stewart
-- Copyright (c) 2005 David House <dmouse@gmail.com>
--
-- | Logging an IRC channel..
--
module Lambdabot.Plugin.IRC.Log (logPlugin) where

import Lambdabot.Compat.FreenodeNick
import Lambdabot.IRC
import Lambdabot.Monad
import qualified Lambdabot.Message as Msg
import Lambdabot.Nick
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Monad
import qualified Data.Map as M
import Data.Time
import System.Directory (createDirectoryIfMissing)
import System.FilePath
import System.IO

-- ------------------------------------------------------------------------

type Channel = Nick

type DateStamp = (Int, Int, Integer)
data ChanState = CS { ChanState -> Handle
chanHandle  :: Handle,
                      ChanState -> DateStamp
chanDate    :: DateStamp }
               deriving (Int -> ChanState -> ShowS
[ChanState] -> ShowS
ChanState -> String
(Int -> ChanState -> ShowS)
-> (ChanState -> String)
-> ([ChanState] -> ShowS)
-> Show ChanState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChanState] -> ShowS
$cshowList :: [ChanState] -> ShowS
show :: ChanState -> String
$cshow :: ChanState -> String
showsPrec :: Int -> ChanState -> ShowS
$cshowsPrec :: Int -> ChanState -> ShowS
Show, ChanState -> ChanState -> Bool
(ChanState -> ChanState -> Bool)
-> (ChanState -> ChanState -> Bool) -> Eq ChanState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChanState -> ChanState -> Bool
$c/= :: ChanState -> ChanState -> Bool
== :: ChanState -> ChanState -> Bool
$c== :: ChanState -> ChanState -> Bool
Eq)
type LogState = M.Map Channel ChanState
type Log = ModuleT LogState LB

data Event =
    Said Nick UTCTime String
    | Joined Nick String UTCTime
    | Parted Nick String UTCTime -- covers quitting as well
    | Kicked Nick Nick String UTCTime String
    | Renick Nick String UTCTime Nick
    | Mode Nick String UTCTime String
    deriving (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq)

instance Show Event where
    show :: Event -> String
show (Said Channel
nick UTCTime
ct String
what)      = UTCTime -> String
timeStamp UTCTime
ct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Channel -> String
nName Channel
nick String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what
    show (Joined Channel
nick String
usr UTCTime
ct)     = UTCTime -> String
timeStamp UTCTime
ct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
nick)
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") joined."
    show (Parted Channel
nick String
usr UTCTime
ct)     = UTCTime -> String
timeStamp UTCTime
ct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
nick)
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") left."
    show (Kicked Channel
nick Channel
op String
usrop UTCTime
ct String
reason) = UTCTime -> String
timeStamp UTCTime
ct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
nick)
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" was kicked by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
op)
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usrop String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
    show (Renick Channel
nick String
usr UTCTime
ct Channel
new) = UTCTime -> String
timeStamp UTCTime
ct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
nick)
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") is now " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
new) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
    show (Mode Channel
nick String
usr UTCTime
ct String
mode)  = UTCTime -> String
timeStamp UTCTime
ct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FreenodeNick -> String
forall a. Show a => a -> String
show (Channel -> FreenodeNick
FreenodeNick Channel
nick)
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") changed mode to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mode String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."

-- * Dispatchers and Module instance declaration
--
logPlugin :: Module (M.Map Channel ChanState)
logPlugin :: Module LogState
logPlugin = Module LogState
forall st. Module st
newModule
    { moduleDefState :: LB LogState
moduleDefState  = LogState -> LB LogState
forall (m :: * -> *) a. Monad m => a -> m a
return LogState
forall k a. Map k a
M.empty
    , moduleExit :: ModuleT LogState LB ()
moduleExit      = ModuleT LogState LB ()
cleanLogState
    , moduleInit :: ModuleT LogState LB ()
moduleInit      = do
        let doLog :: (t -> a -> b) -> t -> Handle -> a -> ModuleT LogState LB ()
doLog t -> a -> b
f t
m Handle
hdl = Handle -> String -> ModuleT LogState LB ()
logString Handle
hdl (String -> ModuleT LogState LB ())
-> (a -> String) -> a -> ModuleT LogState LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall a. Show a => a -> String
show (b -> String) -> (a -> b) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> a -> b
f t
m
            connect :: String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
signal IrcMessage -> UTCTime -> b
cb = String -> Callback LogState -> ModuleT LogState LB ()
forall st. String -> Callback st -> ModuleT st LB ()
registerCallback String
signal (Callback LogState -> ModuleT LogState LB ())
-> Callback LogState -> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ \IrcMessage
msg -> do
                UTCTime
now <- IO UTCTime -> ModuleT LogState LB UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO UTCTime
getCurrentTime
                -- map over the channels this message was directed to, adding to each
                -- of their log files.
                (Channel -> ModuleT LogState LB ())
-> [Channel] -> ModuleT LogState LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Handle -> UTCTime -> ModuleT LogState LB ())
-> UTCTime -> Channel -> ModuleT LogState LB ()
forall a.
(Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a
withValidLog ((IrcMessage -> UTCTime -> b)
-> IrcMessage -> Handle -> UTCTime -> ModuleT LogState LB ()
forall {b} {t} {a}.
Show b =>
(t -> a -> b) -> t -> Handle -> a -> ModuleT LogState LB ()
doLog IrcMessage -> UTCTime -> b
cb IrcMessage
msg) UTCTime
now) (IrcMessage -> [Channel]
forall a. Message a => a -> [Channel]
Msg.channels IrcMessage
msg)

        String
-> (IrcMessage -> UTCTime -> Event) -> ModuleT LogState LB ()
forall {b}.
Show b =>
String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
"PRIVMSG" IrcMessage -> UTCTime -> Event
msgCB
        String
-> (IrcMessage -> UTCTime -> Event) -> ModuleT LogState LB ()
forall {b}.
Show b =>
String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
"JOIN"    IrcMessage -> UTCTime -> Event
joinCB
        String
-> (IrcMessage -> UTCTime -> Event) -> ModuleT LogState LB ()
forall {b}.
Show b =>
String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
"PART"    IrcMessage -> UTCTime -> Event
partCB
        String
-> (IrcMessage -> UTCTime -> Event) -> ModuleT LogState LB ()
forall {b}.
Show b =>
String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
"KICK"    IrcMessage -> UTCTime -> Event
kickCB
        String
-> (IrcMessage -> UTCTime -> Event) -> ModuleT LogState LB ()
forall {b}.
Show b =>
String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
"NICK"    IrcMessage -> UTCTime -> Event
nickCB
        String
-> (IrcMessage -> UTCTime -> Event) -> ModuleT LogState LB ()
forall {b}.
Show b =>
String -> (IrcMessage -> UTCTime -> b) -> ModuleT LogState LB ()
connect String
"MODE"    IrcMessage -> UTCTime -> Event
modeCB
    }

-- * Logging helpers
--

-- | Show a number, padded to the left with zeroes up to the specified width
showWidth :: Int    -- ^ Width to fill to
          -> Int    -- ^ Number to show
          -> String -- ^ Padded string
showWidth :: Int -> Int -> String
showWidth Int
width Int
n = String
zeroes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
num
    where num :: String
num    = Int -> String
forall a. Show a => a -> String
show Int
n
          zeroes :: String
zeroes = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
num) Char
'0'

timeStamp :: UTCTime -> String
timeStamp :: UTCTime -> String
timeStamp (UTCTime Day
_ DiffTime
ct) =
    (Int -> Int -> String
showWidth Int
2 (Int
hours Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
24)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    (Int -> Int -> String
showWidth Int
2 (Int
mins  Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
60)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    (Int -> Int -> String
showWidth Int
2 (Int
secs  Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
60))
    where
        secs :: Int
secs  = DiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round DiffTime
ct :: Int
        mins :: Int
mins  = Int
secs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
60
        hours :: Int
hours = Int
mins Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
60

-- | Show a DateStamp.
dateToString :: DateStamp -> String
dateToString :: DateStamp -> String
dateToString (Int
d, Int
m, Integer
y) = (Int -> Int -> String
showWidth Int
2 (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
y) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         (Int -> Int -> String
showWidth Int
2 (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> Int
fromEnum Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         (Int -> Int -> String
showWidth Int
2 Int
d)

-- | UTCTime -> DateStamp conversion
dateStamp :: UTCTime -> DateStamp
dateStamp :: UTCTime -> DateStamp
dateStamp (UTCTime Day
day DiffTime
_) = (Int
d, Int
m, Integer
y)
    where (Integer
y,Int
m,Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day

-- * State manipulation functions
--

-- | Cleans up after the module (closes files)
cleanLogState :: Log ()
cleanLogState :: ModuleT LogState LB ()
cleanLogState =
    (LBState (ModuleT LogState LB)
 -> (LBState (ModuleT LogState LB) -> ModuleT LogState LB ())
 -> ModuleT LogState LB ())
-> ModuleT LogState LB ()
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (ModuleT LogState LB)
  -> (LBState (ModuleT LogState LB) -> ModuleT LogState LB ())
  -> ModuleT LogState LB ())
 -> ModuleT LogState LB ())
-> (LBState (ModuleT LogState LB)
    -> (LBState (ModuleT LogState LB) -> ModuleT LogState LB ())
    -> ModuleT LogState LB ())
-> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ \LBState (ModuleT LogState LB)
state LBState (ModuleT LogState LB) -> ModuleT LogState LB ()
writer -> do
      IO () -> ModuleT LogState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT LogState LB ())
-> IO () -> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ (ChanState -> IO () -> IO ()) -> IO () -> LogState -> IO ()
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr (\ChanState
cs IO ()
iom -> IO ()
iom IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose (ChanState -> Handle
chanHandle ChanState
cs)) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) LogState
LBState (ModuleT LogState LB)
state
      LBState (ModuleT LogState LB) -> ModuleT LogState LB ()
writer LBState (ModuleT LogState LB)
forall k a. Map k a
M.empty

-- | Fetch a channel from the internal map. Uses LB's fail if not found.
getChannel :: Channel -> Log ChanState
getChannel :: Channel -> Log ChanState
getChannel Channel
c = (ModuleT LogState LB LogState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS ModuleT LogState LB LogState
-> (LogState -> Log ChanState) -> Log ChanState
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) ((LogState -> Log ChanState) -> Log ChanState)
-> (Channel -> LogState -> Log ChanState)
-> Channel
-> Log ChanState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> LogState -> Log ChanState
forall {m :: * -> *} {k} {a}.
(MonadFail m, Ord k) =>
k -> Map k a -> m a
mLookup (Channel -> Log ChanState) -> Channel -> Log ChanState
forall a b. (a -> b) -> a -> b
$ Channel
c
    where mLookup :: k -> Map k a -> m a
mLookup k
k = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"getChannel: not found") a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m a) -> (Map k a -> Maybe a) -> Map k a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k

getDate :: Channel -> Log DateStamp
getDate :: Channel -> Log DateStamp
getDate Channel
c = (ChanState -> DateStamp) -> Log ChanState -> Log DateStamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChanState -> DateStamp
chanDate (Log ChanState -> Log DateStamp)
-> (Channel -> Log ChanState) -> Channel -> Log DateStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Log ChanState
getChannel (Channel -> Log DateStamp) -> Channel -> Log DateStamp
forall a b. (a -> b) -> a -> b
$ Channel
c

getHandle :: Channel -> Log Handle
getHandle :: Channel -> Log Handle
getHandle Channel
c = (ChanState -> Handle) -> Log ChanState -> Log Handle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChanState -> Handle
chanHandle (Log ChanState -> Log Handle)
-> (Channel -> Log ChanState) -> Channel -> Log Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Log ChanState
getChannel (Channel -> Log Handle) -> Channel -> Log Handle
forall a b. (a -> b) -> a -> b
$ Channel
c
    -- add points. otherwise:
    -- Unbound implicit parameters (?ref::GHC.IOBase.MVar LogState, ?name::String)
    --  arising from instantiating a type signature at
    -- Plugin/Log.hs:187:30-39
    -- Probable cause: `getChannel' is applied to too few arguments

-- | Put a DateStamp and a Handle. Used by 'openChannelFile' and
--  'reopenChannelMaybe'.
putHdlAndDS :: Channel -> Handle -> DateStamp -> Log ()
putHdlAndDS :: Channel -> Handle -> DateStamp -> ModuleT LogState LB ()
putHdlAndDS Channel
c Handle
hdl DateStamp
ds =
        (LBState (ModuleT LogState LB) -> LBState (ModuleT LogState LB))
-> ModuleT LogState LB ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS ((ChanState -> ChanState) -> Channel -> LogState -> LogState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (\ChanState
cs -> ChanState
cs {chanHandle :: Handle
chanHandle = Handle
hdl, chanDate :: DateStamp
chanDate = DateStamp
ds}) Channel
c)


-- * Logging IO
--

-- | Open a file to write the log to.
openChannelFile :: Channel -> UTCTime -> Log Handle
openChannelFile :: Channel -> UTCTime -> Log Handle
openChannelFile Channel
chan UTCTime
ct = do
    String
logDir <- LB String -> ModuleT LogState LB String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB String -> ModuleT LogState LB String)
-> LB String -> ModuleT LogState LB String
forall a b. (a -> b) -> a -> b
$ String -> LB String
findLBFileForWriting String
"Log"
    let dir :: String
dir  = String
logDir String -> ShowS
</> Channel -> String
nTag Channel
chan String -> ShowS
</> Channel -> String
nName Channel
chan
        file :: String
file = String
dir String -> ShowS
</> (DateStamp -> String
dateToString DateStamp
date) String -> ShowS
<.> String
"txt"
    IO Handle -> Log Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Handle -> Log Handle) -> IO Handle -> Log Handle
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir IO () -> IO Handle -> IO Handle
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IOMode -> IO Handle
openFile String
file IOMode
AppendMode
    where date :: DateStamp
date = UTCTime -> DateStamp
dateStamp UTCTime
ct

-- | Close and re-open a log file, and update the state.
reopenChannelMaybe :: Channel -> UTCTime -> Log ()
reopenChannelMaybe :: Channel -> UTCTime -> ModuleT LogState LB ()
reopenChannelMaybe Channel
chan UTCTime
ct = do
  DateStamp
date <- Channel -> Log DateStamp
getDate Channel
chan
  Bool -> ModuleT LogState LB () -> ModuleT LogState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DateStamp
date DateStamp -> DateStamp -> Bool
forall a. Eq a => a -> a -> Bool
/= UTCTime -> DateStamp
dateStamp UTCTime
ct) (ModuleT LogState LB () -> ModuleT LogState LB ())
-> ModuleT LogState LB () -> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ do
    Handle
hdl <- Channel -> Log Handle
getHandle Channel
chan
    IO () -> ModuleT LogState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT LogState LB ())
-> IO () -> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
hdl
    Handle
hdl' <- Channel -> UTCTime -> Log Handle
openChannelFile Channel
chan UTCTime
ct
    Channel -> Handle -> DateStamp -> ModuleT LogState LB ()
putHdlAndDS Channel
chan Handle
hdl' (UTCTime -> DateStamp
dateStamp UTCTime
ct)

-- | Initialise the channel state (if it not already inited)
initChannelMaybe :: Nick -> UTCTime -> Log ()
initChannelMaybe :: Channel -> UTCTime -> ModuleT LogState LB ()
initChannelMaybe Channel
chan UTCTime
ct = do
  Bool
chanp <- (LogState -> Bool)
-> ModuleT LogState LB LogState -> ModuleT LogState LB Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Channel -> LogState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Channel
chan) ModuleT LogState LB LogState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
  Bool -> ModuleT LogState LB () -> ModuleT LogState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
chanp (ModuleT LogState LB () -> ModuleT LogState LB ())
-> ModuleT LogState LB () -> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ do
    Handle
hdl <- Channel -> UTCTime -> Log Handle
openChannelFile Channel
chan UTCTime
ct
    (LBState (ModuleT LogState LB) -> LBState (ModuleT LogState LB))
-> ModuleT LogState LB ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS (Channel -> ChanState -> LogState -> LogState
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Channel
chan (ChanState -> LogState -> LogState)
-> ChanState -> LogState -> LogState
forall a b. (a -> b) -> a -> b
$ Handle -> DateStamp -> ChanState
CS Handle
hdl (UTCTime -> DateStamp
dateStamp UTCTime
ct))

-- | Ensure that the log is correctly initialised etc.
withValidLog :: (Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a
withValidLog :: forall a.
(Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a
withValidLog Handle -> UTCTime -> Log a
f UTCTime
ct Channel
chan = do
  Channel -> UTCTime -> ModuleT LogState LB ()
initChannelMaybe Channel
chan UTCTime
ct
  Channel -> UTCTime -> ModuleT LogState LB ()
reopenChannelMaybe Channel
chan UTCTime
ct
  Handle
hdl <- Channel -> Log Handle
getHandle Channel
chan
  a
rv <- Handle -> UTCTime -> Log a
f Handle
hdl UTCTime
ct
  a -> Log a
forall (m :: * -> *) a. Monad m => a -> m a
return a
rv

-- | Log a string. Main logging workhorse.
logString :: Handle -> String -> Log ()
logString :: Handle -> String -> ModuleT LogState LB ()
logString Handle
hdl String
str = IO () -> ModuleT LogState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT LogState LB ())
-> IO () -> ModuleT LogState LB ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
hdl String
str IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
hdl
  -- We flush on each operation to ensure logs are up to date.

-- * The event loggers themselves
--

-- | When somebody joins.
joinCB :: IrcMessage -> UTCTime -> Event
joinCB :: IrcMessage -> UTCTime -> Event
joinCB IrcMessage
msg UTCTime
ct = Channel -> String -> UTCTime -> Event
Joined (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg) (IrcMessage -> String
forall a. Message a => a -> String
Msg.fullName IrcMessage
msg) UTCTime
ct

-- | When somebody quits.
partCB :: IrcMessage -> UTCTime -> Event
partCB :: IrcMessage -> UTCTime -> Event
partCB IrcMessage
msg UTCTime
ct = Channel -> String -> UTCTime -> Event
Parted (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg) (IrcMessage -> String
forall a. Message a => a -> String
Msg.fullName IrcMessage
msg) UTCTime
ct

-- | When somebody is kicked.
kickCB :: IrcMessage -> UTCTime -> Event
kickCB :: IrcMessage -> UTCTime -> Event
kickCB IrcMessage
msg UTCTime
ct = Channel -> Channel -> String -> UTCTime -> String -> Event
Kicked (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg) { nName :: String
nName = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ IrcMessage -> [String]
ircMsgParams IrcMessage
msg }
                       (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg)
                       (IrcMessage -> String
forall a. Message a => a -> String
Msg.fullName IrcMessage
msg)
                       UTCTime
ct
                       (ShowS
forall a. [a] -> [a]
tail ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ IrcMessage -> [String]
ircMsgParams IrcMessage
msg)

-- | When somebody changes his\/her name.
-- TODO:  We should only do this for channels that the user is currently on.
nickCB :: IrcMessage -> UTCTime -> Event
nickCB :: IrcMessage -> UTCTime -> Event
nickCB IrcMessage
msg UTCTime
ct = Channel -> String -> UTCTime -> Channel -> Event
Renick (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg) (IrcMessage -> String
forall a. Message a => a -> String
Msg.fullName IrcMessage
msg) UTCTime
ct
                       (String -> String -> Channel
parseNick (IrcMessage -> String
forall a. Message a => a -> String
Msg.server IrcMessage
msg) (String -> Channel) -> String -> Channel
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ IrcMessage -> [String]
ircMsgParams IrcMessage
msg)

-- | When somebody changes channel mode.
modeCB :: IrcMessage -> UTCTime -> Event
modeCB :: IrcMessage -> UTCTime -> Event
modeCB IrcMessage
msg UTCTime
ct = Channel -> String -> UTCTime -> String -> Event
Mode (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg) (IrcMessage -> String
forall a. Message a => a -> String
Msg.fullName IrcMessage
msg) UTCTime
ct
                     ([String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ IrcMessage -> [String]
ircMsgParams IrcMessage
msg)

-- | When somebody speaks.
msgCB :: IrcMessage -> UTCTime -> Event
msgCB :: IrcMessage -> UTCTime -> Event
msgCB IrcMessage
msg UTCTime
ct = Channel -> UTCTime -> String -> Event
Said (IrcMessage -> Channel
forall a. Message a => a -> Channel
Msg.nick IrcMessage
msg) UTCTime
ct
                    (ShowS
forall a. [a] -> [a]
tail ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ IrcMessage -> [String]
ircMsgParams IrcMessage
msg)
                      -- each lines is :foo