lambdabot-4.0: Plugin/Log.hs
--
-- 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 Plugin.Log (theModule) where
import Plugin
import qualified Message as Msg
import Control.Monad (when)
import qualified Data.Map as M
import System.Time
import System.Directory (createDirectoryIfMissing)
-- ------------------------------------------------------------------------
type Channel = String
newtype LogModule = LogModule ()
type DateStamp = (Int, Month, Int)
data ChanState = CS { chanHandle :: Handle,
chanDate :: DateStamp,
chanHistory :: [Event] }
deriving (Show, Eq)
type LogState = M.Map Channel ChanState
type Log a = ModuleT LogState LB a
data Event =
Said String ClockTime String
| Joined String String ClockTime
| Parted String String ClockTime -- covers quitting as well
| Renick String String ClockTime String
deriving (Eq)
theModule :: MODULE
theModule = MODULE $ LogModule ()
instance Show Event where
show (Said nick ct what) = timeStamp ct ++ " <" ++ nick ++ "> " ++ what
show (Joined nick user ct) = timeStamp ct ++ " " ++ nick
++ " (" ++ user ++ ") joined."
show (Parted nick user ct) = timeStamp ct ++ " " ++ nick
++ " (" ++ user ++ ") left."
show (Renick nick user ct new) = timeStamp ct ++ " " ++ nick
++ " (" ++ user ++ ") is now " ++ new ++ "."
-- * Dispatchers and Module instance declaration
--
-- | Default number of lines to show with @last.
numLastLines :: Int
numLastLines = 10
-- | Command -> Help lookup
commands :: [(String,String)]
commands = [("last",
"@last <channel> [<count>] [<user>] The last <count> (default 10) "
++ "posts to channel <channel>."),
("log-email",
"@log-email <email> [<start-date>] Email the log to the given "
++ "address (default to todays)"),
("print-logs",
"print the current internal state")]
-- | CTCP command -> logger function lookup
loggers :: Msg.Message m => [(String, m -> ClockTime -> Event)]
loggers = [("PRIVMSG", msgCB ),
("JOIN", joinCB),
("PART", partCB),
("NICK", nickCB)]
instance Module LogModule LogState where
moduleHelp _ s = fromJust $ lookup s commands
moduleCmds _ = map fst commands
moduleDefState _ = return M.empty
moduleExit _ = cleanLogState
contextual _ msg _ _ = do
case lookup (Msg.command msg) loggers of
Just f -> do
now <- io getClockTime
-- map over the channels this message was directed to, adding to each
-- of their log files.
when (notMe msg) $
mapM_ (\c -> withValidLog (doLog c f msg) now c) (Msg.channels msg)
Nothing -> return ()
return []
where notMe m = (lowerCaseString $ name config)
/= (lowerCaseString . head $ Msg.channels m)
-- We don't log /msgs to the lambdabot
doLog chan f m hdl ct = do
let event = f m ct
logString hdl (show event)
appendEvent chan event
process _ _ _ "last" rest = showHistory rest
process _ _ _ "print-logs" _ = fmap ((:[]) . show) readMS
-- * The @last command
--
-- | Filter all the nicks by one person
-- FIXME --- maybe we should take into consideration nick changes?
filterNick :: String -> [Event] -> [Event]
filterNick who = filter filterOneNick
where
filterOneNick (Said who' _ _) = who == who'
filterOneNick (Joined who' _ _) = who == who'
filterOneNick (Parted who' _ _) = who == who'
filterOneNick (Renick old _ _ new) = who == old || who == new
-- | Show the last 10 (or whatever) lines from the channel, in reverse order.
showHistory :: String -> Log [String]
showHistory args = do
st <- readMS
case M.lookup chan' st of
Just cs -> let his = chanHistory cs
in return [unlines . reverse . map show
. take nLines'. reverse $ lines' his]
Nothing -> return ["I haven't got any logs for that channel."]
where chan:nLines:nick:_ = map listToMaybeAll (words args ++ repeat "")
chan' = fromMaybe (error "The channel name is required") chan
nLines' = maybe numLastLines read nLines
lines' fm = maybe fm (\n -> filterNick n fm) nick
-- * Event -> String 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 width n = zeroes ++ num
where num = show n
zeroes = replicate (width - length num) '0'
-- | Show a TimeStamp.
timeStamp :: ClockTime -> String
timeStamp ct = let cal = toUTCTime ct
in (showWidth 2 $ ctHour cal) ++ ":" ++
(showWidth 2 $ ctMin cal) ++ ":" ++
(showWidth 2 $ ctSec cal)
-- * Logging helpers
--
-- | Show a DateStamp.
dateToString :: DateStamp -> String
dateToString (d, m, y) = (showWidth 2 y) ++ "-" ++
(showWidth 2 $ fromEnum m + 1) ++ "-" ++
(showWidth 2 d)
-- | ClockTime -> DateStamp conversion
dateStamp :: ClockTime -> DateStamp
dateStamp ct = let cal = toUTCTime ct in (ctDay cal, ctMonth cal, ctYear cal)
-- * State manipulation functions
--
-- | Cleans up after the module (closes files)
cleanLogState :: Log ()
cleanLogState =
withMS $ \state writer -> do
io $ M.fold (\(CS hdl _ _) iom -> iom >> hClose hdl) (return ()) state
writer M.empty
-- | Fetch a channel from the internal map. Uses LB's fail if not found.
getChannel :: Channel -> Log ChanState
getChannel c = (readMS >>=) . M.lookup $ c
getDate :: Channel -> Log DateStamp
getDate c = fmap chanDate . getChannel $ c
getHandle :: Channel -> Log Handle
getHandle c = fmap chanHandle . getChannel $ 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
{-getHistory :: Channel -> Log [Event]
getHistory = fmap chanHistory . getChannel-}
-- | Put a DateStamp and a Handle. Used by 'openChannelFile' and
-- 'reopenChannelMaybe'.
putHdlAndDS :: Channel -> Handle -> DateStamp -> Log ()
putHdlAndDS c hdl ds =
modifyMS (M.adjust (\(CS _ _ his) -> CS hdl ds his) c)
-- | Append an event to the history of a channel
appendEvent :: Channel -> Event -> Log ()
appendEvent c e =
modifyMS (M.adjust (\(CS hdl ds his) -> CS hdl ds (his ++ [e])) c)
-- * Logging IO
--
-- | Open a file to write the log to.
openChannelFile :: Channel -> ClockTime -> Log Handle
openChannelFile chan ct =
io $ createDirectoryIfMissing True dir >> openFile file AppendMode
where dir = outputDir config </> "Log" </> host config </> chan
date = dateStamp ct
file = dir </> (dateToString date) <.> "txt"
-- | Close and re-open a log file, and update the state.
reopenChannelMaybe :: Channel -> ClockTime -> Log ()
reopenChannelMaybe chan ct = do
date <- getDate chan
when (date /= dateStamp ct) $ do
hdl <- getHandle chan
io $ hClose hdl
hdl' <- openChannelFile chan ct
putHdlAndDS chan hdl' (dateStamp ct)
-- | Initialise the channel state (if it not already inited)
initChannelMaybe :: String -> ClockTime -> Log ()
initChannelMaybe chan ct = do
chanp <- liftM (M.member chan) readMS
--io (putStr "chanp: " >> print chanp)
unless chanp $ do
hdl <- openChannelFile chan ct
modifyMS (M.insert chan $ CS hdl (dateStamp ct) [])
-- | Ensure that the log is correctly initialised etc.
withValidLog :: (Handle -> ClockTime -> LB a)
-> ClockTime -> Channel -> Log a
withValidLog f ct chan = do
initChannelMaybe chan ct
reopenChannelMaybe chan ct
hdl <- getHandle chan
rv <- f hdl ct
return rv
-- | Log a string. Main logging workhorse.
logString :: Handle -> String -> LB ()
logString hdl str = io $ hPutStrLn hdl str >> hFlush hdl
-- We flush on each operation to ensure logs are up to date.
-- * The event loggers themselves
--
-- | When somebody joins.
joinCB :: Msg.Message a => a -> ClockTime -> Event
joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct
-- | When somebody quits.
partCB :: Msg.Message a => a -> ClockTime -> Event
partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct
-- | When somebody changes his\/her name.
-- FIXME: We should only do this for channels that the user is currently on.
nickCB :: Msg.Message a => a -> ClockTime -> Event
nickCB msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct
(drop 1 $ head $ Msg.body msg)
-- | When somebody speaks.
msgCB :: Msg.Message a => a -> ClockTime -> Event
msgCB msg ct = Said (Msg.nick msg) ct
(tail . concat . tail $ Msg.body msg)
-- each lines is :foo