diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2003 Andrew J. Bromage +Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell +Portions Copyright (c) 2003-2006 Members of the AUTHORS file + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject +to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY +KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/lambdabot-irc-plugins.cabal b/lambdabot-irc-plugins.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-irc-plugins.cabal @@ -0,0 +1,55 @@ +name: lambdabot-irc-plugins +version: 5.0 + +license: GPL +license-file: LICENSE + +author: Don Stewart +maintainer: James Cook + +category: Development, Web +synopsis: IRC plugins for lambdabot. +description: Lambdabot is an IRC bot written over several years by + those on the #haskell IRC channel. + . + Provided plugins: + . + [irc] Lets lambdabot connect to IRC. + [localtime] Check user's local time. + [log] Log IRC channels. + [topic] Modify channel topics. + +homepage: http://haskell.org/haskellwiki/Lambdabot + +build-type: Simple +cabal-version: >= 1.8 +tested-with: GHC == 7.6.3, GHC == 7.8.3 + +source-repository head + type: git + location: https://github.com/lambdabot/lambdabot.git + +library + hs-source-dirs: src + ghc-options: -Wall + -funbox-strict-fields + + exposed-modules: Lambdabot.Plugin.IRC + + other-modules: Lambdabot.Plugin.IRC.IRC + Lambdabot.Plugin.IRC.Localtime + Lambdabot.Plugin.IRC.Log + Lambdabot.Plugin.IRC.Topic + + build-depends: base >= 4.4 && < 5, + bytestring >= 0.9, + containers >= 0.4, + directory >= 1.1, + filepath >= 1.3, + lambdabot-core >= 5 && < 5.1, + lifted-base >= 0.2, + mtl >= 2, + network >= 2.3.0.13, + time >= 1.4, + SafeSemaphore >= 0.9, + split >= 0.2 diff --git a/src/Lambdabot/Plugin/IRC.hs b/src/Lambdabot/Plugin/IRC.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/IRC.hs @@ -0,0 +1,16 @@ +module Lambdabot.Plugin.IRC + ( ircPlugin + , localtimePlugin + , logPlugin + , topicPlugin + + , ircPlugins + ) where + +import Lambdabot.Plugin.IRC.IRC +import Lambdabot.Plugin.IRC.Localtime +import Lambdabot.Plugin.IRC.Log +import Lambdabot.Plugin.IRC.Topic + +ircPlugins :: [String] +ircPlugins = ["irc", "localtime", "log", "topic"] diff --git a/src/Lambdabot/Plugin/IRC/IRC.hs b/src/Lambdabot/Plugin/IRC/IRC.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/IRC/IRC.hs @@ -0,0 +1,190 @@ +-- | The plugin-level IRC interface. + +module Lambdabot.Plugin.IRC.IRC (ircPlugin) where + +import Lambdabot.IRC +import Lambdabot.Logging +import Lambdabot.Monad +import Lambdabot.Plugin +import Lambdabot.Util + +import Control.Concurrent.Lifted +import qualified Control.Concurrent.SSem as SSem +import Control.Exception.Lifted as E (SomeException(..), throwIO, catch) +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString.Char8 as P +import Data.List +import Data.List.Split +import Network( connectTo, PortID(..) ) +import System.IO +import System.Timeout.Lifted +import Data.IORef + +data IRCState = + IRCState { + password :: Maybe String + } + +type IRC = ModuleT IRCState LB + +ircPlugin :: Module IRCState +ircPlugin = newModule + { moduleCmds = return + [ (command "irc-connect") + { privileged = True + , help = say "irc-connect tag host portnum nickname userinfo. connect to an irc server" + , process = \rest -> + case splitOn " " rest of + tag:hostn:portn:nickn:uix -> do + pn <- (PortNumber . fromInteger) `fmap` readM portn + lift (online tag hostn pn nickn (intercalate " " uix)) + _ -> say "Not enough parameters!" + } + , (command "irc-password") + { privileged = True + , help = say "irc-password pwd. set password for next irc-connect command" + , process = \rest -> + case splitOn " " rest of + pwd:_ -> do + modifyMS (\ms -> ms{ password = Just pwd }) + _ -> say "Not enough parameters!" + } + ] + , moduleDefState = return $ IRCState{ password = Nothing } + } + +---------------------------------------------------------------------- +-- Encoding and decoding of messages + +-- | 'encodeMessage' takes a message and converts it to a function. +-- giving this function a string will attach the string to the message +-- and output a string containing IRC protocol commands ready for writing +-- on the outgoing stream socket. +encodeMessage :: IrcMessage -> String -> String +encodeMessage msg + = encodePrefix (ircMsgPrefix msg) . encodeCommand (ircMsgCommand msg) + . encodeParams (ircMsgParams msg) + where + encodePrefix [] = id + encodePrefix prefix = showChar ':' . showString prefix . showChar ' ' + + encodeCommand cmd = showString cmd + + encodeParams [] = id + encodeParams (p:ps) = showChar ' ' . showString p . encodeParams ps + +-- | 'decodeMessage' Takes an input line from the IRC protocol stream +-- and decodes it into a message. TODO: this has too many parameters. +decodeMessage :: String -> String -> String -> IrcMessage +decodeMessage svr lbn line = + let (prefix, rest1) = decodePrefix (,) line + (cmd, rest2) = decodeCmd (,) rest1 + params = decodeParams rest2 + in IrcMessage { ircMsgServer = svr, ircMsgLBName = lbn, ircMsgPrefix = prefix, + ircMsgCommand = cmd, ircMsgParams = params } + where + decodePrefix k (':':cs) = decodePrefix' k cs + where decodePrefix' j "" = j "" "" + decodePrefix' j (' ':ds) = j "" ds + decodePrefix' j (c:ds) = decodePrefix' (j . (c:)) ds + + decodePrefix k cs = k "" cs + + decodeCmd k [] = k "" "" + decodeCmd k (' ':cs) = k "" cs + decodeCmd k (c:cs) = decodeCmd (k . (c:)) cs + + decodeParams :: String -> [String] + decodeParams xs = decodeParams' [] [] xs + where + decodeParams' param params [] + | null param = reverse params + | otherwise = reverse (reverse param : params) + decodeParams' param params (' ' : cs) + | null param = decodeParams' [] params cs + | otherwise = decodeParams' [] (reverse param : params) cs + decodeParams' param params rest@(c@':' : cs) + | null param = reverse (rest : params) + | otherwise = decodeParams' (c:param) params cs + decodeParams' param params (c:cs) = decodeParams' (c:param) params cs + +ircSignOn :: String -> Nick -> Maybe String -> String -> LB () +ircSignOn svr nickn pwd ircname = do + maybe (return ()) (\pwd' -> send $ pass (nTag nickn) pwd') pwd + send $ user (nTag nickn) (nName nickn) svr ircname + send $ setNick nickn + +------------------------------------------------------------------------ +-- +-- Lambdabot is mostly synchronous. We have a main loop, which reads +-- messages and forks threads to execute commands (which write responces). +-- OR +-- We have a main loop which reads offline commands, and synchronously +-- interprets them. + +online :: String -> String -> PortID -> String -> String -> IRC () +online tag hostn portnum nickn ui = do + sock <- io $ connectTo hostn portnum + io $ hSetBuffering sock NoBuffering + -- Implements flood control: RFC 2813, section 5.8 + sem1 <- io $ SSem.new 0 + sem2 <- io $ SSem.new 4 -- one extra token stays in the MVar + sendmv <- io newEmptyMVar + pongref <- io $ newIORef False + io . void . fork . forever $ do + SSem.wait sem1 + threadDelay 2000000 + SSem.signal sem2 + io . void . fork . forever $ do + SSem.wait sem2 + putMVar sendmv () + SSem.signal sem1 + E.catch + (addServer tag (io . sendMsg sock sendmv)) + (\err@SomeException{} -> io (hClose sock) >> E.throwIO err) + pwd <- password `fmap` readMS + modifyMS $ \ms -> ms{ password = Nothing } + lb $ ircSignOn hostn (Nick tag nickn) pwd ui + lb . void . fork $ E.catch + (readerLoop tag nickn pongref sock) + (\e@SomeException{} -> do + errorM (show e) + remServer tag) + lb . void . fork $ E.catch + (pingPongDelay >> pingPongLoop tag hostn pongref sock) + (\e@SomeException{} -> do + errorM (show e) + remServer tag) + +pingPongDelay :: LB () +pingPongDelay = io $ threadDelay 120000000 + +pingPongLoop :: String -> String -> IORef Bool -> Handle -> LB () +pingPongLoop tag hostn pongref sock = do + io $ writeIORef pongref False + io $ P.hPut sock $ P.pack $ "PING " ++ hostn ++ "\r\n" + pingPongDelay + pong <- io $ readIORef pongref + if pong + then pingPongLoop tag hostn pongref sock + else errorM "Ping timeout." >> remServer tag + +readerLoop :: String -> String -> IORef Bool -> Handle -> LB () +readerLoop tag nickn pongref sock = forever $ do + line <- io $ hGetLine sock + let line' = filter (`notElem` "\r\n") line + if "PING " `isPrefixOf` line' + then io $ P.hPut sock $ P.pack $ "PONG " ++ drop 5 line' ++ "\r\n" + else void . fork . void . timeout 15000000 $ do + let msg = decodeMessage tag nickn line' + if ircMsgCommand msg == "PONG" + then io $ writeIORef pongref True + else received msg + +sendMsg :: Handle -> MVar () -> IrcMessage -> IO () +sendMsg sock mv msg = + E.catch (do takeMVar mv + P.hPut sock $ P.pack $ encodeMessage msg "\r\n") + (\err -> do errorM (show (err :: IOError)) + hClose sock) diff --git a/src/Lambdabot/Plugin/IRC/Localtime.hs b/src/Lambdabot/Plugin/IRC/Localtime.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/IRC/Localtime.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeFamilies #-} + +-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) + +-- | Simple wrapper over privmsg to get time information via the CTCP +module Lambdabot.Plugin.IRC.Localtime (localtimePlugin) where + +import Lambdabot.Plugin +import Lambdabot.Bot (ircPrivmsg') +import qualified Data.Map as M + +type TimeMap = M.Map Nick -- the person who's time we requested + [Nick] -- a list of targets waiting on this time + +localtimePlugin :: Module TimeMap +localtimePlugin = newModule + { moduleDefState = return M.empty + + , moduleCmds = return + [ (command "time") + { aliases = ["localtime"] + , help = say "time . Print a user's local time. User's client must support ctcp pings." + , process = doLocalTime + } + , (command "localtime-reply") + { help = say "time . Print a user's local time. User's client must support ctcp pings." + , process = doReply + } + ] + } :: Module TimeMap + +-- record this person as a callback, for when we (asynchronously) get a result +doLocalTime :: (MonadLBState m, LBState m ~ M.Map Nick [Nick]) => + [Char] -> Cmd m () +doLocalTime [] = do + n <- getSender + doLocalTime (nName n) + +doLocalTime rawWho = do + whoAsked <- getTarget + whoToPing <- readNick $ fst $ break (== ' ') rawWho + me <- getLambdabotName + if whoToPing /= me + then do + modifyMS $ \st -> M.insertWith (++) whoToPing [whoAsked] st + -- this is a CTCP time call, which returns a NOTICE + lb $ ircPrivmsg' whoToPing ("\^ATIME\^A") -- has to be raw + else say "I live on the internet, do you expect me to have a local time?" + +-- the Base module caught the NOTICE TIME, mapped it to a PRIVMGS, and here it is :) +doReply :: (MonadLBState m, LBState m ~ M.Map Nick [Nick]) => + [Char] -> Cmd m () +doReply text = do + let (whoGotPinged', time') = break (== ':') text + time = drop 1 time' + whoGotPinged <- readNick whoGotPinged' + + targets <- withMS $ \st set -> do + case M.lookup whoGotPinged st of + Nothing -> return [] + Just xs -> do set (M.insert whoGotPinged [] st) -- clear the callback state + return xs + whoGotPinged'' <- showNick whoGotPinged + let txt = "Local time for " ++ whoGotPinged'' ++ " is " ++ time + lb $ flip mapM_ targets $ flip ircPrivmsg' txt diff --git a/src/Lambdabot/Plugin/IRC/Log.hs b/src/Lambdabot/Plugin/IRC/Log.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/IRC/Log.hs @@ -0,0 +1,203 @@ +-- Copyright (c) 2004 Thomas Jaeger +-- Copyright (c) 2005 Simon Winwood +-- Copyright (c) 2005 Don Stewart +-- Copyright (c) 2005 David House +-- +-- | Logging an IRC channel.. +-- +module Lambdabot.Plugin.IRC.Log (logPlugin) where + +import Lambdabot.Bot +import Lambdabot.Compat.FreenodeNick +import Lambdabot.IRC +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 { chanHandle :: Handle, + chanDate :: DateStamp } + deriving (Show, 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 + | Renick Nick String UTCTime Nick + deriving (Eq) + +instance Show Event where + show (Said nick ct what) = timeStamp ct ++ " <" ++ nName nick ++ "> " ++ what + show (Joined nick usr ct) = timeStamp ct ++ " " ++ show (FreenodeNick nick) + ++ " (" ++ usr ++ ") joined." + show (Parted nick usr ct) = timeStamp ct ++ " " ++ show (FreenodeNick nick) + ++ " (" ++ usr ++ ") left." + show (Renick nick usr ct new) = timeStamp ct ++ " " ++ show (FreenodeNick nick) + ++ " (" ++ usr ++ ") is now " ++ show (FreenodeNick new) ++ "." + +-- * Dispatchers and Module instance declaration +-- +logPlugin :: Module (M.Map Channel ChanState) +logPlugin = newModule + { moduleDefState = return M.empty + , moduleExit = cleanLogState + , moduleInit = do + let doLog f m hdl = logString hdl . show . f m + wrapCB f = bindModule1 $ \msg -> do + now <- io getCurrentTime + -- map over the channels this message was directed to, adding to each + -- of their log files. + mapM_ (withValidLog (doLog f msg) now) (Msg.channels msg) + connect signal cb = ircSignalConnect signal =<< wrapCB cb + + connect "PRIVMSG" msgCB + connect "JOIN" joinCB + connect "PART" partCB + connect "NICK" nickCB + } + +-- * 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 width n = zeroes ++ num + where num = show n + zeroes = replicate (width - length num) '0' + +timeStamp :: UTCTime -> String +timeStamp (UTCTime _ ct) = + (showWidth 2 (hours `mod` 24)) ++ ":" ++ + (showWidth 2 (mins `mod` 60)) ++ ":" ++ + (showWidth 2 (secs `mod` 60)) + where + secs = round ct :: Int + mins = secs `div` 60 + hours = mins `div` 60 + +-- | Show a DateStamp. +dateToString :: DateStamp -> String +dateToString (d, m, y) = (showWidth 2 $ fromInteger y) ++ "-" ++ + (showWidth 2 $ fromEnum m + 1) ++ "-" ++ + (showWidth 2 d) + +-- | UTCTime -> DateStamp conversion +dateStamp :: UTCTime -> DateStamp +dateStamp (UTCTime day _) = (d, m, y) + where (y,m,d) = toGregorian day + +-- * State manipulation functions +-- + +-- | Cleans up after the module (closes files) +cleanLogState :: Log () +cleanLogState = + withMS $ \state writer -> do + io $ M.fold (\cs iom -> iom >> hClose (chanHandle cs)) (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 >>=) . mLookup $ c + where mLookup k = maybe (fail "getChannel: not found") return . M.lookup k + +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 + +-- | Put a DateStamp and a Handle. Used by 'openChannelFile' and +-- 'reopenChannelMaybe'. +putHdlAndDS :: Channel -> Handle -> DateStamp -> Log () +putHdlAndDS c hdl ds = + modifyMS (M.adjust (\cs -> cs {chanHandle = hdl, chanDate = ds}) c) + + +-- * Logging IO +-- + +-- | Open a file to write the log to. +openChannelFile :: Channel -> UTCTime -> Log Handle +openChannelFile chan ct = do + stateDir <- getConfig outputDir + let dir = stateDir "Log" nTag chan nName chan + file = dir (dateToString date) <.> "txt" + io $ createDirectoryIfMissing True dir >> openFile file AppendMode + where date = dateStamp ct + +-- | Close and re-open a log file, and update the state. +reopenChannelMaybe :: Channel -> UTCTime -> 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 :: Nick -> UTCTime -> Log () +initChannelMaybe chan ct = do + chanp <- liftM (M.member chan) readMS + 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 -> UTCTime -> Log a) -> UTCTime -> 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 -> Log () +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 :: IrcMessage -> UTCTime -> Event +joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct + +-- | When somebody quits. +partCB :: IrcMessage -> UTCTime -> Event +partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct + +-- | 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 msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct + (parseNick (Msg.server msg) $ drop 1 $ head $ ircMsgParams msg) + +-- | When somebody speaks. +msgCB :: IrcMessage -> UTCTime -> Event +msgCB msg ct = Said (Msg.nick msg) ct + (tail . concat . tail $ ircMsgParams msg) + -- each lines is :foo diff --git a/src/Lambdabot/Plugin/IRC/Topic.hs b/src/Lambdabot/Plugin/IRC/Topic.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/IRC/Topic.hs @@ -0,0 +1,112 @@ +-- | The Topic plugin is an interface for messing with the channel topic. +-- It can alter the topic in various ways and keep track of the changes. +-- The advantage of having the bot maintain the topic is that we get an +-- authoritative source for the current topic, when the IRC server decides +-- to delete it due to Network Splits. +module Lambdabot.Plugin.IRC.Topic (topicPlugin) where + +import Lambdabot.IRC +import Lambdabot.Monad +import Lambdabot.Plugin +import Lambdabot.Util + +import qualified Data.Map as M + +import Control.Monad.State (gets) + +type Topic = ModuleT () LB + +type TopicAction = Nick -> String -> Cmd Topic () +data TopicCommand = TopicCommand + { _commandAliases :: [String] + , _commandHelp :: String + , _invokeCommand :: TopicAction + } + +commands :: [TopicCommand] +commands = + [ TopicCommand ["set-topic"] + "Set the topic of the channel, without using all that listy stuff" + (installTopic) + , TopicCommand ["get-topic"] + "Recite the topic of the channel" + (reciteTopic) + + , TopicCommand ["unshift-topic", "queue-topic"] + "Add a new topic item to the front of the topic list" + (alterListTopic (:)) + , TopicCommand ["shift-topic"] + "Remove a topic item from the front of the topic list" + (alterListTopic (const tail)) + + , TopicCommand ["push-topic"] + "Add a new topic item to the end of the topic stack" + (alterListTopic (\arg -> (++ [arg]))) + , TopicCommand ["pop-topic", "dequeue-topic"] + "Pop an item from the end of the topic stack" + (alterListTopic (const init)) + + , TopicCommand ["clear-topic"] + "Empty the topic stack" + (alterListTopic (\_ _ -> [])) + ] + +topicPlugin :: Module () +topicPlugin = newModule + { moduleCmds = return + [ (command name) + { help = say helpStr + , aliases = aliases' + , process = \args -> do + tgt <- getTarget + (chan, rest) <- case splitFirstWord args of + (c@('#':_), r) -> do + c' <- readNick c + return (Just c', r) + _ -> case nName tgt of + ('#':_) -> return (Just tgt, args) + _ -> return (Nothing, args) + + case chan of + Just chan' -> invoke chan' rest + Nothing -> say "What channel?" + } + | TopicCommand (name:aliases') helpStr invoke <- commands + ] + } + +------------------------------------------------------------------------ +-- Topic action implementations + +installTopic :: TopicAction +installTopic chan topic = withTopic chan $ \_ -> do + lb (send (setTopic chan topic)) + +reciteTopic :: TopicAction +reciteTopic chan "" = withTopic chan $ \topic -> do + say (nName chan ++ ": " ++ topic) +reciteTopic _ ('#':_) = say "One channel at a time. Jeepers!" +reciteTopic _ _ = say "I don't know what all that extra stuff is about." + +alterTopic :: (String -> String -> String) -> TopicAction +alterTopic f chan args = withTopic chan $ \oldTopic -> do + lb (send (setTopic chan (f args oldTopic))) + +alterListTopic :: (String -> [String] -> [String]) -> TopicAction +alterListTopic f = alterTopic $ \args topic -> show $ case reads topic of + [(xs, "")] -> f args xs + _ -> f args [topic] + +------------------------------------------------------------------------ + +lookupTopic :: Nick -> LB (Maybe String) +lookupTopic chan = gets (\s -> M.lookup (mkCN chan) (ircChannels s)) + +-- | 'withTopic' is like 'lookupTopic' except that it ditches the Maybe in +-- favor of just yelling at the user when things don't work out as planned. +withTopic :: Nick -> (String -> Cmd Topic ()) -> Cmd Topic () +withTopic chan f = do + maybetopic <- lb (lookupTopic chan) + case maybetopic of + Just t -> f t + Nothing -> say "I don't know that channel."