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-social-plugins.cabal b/lambdabot-social-plugins.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-social-plugins.cabal @@ -0,0 +1,56 @@ +name: lambdabot-social-plugins +version: 5.0 + +license: GPL +license-file: LICENSE + +author: Don Stewart +maintainer: James Cook + +category: Development, Web +synopsis: Social plugins for Lambdabot +description: Lambdabot is an IRC bot written over several years by + those on the #haskell IRC channel. + . + Provided plugins: + . + [activity] Check where and how much is lambdabot used. + [karma] Track who's been good and who's been naughty. + [poll] Let the people vote. + [seen] Track who was around when. + [tell] Leave messages for other users. + +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.Social + + other-modules: Lambdabot.Plugin.Social.Activity + Lambdabot.Plugin.Social.Karma + Lambdabot.Plugin.Social.Poll + Lambdabot.Plugin.Social.Seen + Lambdabot.Plugin.Social.Seen.StopWatch + Lambdabot.Plugin.Social.Seen.UserStatus + Lambdabot.Plugin.Social.Tell + Lambdabot.Util.NickEq + + build-depends: base >= 4.4 && < 5, + binary >= 0.5, + bytestring >= 0.9, + containers >= 0.4, + lambdabot-core >= 5 && < 5.1, + mtl >= 2, + split >= 0.2, + time >= 1.4 diff --git a/src/Lambdabot/Plugin/Social.hs b/src/Lambdabot/Plugin/Social.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social.hs @@ -0,0 +1,18 @@ +module Lambdabot.Plugin.Social + ( activityPlugin + , karmaPlugin + , pollPlugin + , seenPlugin + , tellPlugin + + , socialPlugins + ) where + +import Lambdabot.Plugin.Social.Activity +import Lambdabot.Plugin.Social.Karma +import Lambdabot.Plugin.Social.Poll +import Lambdabot.Plugin.Social.Seen +import Lambdabot.Plugin.Social.Tell + +socialPlugins :: [String] +socialPlugins = ["activity", "karma", "poll", "seen", "tell"] diff --git a/src/Lambdabot/Plugin/Social/Activity.hs b/src/Lambdabot/Plugin/Social/Activity.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Activity.hs @@ -0,0 +1,59 @@ +-- | Logging an IRC channel.. +module Lambdabot.Plugin.Social.Activity (activityPlugin) where + +import Lambdabot.Bot +import Lambdabot.Plugin +import Lambdabot.Util + +import Control.Arrow ((&&&)) +import Control.Exception (evaluate) +import Data.List +import Data.Maybe +import Data.Time + +type ActivityState = [(UTCTime,Nick)] +type Activity = ModuleT ActivityState LB + +activityPlugin :: Module [(UTCTime, Nick)] +activityPlugin = newModule + { moduleDefState = return [] + , moduleInit = bindModule2 activityFilter >>= ircInstallOutputFilter + + , moduleCmds = return + [ (command "activity") + { help = say helpStr + , process = activity False + } + , (command "activity-full") + { help = say helpStr + , privileged = True + , process = activity True + } + ] + } + +helpStr :: String +helpStr = "activity seconds. Find out where/how much the bot is being used" + +activity :: Bool -> String -> Cmd Activity () +activity full args = do + let obscure nm + | full || isPrefixOf "#" (nName nm) = return nm + | otherwise = readNick "private" + + now <- io getCurrentTime + let cutoff = addUTCTime (- fromInteger (fromMaybe 90 $ readM args)) now + users <- mapM (obscure . snd) . takeWhile ((> cutoff) . fst) =<< readMS + let agg_users = reverse . sort . map (length &&& head) . group . sort $ users + fmt_agg <- fmap (intercalate " " . (:) (show (length users) ++ "*total")) + (mapM (\(n,u) -> do u' <- showNick u; return (show n ++ "*" ++ u')) $ agg_users) + + say fmt_agg + +activityFilter :: Nick -> [String] -> Activity [String] +activityFilter target lns = do + io $ evaluate $ foldr seq () $ map (foldr seq ()) $ lns + withMS $ \ st wr -> do + now <- io getCurrentTime + wr (map (const (now,target)) lns ++ st) + return lns diff --git a/src/Lambdabot/Plugin/Social/Karma.hs b/src/Lambdabot/Plugin/Social/Karma.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Karma.hs @@ -0,0 +1,110 @@ +-- | Karma +module Lambdabot.Plugin.Social.Karma (karmaPlugin) where + +import Lambdabot.Compat.FreenodeNick +import Lambdabot.Plugin +import qualified Lambdabot.Util.NickEq as E + +import Data.Char +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Text.Printf + +type KarmaState = M.Map Nick Integer +type Karma = ModuleT KarmaState LB + +karmaPlugin :: Module KarmaState +karmaPlugin = newModule + { moduleCmds = return + [ (command "karma") + { help = say "karma . Return a person's karma value" + , process = \rest -> withMsg $ \msg -> do + sender <- getSender + tellKarma sender $ case words rest of + [] -> E.mononickToPolynick sender + (nick:_) -> E.readPolynick msg nick + + } + , (command "karma+") + { help = say "karma+ . Increment someone's karma" + , process = doCmd 1 + } + , (command "karma-") + { help = say "karma- . Decrement someone's karma" + , process = doCmd (-1) + } + , (command "karma-all") + { help = say "karma-all. List all karma" + , process = const listKarma + } + ] + + , moduleDefState = return $ M.empty + , moduleSerialize = Just freenodeNickMapSerial + + -- nick++($| ) + , contextual = \text -> withMsg $ \_ -> do + sender <- getSender + + let ws = words text + decs = match "--" + incs = match "++" + match m = mapM readNick . filter okay . map (reverse . drop 2) + . filter (isPrefixOf m) . map reverse $ ws + okay x = not (elem x badNicks || any (`isPrefixOf` x) badPrefixes) + -- Special cases. Ignore the null nick. C must also be ignored + -- because C++ and C-- are languages. + badNicks = ["", "C", "c", "notepad"] + -- More special cases, to ignore Perl code. + badPrefixes = ["$", "@", "%"] + + mapM_ (changeKarma (-1) sender) =<< decs + mapM_ (changeKarma 1 sender) =<< incs + } + +doCmd :: Integer -> String -> Cmd Karma () +doCmd dk rest = do + sender <- getSender + case words rest of + [] -> say "usage @karma(+|-) nick" + (nick:_) -> do + nick' <- readNick nick + changeKarma dk sender nick' >>= say + +------------------------------------------------------------------------ + +tellKarma :: Nick -> E.Polynick -> Cmd Karma () +tellKarma sender nick = do + lookup' <- lb E.lookupMononickMap + karma <- (sum . map snd . lookup' nick) `fmap` readMS + nickStr <- withMsg (return . flip E.showPolynick nick) + say $ concat [if E.mononickToPolynick sender == nick then "You have" else nickStr ++ " has" + ," a karma of " + ,show karma] + +listKarma :: Cmd Karma () +listKarma = do + ks <- M.toList `fmap` readMS + let ks' = sortBy (\(_,e) (_,e') -> e' `compare` e) ks + flip mapM_ ks' $ \(k,e) -> do + k' <- showNick k + say (printf " %-20s %4d" k' e) + +changeKarma :: Integer -> Nick -> Nick -> Cmd Karma String +changeKarma km sender nick + | map toLower (nName nick) == "java" && km > 0 = do + me <- getLambdabotName + changeKarma (-km) me sender + | sender == nick = return "You can't change your own karma, silly." + | otherwise = do + nickStr <- showNick nick + withMS $ \fm write -> do + let fm' = M.insertWith (+) nick km fm + let karma = fromMaybe 0 $ M.lookup nick fm' + write fm' + return (fmt nickStr km (show karma)) + where + fmt n v k | v < 0 = n ++ "'s karma lowered to " ++ k ++ "." + | v == 0 = n ++ "'s karma unchanged at " ++ k ++ "." + | otherwise = n ++ "'s karma raised to " ++ k ++ "." diff --git a/src/Lambdabot/Plugin/Social/Poll.hs b/src/Lambdabot/Plugin/Social/Poll.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Poll.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE TypeFamilies #-} +-- | Module: Vote +-- | Support for voting +-- | +-- | License: lGPL +-- | +-- | added by Kenneth Hoste (boegel), 22/11/2005 +-- | inspiration: Where plugin (thanks shapr,dons) +module Lambdabot.Plugin.Social.Poll (pollPlugin) where + +import Lambdabot.Plugin +import qualified Data.ByteString.Char8 as P +import Data.List +import qualified Data.Map as M + +newPoll :: Poll +newPoll = (True,[]) + +appendPoll :: String -> Poll -> (Maybe Poll) +appendPoll choice (o,ls) = Just (o,(choice,0):ls) + +voteOnPoll :: Poll -> String -> (Poll,String) +voteOnPoll (o,poll) choice = + if any (\(x,_) -> x == choice) poll + then ((o,map (\(c,n) -> + if c == choice then (c,n+1) + else (c,n)) poll) + ,"voted on " ++ show choice) + else ((o,poll),show choice ++ " is not currently a candidate in this poll") + +------------------------------------------------------------------------ + +type Count = Int +type Candidate = String +type PollName = P.ByteString +type Poll = (Bool, [(Candidate, Count)]) +type VoteState = M.Map PollName Poll +type VoteWriter = VoteState -> Cmd Vote () +type Vote = ModuleT VoteState LB + +------------------------------------------------------------------------ +-- Define a serialiser + +voteSerial :: Serial VoteState +voteSerial = Serial (Just . showPacked) (Just . readPacked) + +------------------------------------------------------------------------ + +pollPlugin :: Module (M.Map PollName Poll) +pollPlugin = newModule + { moduleCmds = return + [ (command "poll-list") + { help = say "poll-list Shows all current polls" + , process = \_ -> do + result <- withMS $ \factFM writer -> processCommand factFM writer "poll-list" [] + say result + } + , (command "poll-show") + { help = say "poll-show Shows all choices for some poll" + , process = process_ "poll-show" + } + , (command "poll-add") + { help = say "poll-add Adds a new poll, with no candidates" + , process = process_ "poll-add" + } + , (command "choice-add") + { help = say "choice-add Adds a new choice to the given poll" + , process = process_ "choice-add" + } + , (command "vote") + -- todo, should @vote foo automagically add foo as a possibility? + { help = say "vote Vote for in " + , process = process_ "vote" + } + , (command "poll-result") + { help = say "poll-result Show result for given poll" + , process = process_ "poll-result" + } + , (command "poll-close") + { help = say "poll-close Closes a poll" + , process = process_ "poll-close" + } + , (command "poll-remove") + { help = say "poll-remove Removes a poll" + , process = process_ "poll-remove" + } + ] + + , moduleDefState = return M.empty + , moduleSerialize = Just voteSerial + } + +process_ :: [Char] -> [Char] -> Cmd Vote () +process_ cmd [] = say ("Missing argument. Check @help " ++ cmd ++ " for info.") +process_ cmd dat = do + result <- withMS $ \fm writer -> processCommand fm writer cmd (words dat) + say result + +------------------------------------------------------------------------ + +processCommand :: VoteState -> VoteWriter -> String -> [String] -> Cmd Vote String +processCommand fm writer cmd dat = case cmd of + + -- show all current polls + "poll-list" -> return $ listPolls fm + + -- show candidates + "poll-show" -> return $ case length dat of + 1 -> showPoll fm (head dat) + _ -> "usage: @poll-show " + + -- declare a new poll + "poll-add" -> case length dat of + 1 -> addPoll fm writer (head dat) + _ -> return "usage: @poll-add with \"ThisTopic\" style names" + + "choice-add" -> case length dat of + 2 -> addChoice fm writer (head dat) (last dat) + _ -> return "usage: @choice-add " + + "vote" -> case length dat of + 2 -> vote fm writer (head dat) (last dat) + _ -> return "usage: @vote " + + "poll-result" -> return $ case length dat of + 1 -> showResult fm (head dat) + _ -> "usage: @poll-result " + + "poll-close" -> case length dat of + 1 -> closePoll fm writer (head dat) + _ -> return "usage: @poll-close " + + "poll-remove" -> case length dat of + 1 -> removePoll fm writer (head dat) + _ -> return "usage: @poll-remove " + + _ -> return "Unknown command." + +------------------------------------------------------------------------ + +listPolls :: VoteState -> String +listPolls fm = show $ map fst (M.toList fm) + +showPoll :: VoteState -> String -> String +showPoll fm poll = + case M.lookup (P.pack poll) fm of + Nothing -> "No such poll: " ++ show poll ++ " Use @poll-list to see the available polls." + Just p -> show $ map fst (snd p) + +addPoll :: VoteState -> VoteWriter -> String -> Cmd Vote String +addPoll fm writer poll = + case M.lookup (P.pack poll) fm of + Nothing -> do writer $ M.insert (P.pack poll) newPoll fm + return $ "Added new poll: " ++ show poll + Just _ -> return $ "Poll " ++ show poll ++ + " already exists, choose another name for your poll" + +addChoice :: VoteState -> VoteWriter -> String -> String -> Cmd Vote String +addChoice fm writer poll choice = case M.lookup (P.pack poll) fm of + Nothing -> return $ "No such poll: " ++ show poll + Just _ -> do writer $ M.update (appendPoll choice) (P.pack poll) fm + return $ "New candidate " ++ show choice ++ + ", added to poll " ++ show poll ++ "." + +vote :: VoteState -> VoteWriter -> String -> String -> Cmd Vote String +vote fm writer poll choice = case M.lookup (P.pack poll) fm of + Nothing -> return $ "No such poll:" ++ show poll + Just (False,_) -> return $ "The "++ show poll ++ " poll is closed, sorry !" + Just p@(True,_) -> do let (np,msg) = voteOnPoll p choice + writer $ M.update (const (Just np)) (P.pack poll) fm + return msg + +showResult :: VoteState -> String -> String +showResult fm poll = case M.lookup (P.pack poll) fm of + Nothing -> "No such poll: " ++ show poll + Just (o,p) -> "Poll results for " ++ poll ++ " (" ++ (status o) ++ "): " + ++ (concat $ intersperse ", " $ map ppr p) + where + status s | s = "Open" + | otherwise = "Closed" + ppr (x,y) = x ++ "=" ++ show y + +removePoll :: VoteState -> VoteWriter -> String -> Cmd Vote String +removePoll fm writer poll = case M.lookup (P.pack poll) fm of + Just (True,_) -> return "Poll should be closed before you can remove it." + Just (False,_) -> do writer $ M.delete (P.pack poll) fm + return $ "poll " ++ show poll ++ " removed." + Nothing -> return $ "No such poll: " ++ show poll + +closePoll :: VoteState -> VoteWriter -> String -> Cmd Vote String +closePoll fm writer poll = case M.lookup (P.pack poll) fm of + Nothing -> return $ "No such poll: " ++ show poll + Just (_,p) -> do writer $ M.update (const (Just (False,p))) (P.pack poll) fm + return $ "Poll " ++ show poll ++ " closed." diff --git a/src/Lambdabot/Plugin/Social/Seen.hs b/src/Lambdabot/Plugin/Social/Seen.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Seen.hs @@ -0,0 +1,332 @@ +-- Copyright (c) 2004 Thomas Jaeger +-- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) + +-- | Keep track of IRC users. +module Lambdabot.Plugin.Social.Seen (seenPlugin) where + +import Lambdabot.Bot +import Lambdabot.Compat.AltTime +import Lambdabot.Compat.PackedNick +import Lambdabot.IRC +import Lambdabot.Logging +import qualified Lambdabot.Message as G +import Lambdabot.Nick +import Lambdabot.Plugin +import Lambdabot.Util + +import Lambdabot.Plugin.Social.Seen.StopWatch +import Lambdabot.Plugin.Social.Seen.UserStatus + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Data.Binary +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.List +import qualified Data.Map as M +import Text.Printf + +type SeenState = (MaxMap, SeenMap) +type SeenMap = M.Map PackedNick UserStatus +type MaxMap = M.Map Channel Int + +type Seen = ModuleT SeenState LB + +------------------------------------------------------------------------ + +seenPlugin :: Module (M.Map Channel Int, M.Map PackedNick UserStatus) +seenPlugin = newModule + { moduleDefState = return (M.empty,M.empty) + + , moduleCmds = return + [ (command "users") + { help = say "users [chan]. Report the maximum number of users seen in a channel, and active users in the last 30 minutes" + , process = doUsers + } + , (command "seen") + { help = say "seen . Report if a user has been seen by the bot" + , process = doSeen + } + ] + + , moduleInit = do + sequence_ + [ ircSignalConnect signal =<< bindModule1 (withSeenFM cb) + | (signal, cb) <- zip + ["JOIN", "PART", "QUIT", "NICK", "353", "PRIVMSG"] + [joinCB, partCB, quitCB, nickCB, joinChanCB, msgCB] + ] + + c <- lb $ findOrCreateLBFile "seen" + s <- io $ P.readFile c + let ls = L.fromChunks [s] + mbDecoded <- io . try . evaluate $ decode ls + case mbDecoded of + Left exc@SomeException{} -> do + -- try reading the old format (slightly different type... oh, "binary"...) + mbOld <- io . try . evaluate $ decode ls + case mbOld of + Left SomeException{} -> + warningM ("WARNING: failed to read Seen module state: " ++ show exc) + Right (maxMap, seenMap) -> + writeMS (M.mapKeys P.pack maxMap, seenMap) + Right decoded -> writeMS decoded + + , moduleExit = do + chans <- lift $ ircGetChannels + unless (null chans) $ do + ct <- io getClockTime + modifyMS $ \(n,m) -> (n, botPart ct (map packNick chans) m) + + -- and write out our state: + withMS $ \s _ -> lb (findOrCreateLBFile "seen") >>= \ c -> io (encodeFile c s) + } + +lcNick :: Nick -> Nick +lcNick (Nick svr nck) = Nick svr (map toLower nck) + +------------------------------------------------------------------------ + +doUsers :: String -> Cmd Seen () +doUsers rest = withMsg $ \msg -> do + -- first step towards tracking the maximum number of users + chan <- getTarget + (m, seenFM) <- readMS + s <- io getClockTime + let who = packNick $ lcNick $ if null rest then chan else parseNick (G.server msg) rest + now = length [ () | (_,Present _ chans) <- M.toList seenFM + , who `elem` chans ] + + n = case M.lookup who m of Nothing -> 1; Just n' -> n' + + active = length [() | (_,st@(Present _ chans)) <- M.toList seenFM + , who `elem` chans && isActive st ] + + isActive (Present (Just (ct,_td)) _cs) = recent ct + isActive _ = False + + recent t = diffClockTimes s t < gap_minutes + gap_minutes = TimeDiff 1800 -- 30 minutes + + percent p q = 100 * (fromIntegral p / fromIntegral q) :: Double + + total 0 0 = "0" + total p q = printf "%d (%0.1f%%)" p (percent p q) + + say $! printf "Maximum users seen in %s: %d, currently: %s, active: %s" + (fmtNick (G.server msg) $ unpackNick who) n (total now n) (total active now) + +doSeen :: String -> Cmd Seen () +doSeen rest = withMsg $ \msg -> do + target <- getTarget + (_,seenFM) <- readMS + now <- io getClockTime + let (txt,safe) = (getAnswer msg rest seenFM now) + if safe || not ("#" `isPrefixOf` nName target) + then mapM_ say txt + else lb (ircPrivmsg (G.nick msg) (unlines txt)) + +getAnswer :: G.Message a => a -> String -> SeenMap -> ClockTime -> ([String], Bool) +getAnswer msg rest seenFM now + | null nick' = + let people = map fst $ filter isActive $ M.toList seenFM + isActive (_nick,state) = case state of + (Present (Just (ct,_td)) _cs) -> recent ct + _ -> False + recent t = diffClockTimes now t < gap_minutes + gap_minutes = TimeDiff 900 -- 15 minutes + in (["Lately, I have seen " ++ (if null people then "nobody" + else listToStr "and" (map upAndShow people)) ++ "."], False) + + | pnick == G.lambdabotName msg = + case M.lookup (packNick pnick) seenFM of + Just (Present _ cs) -> + (["Yes, I'm here. I'm in " ++ listToStr "and" (map upAndShow cs)], True) + _ -> error "I'm here, but not here. And very confused!" + + | head (nName pnick) == '#' = + let people = map fst $ filter inChan $ M.toList seenFM + inChan (_nick,state) = case state of + (Present (Just _) cs) + -> packNick pnick `elem` cs + _ -> False + in (["In "++nick'++" I can see " + ++ (if null people then "nobody" -- todo, how far back does this go? + else listToStr "and" (map upAndShow people)) ++ "."], False) + + | otherwise = (return $ concat (case M.lookup (packNick pnick) seenFM of + Just (Present mct cs) -> nickPresent mct (map upAndShow cs) + Just (NotPresent ct td chans) -> nickNotPresent ct td (map upAndShow chans) + Just (WasPresent ct sw _ chans) -> nickWasPresent ct sw (map upAndShow chans) + Just (NewNick newnick) -> nickIsNew newnick + _ -> ["I haven't seen ", nick, "."]), True) + where + -- I guess the only way out of this spagetty hell are printf-style responses. + upAndShow = fmtNick (G.server msg) . unpackNick + nickPresent mct cs = + [ if you then "You are" else nick ++ " is" + , " in ", listToStr "and" cs, "." + , case mct of + Nothing -> concat [" I don't know when ", nick, " last spoke."] + Just (ct,missed) -> prettyMissed (Stopped missed) + (concat [" I last heard ", nick, " speak ", + lastSpoke {-, ", but "-}]) + (" Last spoke " ++ lastSpoke) + where lastSpoke = clockDifference ct + ] + nickNotPresent ct missed chans = + [ "I saw ", nick, " leaving ", listToStr "and" chans, " " + , clockDifference ct, prettyMissed missed ", and " "" + ] + nickWasPresent ct sw chans = + [ "Last time I saw ", nick, " was when I left " + , listToStr "and" chans , " ", clockDifference ct + , prettyMissed sw ", and " "" + ] + nickIsNew newnick = + [ if you then "You have" else nick++" has" + , " changed nick to ", us, "." + ] ++ fst (getAnswer msg us seenFM now) + where + us = upAndShow $ findFunc newnick + findFunc pstr = case M.lookup pstr seenFM of + Just (NewNick pstr') -> findFunc pstr' + Just _ -> pstr + Nothing -> error "SeenModule.nickIsNew: Nothing" + + nick' = takeWhile (not . isSpace) rest + you = pnick == lcNick (G.nick msg) + nick = if you then "you" else nick' + pnick = lcNick $ parseNick (G.server msg) nick' + clockDifference past + | all (==' ') diff = "just now" + | otherwise = diff ++ " ago" + where diff = timeDiffPretty . diffClockTimes now $ past + + prettyMissed (Stopped _) _ifMissed _ = "." -- ifMissed ++ "." + prettyMissed _ _ _ifNotMissed = "." -- ifNotMissed ++ "." + +{- + prettyMissed (Stopped missed) ifMissed _ + | missedPretty <- timeDiffPretty missed + , any (/=' ') missedPretty + = concat [ifMissed, "I have missed ", missedPretty, " since then."] + + prettyMissed _ _ ifNotMissed = ifNotMissed ++ "." +-} + +-- | extract channels from message as packed, lower cased, strings. +msgChans :: G.Message a => a -> [Channel] +msgChans = map (packNick . lcNick) . G.channels + +-- | Callback for when somebody joins. If it is not the bot that joins, record +-- that we have a new user in our state tree and that we have never seen the +-- user speaking. +joinCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap +joinCB msg _ct nick fm + | nick == lbNick = Right fm + | otherwise = Right $! insertUpd (updateJ Nothing chans) nick newInfo fm + where + insertUpd f = M.insertWith (\_ -> f) + lbNick = packNick $ G.lambdabotName msg + newInfo = Present Nothing chans + chans = msgChans msg + +-- | Update the state to reflect the bot leaving channel(s) +botPart :: ClockTime -> [Channel] -> SeenMap -> SeenMap +botPart ct cs = fmap botPart' + where + botPart' (Present mct xs) = case xs \\ cs of + [] -> WasPresent ct (startWatch ct zeroWatch) mct cs + ys -> Present mct ys + botPart' (NotPresent ct' missed c) + | head c `elem` cs = NotPresent ct' (startWatch ct missed) c + botPart' (WasPresent ct' missed mct c) + | head c `elem` cs = WasPresent ct' (startWatch ct missed) mct c + botPart' us = us + +-- | when somebody parts +partCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap +partCB msg ct nick fm + | nick == lbNick = Right $ botPart ct (msgChans msg) fm + | otherwise = case M.lookup nick fm of + Just (Present mct xs) -> + case xs \\ (msgChans msg) of + [] -> Right $! M.insert nick (NotPresent ct zeroWatch xs) fm + ys -> Right $! M.insert nick (Present mct ys) fm + _ -> Left "someone who isn't known parted" + where lbNick = packNick $ G.lambdabotName msg + +-- | when somebody quits +quitCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap +quitCB _ ct nick fm = case M.lookup nick fm of + Just (Present _ct xs) -> Right $! M.insert nick (NotPresent ct zeroWatch xs) fm + _ -> Left "someone who isn't known has quit" + +-- | when somebody changes his\/her name +nickCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap +nickCB msg _ nick fm = case M.lookup nick fm of + Just status -> Right $! M.insert lcnewnick status + $ M.insert nick (NewNick lcnewnick) fm + _ -> Left "someone who isn't here changed nick" + where + newnick = drop 1 $ head (ircMsgParams msg) + lcnewnick = packNick $ lcNick $ parseNick (G.server msg) newnick + +-- | when the bot joins a channel +joinChanCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap +joinChanCB msg now _nick fm + = Right $! fmap (updateNP now chan) (foldl insertNick fm chanUsers) + where + l = ircMsgParams msg + chan = packNick $ lcNick $ parseNick (G.server msg) $ l !! 2 + chanUsers = map (packNick . lcNick . parseNick (G.server msg)) $ words (drop 1 (l !! 3)) -- remove ':' + unUserMode nick = Nick (nTag nick) (dropWhile (`elem` "@+") $ nName nick) + insertUpd f = M.insertWith (\_ -> f) + insertNick fm' u = insertUpd (updateJ (Just now) [chan]) + (packNick . unUserMode . lcNick . unpackNick $ u) + (Present Nothing [chan]) fm' + +-- | when somebody speaks, update their clocktime +msgCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap +msgCB _ ct nick fm = + case M.lookup nick fm of + Just (Present _ xs) -> Right $! + M.insert nick (Present (Just (ct, noTimeDiff)) xs) fm + _ -> Left "someone who isn't here msg us" + + +-- | Callbacks are only allowed to use a limited knowledge of the world. +-- 'withSeenFM' is (up to trivial isomorphism) a monad morphism from the +-- restricted +-- 'ReaderT (IRC.Message, ClockTime, Nick) (StateT SeenState (Error String))' +-- to the +-- 'ReaderT IRC.Message (Seen IRC)' +-- monad. +withSeenFM :: G.Message a + => (a -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap) + -> (a -> Seen ()) + +withSeenFM f msg = do + let chan = packNick . lcNick . head . G.channels $! msg + nick = packNick . lcNick . G.nick $ msg + + withMS $ \(maxUsers,state) writer -> do + ct <- io getClockTime + case f msg ct nick state of + Left _ -> return () + Right newstate -> do + let curUsers = length $! + [ () | (_,Present _ chans) <- M.toList state + , chan `elem` chans ] + + newMax = case M.lookup chan maxUsers of + Nothing -> M.insert chan curUsers maxUsers + Just n -> if n < curUsers + then M.insert chan curUsers maxUsers + else maxUsers + + newMax `seq` newstate `seq` writer (newMax, newstate) diff --git a/src/Lambdabot/Plugin/Social/Seen/StopWatch.hs b/src/Lambdabot/Plugin/Social/Seen/StopWatch.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Seen/StopWatch.hs @@ -0,0 +1,30 @@ +module Lambdabot.Plugin.Social.Seen.StopWatch where + +import Lambdabot.Compat.AltTime + +import Data.Binary + +data StopWatch + = Stopped !TimeDiff + | Running !ClockTime + deriving (Show,Read) + +instance Binary StopWatch where + put (Stopped td) = putWord8 0 >> put td + put (Running ct) = putWord8 1 >> put ct + + get = getWord8 >>= \h -> case h of + 0 -> fmap Stopped get + 1 -> fmap Running get + _ -> error "Seen.StopWatch.get" + +zeroWatch :: StopWatch +zeroWatch = Stopped noTimeDiff + +startWatch :: ClockTime -> StopWatch -> StopWatch +startWatch now (Stopped td) = Running (td `addToClockTime` now) +startWatch _ alreadyStarted = alreadyStarted + +stopWatch :: ClockTime -> StopWatch -> StopWatch +stopWatch now (Running t) = Stopped (t `diffClockTimes` now) +stopWatch _ alreadyStopped = alreadyStopped diff --git a/src/Lambdabot/Plugin/Social/Seen/UserStatus.hs b/src/Lambdabot/Plugin/Social/Seen/UserStatus.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Seen/UserStatus.hs @@ -0,0 +1,77 @@ +module Lambdabot.Plugin.Social.Seen.UserStatus where + +import Control.Applicative +import Data.Binary +import qualified Data.ByteString as BS +import Data.List +import Lambdabot.Compat.AltTime +import Lambdabot.Compat.PackedNick +import Lambdabot.Plugin.Social.Seen.StopWatch + +-- | The type of channels +type Channel = BS.ByteString + +-- | We last heard the user speak at ClockTime; since then we have missed +-- TimeDiff of him because we were absent. +type LastSpoke = Maybe (ClockTime, TimeDiff) + +-- | 'UserStatus' keeps track of the status of a given Nick name. +data UserStatus + = Present !LastSpoke [Channel] + -- ^ Records when the nick last spoke and that the nick is currently + -- in [Channel]. + | NotPresent !ClockTime !StopWatch [Channel] + -- ^ The nick is not present and was last seen at ClockTime in Channel. + -- The second argument records how much we've missed. + | WasPresent !ClockTime !StopWatch !LastSpoke [Channel] + -- ^ The bot parted a channel where the user was. The Clocktime + -- records the time and Channel the channel this happened in. + -- We also save the reliablility of our information and the + -- time we last heard the user speak. + | NewNick !PackedNick + -- ^ The user changed nick to something new. + deriving (Show, Read) + +instance Binary UserStatus where + put (Present sp ch) = putWord8 0 >> put sp >> put ch + put (NotPresent ct sw ch) = putWord8 1 >> put ct >> put sw >> put ch + put (WasPresent ct sw sp ch) = putWord8 2 >> put ct >> put sw >> put sp >> put ch + put (NewNick n) = putWord8 3 >> put n + + get = getWord8 >>= \h -> case h of + 0 -> Present <$> get <*> get + 1 -> NotPresent <$> get <*> get <*> get + 2 -> WasPresent <$> get <*> get <*> get <*> get + 3 -> NewNick <$> get + _ -> error "Seen.UserStatus.get" + +-- | Update the user status when a user joins a channel. +updateJ :: Maybe ClockTime -- ^ If the bot joined the channel, the time that + -- happened, i.e. now. + -> [Channel] -- ^ The channels the user joined. + -> UserStatus -- ^ The old status + -> UserStatus -- ^ The new status +-- The user was present before, so he's present now. +updateJ _ c (Present ct cs) = Present ct $ nub (c ++ cs) +-- The user was present when we left that channel and now we've come back. +-- We need to update the time we've missed. +updateJ (Just now) cs (WasPresent lastSeen _ (Just (lastSpoke, missed)) channels) + | head channels `elem` cs + --- newMissed + --- |---------------------------------------| + --- |-------------------| | + --- missed lastSeen now + = let newMissed = addToClockTime missed now `diffClockTimes` lastSeen + in newMissed `seq` Present (Just (lastSpoke, newMissed)) cs +-- Otherwise, we create a new record of the user. +updateJ _ cs _ = Present Nothing cs + +-- | Update a user who is not present. We just convert absolute missing time +-- into relative time (i.e. start the "watch"). +updateNP :: ClockTime -> Channel -> UserStatus -> UserStatus +updateNP now _ (NotPresent ct missed c) + = NotPresent ct (stopWatch now missed) c +-- The user might be gone, thus it's meaningless when we last heard him speak. +updateNP now chan (WasPresent lastSeen missed _ cs) + | head cs == chan = WasPresent lastSeen (stopWatch now missed) Nothing cs +updateNP _ _ status = status diff --git a/src/Lambdabot/Plugin/Social/Tell.hs b/src/Lambdabot/Plugin/Social/Tell.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Social/Tell.hs @@ -0,0 +1,296 @@ +{- Leave a message with lambdabot, the faithful secretary + +> 17:11 < davidhouse> @tell dmhouse foo +> 17:11 < hsbot> Consider it noted +> 17:11 < davidhouse> @tell dmhouse bar +> 17:11 < hsbot> Consider it noted +> 17:11 < dmhouse> hello! +> 17:11 < hsbot> dmhouse: You have 2 new messages. '/msg hsbot @messages' to read them. +> 17:11 < dmhouse> Notice how I'm speaking again, and hsbot isn't buzzing me more than that one time. +> 17:12 < dmhouse> It'll buzz me after a day's worth of not checking my messages. +> 17:12 < dmhouse> If I want to check them in the intermittent period, I can either send a /msg, or: +> 17:12 < dmhouse> @messages? +> 17:12 < hsbot> You have 2 messages +> 17:12 < dmhouse> Let's check them, shall we? +> +> [In a /msg to hsbot] +> 17:12 davidhouse said less than a minute ago: foo +> 17:12 davidhouse said less than a minute ago: bar +> +> [Back in the channel +> 17:12 < dmhouse> You needn't use a /msg, however. If you're not going to annoy the channel by printing 20 of +> your messages, feel free to just type '@messages' in the channel. +> 17:12 < davidhouse> @tell dmhouse foobar +> 17:12 < hsbot> Consider it noted +> 17:12 < davidhouse> @ask dmhouse barfoo +> 17:12 < hsbot> Consider it noted +> 17:12 < davidhouse> You can see there @ask. It's just a synonym for @tell, but it prints "foo asked X ago M", +> which is more natural. E.g. '@ask dons whether he's applied my latest patch yet?' +> 17:13 < dmhouse> For the admins, a useful little debugging tool is @print-notices. +> 17:13 < hsbot> dmhouse: You have 2 new messages. '/msg hsbot @messages' to read them. +> 17:14 < dmhouse> Notice that hsbot pinged me there, even though it's less than a day since I last checked my +> messages, because there have been some new ones posted. +> 17:14 < dmhouse> @print-notices +> 17:14 < hsbot> {"dmhouse":=(Just Thu Jun 8 17:13:46 BST 2006,[Note {noteSender = "davidhouse", noteContents = +> "foobar", noteTime = Thu Jun 8 17:12:50 BST 2006, noteType = Tell},Note {noteSender = + "davidhouse", noteContents = "barfoo", noteTime = Thu Jun 8 17:12:55 BST 2006, noteType = Ask}])} +> 17:15 < dmhouse> There you can see the two notes. The internal state is a map from recipient nicks to a pair of +> (when we last buzzed them about having messages, a list of the notes they've got stacked up). +> 17:16 < dmhouse> Finally, if you don't want to bother checking your messages, then the following command will +> likely be useful. +> 17:16 < dmhouse> @clear-messages +> 17:16 < hsbot> Messages cleared. +> 17:16 < dmhouse> That's all, folks! +> 17:17 < dmhouse> Any comments, queries or complaints to dmhouse@gmail.com. The source should be fairly readable, so +> hack away! +-} + +module Lambdabot.Plugin.Social.Tell (tellPlugin) where + +import Lambdabot.Compat.AltTime +import Lambdabot.Compat.FreenodeNick +import Lambdabot.Plugin +import Lambdabot.Util + +import Control.Monad +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Text.Printf (printf) + +-- | Was it @tell or @ask that was the original command? +data NoteType = Tell | Ask deriving (Show, Eq, Read) +-- | The Note datatype. Fields self-explanatory. +data Note = Note { noteSender :: FreenodeNick, + noteContents :: String, + noteTime :: ClockTime, + noteType :: NoteType } + deriving (Eq, Show, Read) +-- | The state. A map of (times we last told this nick they've got messages, the +-- messages themselves, the auto-reply) +type NoticeEntry = (Maybe ClockTime, [Note], Maybe String) +type NoticeBoard = M.Map FreenodeNick NoticeEntry + +type Tell = ModuleT NoticeBoard LB + +tellPlugin :: Module NoticeBoard +tellPlugin = newModule + { moduleCmds = return + [ (command "tell") + { help = say "tell . When shows activity, tell them ." + , process = doTell Tell . words + } + , (command "ask") + { help = say "ask . When shows activity, ask them ." + , process = doTell Ask . words + } + , (command "messages") + { help = say "messages. Check your messages, responding in private." + , process = const (doMessages False) + } + , (command "messages-loud") + { help = say "messages. Check your messages, responding in public." + , process = const (doMessages True) + } + , (command "messages?") + { help = say "messages?. Tells you whether you have any messages" + , process = const $ do + sender <- getSender + ms <- getMessages sender + case ms of + Just _ -> doRemind sender say + Nothing -> say "Sorry, no messages today." + } + , (command "clear-messages") + { help = say "clear-messages. Clears your messages." + , process = const $ do + sender <- getSender + clearMessages sender + say "Messages cleared." + } + , (command "auto-reply") + { help = say "auto-reply. Lets lambda-bot auto-reply if someone sends you a message" + , process = doAutoReply + } + , (command "auto-reply?") + { help = say "auto-reply?. Tells you your auto-reply status" + , process = const $ do + sender <- getSender + a <- getAutoReply sender + case a of + Just s -> say $ "Your auto-reply is \"" ++ s ++ "\"." + Nothing -> say "You do not have an auto-reply message set." + } + , (command "clear-auto-reply") + { help = say "clear-auto-reply. Clears your auto-reply message." + , process = const $ do + sender <- getSender + clearAutoReply sender + say "Auto-reply message cleared." + } + , (command "print-notices") + { privileged = True + , help = say "print-notices. Print the current map of notes." + , process = const ((say . show) =<< readMS) + } + , (command "purge-notices") + { privileged = True + , help = say $ + "purge-notices [ [ [ ...]]]]. " + ++ "Clear all notes for specified nicks, or all notices if you don't " + ++ "specify a nick." + , process = \args -> do + users <- mapM readNick (words args) + if null users + then writeMS M.empty + else mapM_ clearMessages users + say "Messages purged." + } + ] + , moduleDefState = return M.empty + , moduleSerialize = Just mapSerial + -- Hook onto contextual. Grab nicks of incoming messages, and tell them + -- if they have any messages, if it's less than a day since we last did so. + , contextual = const $ do + sender <- getSender + remp <- needToRemind sender + if remp + then doRemind sender (lb . ircPrivmsg sender) + else return () + } + +-- | Take a note and the current time, then display it +showNote :: ClockTime -> Note -> Cmd Tell String +showNote time note = do + sender <- showNick (getFreenodeNick (noteSender note)) + let diff = time `diffClockTimes` noteTime note + ago = case timeDiffPretty diff of + [] -> "less than a minute" + pr -> pr + action = case noteType note of Tell -> "said"; Ask -> "asked" + return $ printf "%s %s %s ago: %s" sender action ago (noteContents note) + +-- | Is it less than a day since we last reminded this nick they've got messages? +needToRemind :: Nick -> Cmd Tell Bool +needToRemind n = do + st <- readMS + now <- io getClockTime + return $ case M.lookup (FreenodeNick n) st of + Just (Just lastTime, _, _) -> + let diff = now `diffClockTimes` lastTime + in diff > TimeDiff 86400 + Just (Nothing, _, _) -> True + Nothing -> True + +-- | Add a note to the NoticeBoard +writeDown :: Nick -> Nick -> String -> NoteType -> Cmd Tell () +writeDown to from what ntype = do + time <- io getClockTime + let note = Note { noteSender = FreenodeNick from, + noteContents = what, + noteTime = time, + noteType = ntype } + modEntry to $ \(_, ns, a) -> (Nothing, ns ++ [note], a) + +-- | Return a user's notes, or Nothing if they don't have any +getMessages :: Nick -> Cmd Tell (Maybe [Note]) +getMessages sender = do + st <- readMS + return $ case M.lookup (FreenodeNick sender) st of + Nothing -> Nothing + Just (_, [], _) -> Nothing + Just (_, ns, _) -> Just ns + +-- | Clear a user's messages. +clearMessages :: Nick -> Cmd Tell () +clearMessages sender = modEntry sender $ \(_, _, a) -> (Nothing, [], a) + +-- | Sets a user's auto-reply message +setAutoReply :: Nick -> String -> Cmd Tell () +setAutoReply sender msg = modEntry sender $ \(t, ns, _) -> (t, ns, Just msg) + +-- | Gets a user's auto-reply message +getAutoReply :: Nick -> Cmd Tell (Maybe String) +getAutoReply sender = fmap (join . fmap (\(_,_,a) -> a) . M.lookup (FreenodeNick sender)) readMS + +-- | Clears the auto-reply message +clearAutoReply :: Nick -> Cmd Tell () +clearAutoReply sender = modEntry sender $ \(t, ns, _) -> (t, ns, Nothing) + +-- | Modifies an entry, taking care of missing entries and cleaning up empty entries. +-- (We consider an entry empty even if it still has a timestamp.) +modEntry :: Nick -> (NoticeEntry -> NoticeEntry) -> Cmd Tell () +modEntry sender f = modifyMS $ M.alter (cleanup . f . fromMaybe empty) (FreenodeNick sender) + where empty = (Nothing, [], Nothing) + cleanup (_, [], Nothing) = Nothing + cleanup e = Just e + +-- * Handlers +-- + +-- | Give a user their messages +doMessages :: Bool -> Cmd Tell () +doMessages loud = do + sender <- getSender + msgs <- getMessages sender + clearMessages sender + + let tellNote = if loud + then say + else lb . ircPrivmsg sender + + case msgs of + Nothing -> say "You don't have any messages" + Just mesgs -> do + time <- io getClockTime + mapM_ (showNote time >=> tellNote) mesgs + +verb :: NoteType -> String +verb Ask = "ask" +verb Tell= "tell" + +-- | Execute a @tell or @ask command. +doTell :: NoteType -> [String] -> Cmd Tell () +doTell ntype [] = say ("Who should I " ++ verb ntype ++ "?") +doTell ntype (who':args) = do + let who = dropFromEnd (== ':') who' + recipient <- readNick who + sender <- getSender + me <- getLambdabotName + let rest = unwords args + (record, res) + | sender == recipient = (False, "You can " ++ verb ntype ++ " yourself!") + | recipient == me = (False, "Nice try ;)") + | null args = (False, "What should I " ++ verb ntype ++ " " ++ who ++ "?") + | otherwise = (True, "Consider it noted.") + when record $ do + autoReply <- getAutoReply recipient + case autoReply of + Nothing -> return () + Just s -> say $ who ++ " lets you know: " ++ s + writeDown recipient sender rest ntype + say res + +-- | Execute a @auto-reply +doAutoReply :: String -> Cmd Tell () +doAutoReply "" = say "No auto-reply message given. Did you mean @clear-auto-reply?" +doAutoReply msg = do + sender <- getSender + setAutoReply sender msg + say "Auto-Reply messages noted. You can check the status with auto-reply? and clear it with clear-auto-reply." + +-- | Remind a user that they have messages. +doRemind :: Nick -> (String -> Cmd Tell ()) -> Cmd Tell () +doRemind sender remind = do + ms <- getMessages sender + now <- io getClockTime + modEntry sender $ \(_,ns,a) -> (Just now, ns, a) + case ms of + Just msgs -> do + me <- showNick =<< getLambdabotName + let n = length msgs + (messages, pronoun) + | n > 1 = ("messages", "them") + | otherwise = ("message", "it") + remind $ printf "You have %d new %s. '/msg %s @messages' to read %s." + n messages me pronoun + Nothing -> return () diff --git a/src/Lambdabot/Util/NickEq.hs b/src/Lambdabot/Util/NickEq.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Util/NickEq.hs @@ -0,0 +1,59 @@ +-- +-- | Nickname equality subsystem. +-- +-- This component is responsible for deciding whether two nicknames +-- refer to the same person, for the purposes of @tell et al. Nickname +-- equality must be monadic because it uses mutable state maintained +-- by the @link and @unlink commands. +-- +-- Also provided is a concept of polynicks (by analogy to polytypes); +-- polynicks can refer to an (open) set of nicknames. For instance '@tell +-- *lambdabot Why does X do Y' could tell a message to anyone who has +-- identified as a lambdabot maintainer. A polynick consists of a +-- bar-separated list of (nicks or open terms); an open term is like a +-- nick but preceded with a star. + +module Lambdabot.Util.NickEq + ( Polynick + , nickMatches + , readPolynick + , showPolynick + + , lookupMononickMap + , mononickToPolynick + ) where + +import Lambdabot.Message +import Lambdabot.Monad +import Lambdabot.Nick + +import Data.List (intercalate) +import Data.List.Split (splitOn) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) + +data Polynick = Polynick [Nick] deriving (Eq) -- for now + +-- |Determine if a nick matches a polynick. The state is read at the +-- point of binding. +nickMatches :: LB (Nick -> Polynick -> Bool) +nickMatches = return m' + where + m' nck (Polynick nck2) = nck `elem` nck2 + +-- | Parse a read polynick. +readPolynick :: Message a => a -> String -> Polynick +readPolynick m = Polynick . map (parseNick (server m)) . splitOn "|" + +-- | Format a polynick. +showPolynick :: Message a => a -> Polynick -> String +showPolynick m (Polynick n) = intercalate "|" $ map (fmtNick (server m)) n + +-- | Convert a regular mononick into a polynick. +mononickToPolynick :: Nick -> Polynick +mononickToPolynick = Polynick . (:[]) + +-- | Lookup (using a polynick) in a map keyed on mononicks. +lookupMononickMap :: LB (Polynick -> M.Map Nick a -> [(Nick,a)]) +lookupMononickMap = return $ look' + where look' (Polynick ns) m = mapMaybe (\n -> (,) n `fmap` M.lookup n m) ns