lambdabot-irc-plugins-5.0.3/0000755000000000000000000000000012554503453014072 5ustar0000000000000000lambdabot-irc-plugins-5.0.3/LICENSE0000644000000000000000000000225612554503453015104 0ustar0000000000000000Copyright (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. lambdabot-irc-plugins-5.0.3/lambdabot-irc-plugins.cabal0000644000000000000000000000424612554503453021243 0ustar0000000000000000name: lambdabot-irc-plugins version: 5.0.3 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.0.3 && < 5.1, lifted-base >= 0.2, mtl >= 2, network >= 2.3.0.13, time >= 1.4, SafeSemaphore >= 0.9, split >= 0.2 lambdabot-irc-plugins-5.0.3/Setup.hs0000644000000000000000000000014212554503453015523 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-irc-plugins-5.0.3/src/0000755000000000000000000000000012554503453014661 5ustar0000000000000000lambdabot-irc-plugins-5.0.3/src/Lambdabot/0000755000000000000000000000000012554503453016546 5ustar0000000000000000lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/0000755000000000000000000000000012554503453020004 5ustar0000000000000000lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/IRC.hs0000644000000000000000000000053112554503453020754 0ustar0000000000000000module 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"] lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/IRC/0000755000000000000000000000000012554503453020421 5ustar0000000000000000lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/IRC/Log.hs0000644000000000000000000001761512554503453021510 0ustar0000000000000000-- 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 | Kicked Nick Nick String UTCTime String | Renick Nick String UTCTime Nick | Mode Nick String UTCTime String 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 (Kicked nick op usrop ct reason) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " was kicked by " ++ show (FreenodeNick op) ++ " (" ++ usrop ++ "): " ++ reason ++ "." show (Renick nick usr ct new) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " (" ++ usr ++ ") is now " ++ show (FreenodeNick new) ++ "." show (Mode nick usr ct mode) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " (" ++ usr ++ ") changed mode to " ++ mode ++ "." -- * 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 "KICK" kickCB connect "NICK" nickCB connect "MODE" 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 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 logDir <- lb $ findLBFileForWriting "Log" let dir = logDir 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 is kicked. kickCB :: IrcMessage -> UTCTime -> Event kickCB msg ct = Kicked (Msg.nick msg) { nName = head $ tail $ ircMsgParams msg } (Msg.nick msg) (Msg.fullName msg) ct (tail . concat . tail . tail $ ircMsgParams 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 msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct (parseNick (Msg.server msg) $ drop 1 $ head $ ircMsgParams msg) -- | When somebody changes channel mode. modeCB :: IrcMessage -> UTCTime -> Event modeCB msg ct = Mode (Msg.nick msg) (Msg.fullName msg) ct (unwords $ tail $ 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 lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/IRC/Localtime.hs0000644000000000000000000000474412554503453022677 0ustar0000000000000000{-# 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 lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/IRC/IRC.hs0000644000000000000000000001573212554503453021402 0ustar0000000000000000-- | 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) lambdabot-irc-plugins-5.0.3/src/Lambdabot/Plugin/IRC/Topic.hs0000644000000000000000000000763212554503453022043 0ustar0000000000000000-- | 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."