lambdabot-social-plugins-5.1/0000755000000000000000000000000012722676543014437 5ustar0000000000000000lambdabot-social-plugins-5.1/LICENSE0000644000000000000000000000225612722676543015451 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-social-plugins-5.1/lambdabot-social-plugins.cabal0000644000000000000000000000447012722676543022304 0ustar0000000000000000name: lambdabot-social-plugins version: 5.1 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.8.4, GHC == 7.10.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.1 && < 5.2, mtl >= 2, split >= 0.2, time >= 1.4 lambdabot-social-plugins-5.1/Setup.hs0000644000000000000000000000014212722676543016070 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-social-plugins-5.1/src/0000755000000000000000000000000012722676543015226 5ustar0000000000000000lambdabot-social-plugins-5.1/src/Lambdabot/0000755000000000000000000000000012722676543017113 5ustar0000000000000000lambdabot-social-plugins-5.1/src/Lambdabot/Util/0000755000000000000000000000000012722676543020030 5ustar0000000000000000lambdabot-social-plugins-5.1/src/Lambdabot/Util/NickEq.hs0000644000000000000000000000370412722676543021542 0ustar0000000000000000-- -- | 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 lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/0000755000000000000000000000000012722676543020351 5ustar0000000000000000lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social.hs0000644000000000000000000000066112722676543022122 0ustar0000000000000000module 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"] lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/0000755000000000000000000000000012722676543021563 5ustar0000000000000000lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Activity.hs0000644000000000000000000000350412722676543023715 0ustar0000000000000000-- | Logging an IRC channel.. module Lambdabot.Plugin.Social.Activity (activityPlugin) where import Lambdabot.Monad 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 = registerOutputFilter activityFilter , 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 lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Seen.hs0000644000000000000000000003310512722676543023013 0ustar0000000000000000-- 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.Monad 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_ [ registerCallback signal (withSeenFM cb) | (signal, cb) <- zip ["JOIN", "PART", "QUIT", "NICK", "353", "PRIVMSG"] [joinCB, partCB, quitCB, nickCB, joinChanCB, msgCB] ] c <- lb $ findLBFileForReading "seen" s <- maybe (return (P.pack "")) (io . P.readFile) c let ls = L.fromStrict 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 (findLBFileForWriting "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) lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Tell.hs0000644000000000000000000003123312722676543023021 0ustar0000000000000000{- 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 -- | Set a user's messages. setMessages :: Nick -> [Note] -> Cmd Tell () setMessages sender msgs = modEntry sender $ \(t, _, a) -> (t, msgs, a) -- | 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 let tellNote = if loud then say else lb . ircPrivmsg sender let loop [] = clearMessages sender loop (msg : msgs) = do time <- io getClockTime -- Note that 'showNote' may block and thus run into a timeout. -- Hence we update the list of pending messages after each message. showNote time msg >>= tellNote setMessages sender msgs loop msgs case msgs of Nothing -> say "You don't have any messages" Just msgs -> loop msgs 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 () lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Poll.hs0000644000000000000000000001736612722676543023042 0ustar0000000000000000{-# 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." lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Karma.hs0000644000000000000000000000752012722676543023156 0ustar0000000000000000-- | 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 ++ "." lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Seen/0000755000000000000000000000000012722676543022455 5ustar0000000000000000lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Seen/UserStatus.hs0000644000000000000000000000667512722676543025151 0ustar0000000000000000module 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 lambdabot-social-plugins-5.1/src/Lambdabot/Plugin/Social/Seen/StopWatch.hs0000644000000000000000000000147312722676543024732 0ustar0000000000000000module 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