lambdabot-social-plugins 5.3 → 5.3.0.2
raw patch · 3 files changed
+110/−71 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- lambdabot-social-plugins.cabal +3/−3
- src/Lambdabot/Plugin/Social/Poll.hs +93/−59
- src/Lambdabot/Plugin/Social/Seen.hs +14/−9
lambdabot-social-plugins.cabal view
@@ -1,11 +1,11 @@ name: lambdabot-social-plugins-version: 5.3+version: 5.3.0.2 license: GPL license-file: LICENSE author: Don Stewart-maintainer: James Cook <mokus@deepbondi.net>+maintainer: Bertram Felgenhauer <int-e@gmx.de> category: Development, Web synopsis: Social plugins for Lambdabot@@ -28,7 +28,7 @@ build-type: Simple cabal-version: >= 1.10-tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3+tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4 source-repository head type: git
src/Lambdabot/Plugin/Social/Poll.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- | Module: Vote+-- | Module: Poll -- | Support for voting -- | -- | License: lGPL@@ -16,24 +16,24 @@ newPoll :: Poll newPoll = (True,[]) -appendPoll :: String -> Poll -> (Maybe Poll)+appendPoll :: Choice -> Poll -> (Maybe Poll) appendPoll choice (o,ls) = Just (o,(choice,0):ls) -voteOnPoll :: Poll -> String -> (Poll,String)+voteOnPoll :: Poll -> Choice -> (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")+ ,"voted on " ++ pprChoice choice)+ else ((o,poll),pprChoice choice ++ " is not currently a candidate in this poll") ------------------------------------------------------------------------ type Count = Int-type Candidate = String+type Choice = P.ByteString type PollName = P.ByteString-type Poll = (Bool, [(Candidate, Count)])+type Poll = (Bool, [(Choice, Count)]) type VoteState = M.Map PollName Poll type VoteWriter = VoteState -> Cmd Vote () type Vote = ModuleT VoteState LB@@ -84,6 +84,10 @@ { help = say "poll-remove <poll> Removes a poll" , process = process_ "poll-remove" }+ , (command "poll-reset")+ { help = say "poll-reset <poll> Resets votes and reopens a poll"+ , process = process_ "poll-reset"+ } ] , moduleDefState = return M.empty@@ -92,103 +96,133 @@ process_ :: [Char] -> [Char] -> Cmd Vote () process_ cmd [] = say ("Missing argument. Check @help " ++ cmd ++ " for info.")+process_ cmd dat+ | any (\c -> c < ' ' || c == '"') dat+ = say "Please do not use control characters or double quotes in polls." process_ cmd dat = do- result <- withMS $ \fm writer -> processCommand fm writer cmd (words dat)+ result <- withMS $ \fm writer ->+ processCommand fm writer cmd (map P.pack (words dat)) say result ------------------------------------------------------------------------ -processCommand :: VoteState -> VoteWriter -> String -> [String] -> Cmd Vote String+processCommand :: VoteState -> VoteWriter -> String -> [P.ByteString] -> 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)+ "poll-show" -> return $ case dat of+ [poll] -> showPoll fm poll _ -> "usage: @poll-show <poll>" -- declare a new poll- "poll-add" -> case length dat of- 1 -> addPoll fm writer (head dat)+ "poll-add" -> case dat of+ [poll] -> addPoll fm writer poll _ -> return "usage: @poll-add <poll> with \"ThisTopic\" style names" - "choice-add" -> case length dat of- 2 -> addChoice fm writer (head dat) (last dat)+ "choice-add" -> case dat of+ [poll,choice] -> addChoice fm writer poll choice _ -> return "usage: @choice-add <poll> <choice>" - "vote" -> case length dat of- 2 -> vote fm writer (head dat) (last dat)+ "vote" -> case dat of+ [poll,choice] -> vote fm writer poll choice _ -> return "usage: @vote <poll> <choice>" - "poll-result" -> return $ case length dat of- 1 -> showResult fm (head dat)+ "poll-result" -> return $ case dat of+ [poll] -> showResult fm poll _ -> "usage: @poll-result <poll>" - "poll-close" -> case length dat of- 1 -> closePoll fm writer (head dat)+ "poll-close" -> case dat of+ [poll] -> closePoll fm writer poll _ -> return "usage: @poll-close <poll>" - "poll-remove" -> case length dat of- 1 -> removePoll fm writer (head dat)+ "poll-remove" -> case dat of+ [poll] -> removePoll fm writer poll _ -> return "usage: @poll-remove <poll>" + "poll-reset" -> case dat of+ [poll] -> resetPoll fm writer poll+ _ -> return "usage: @poll-reset <poll>" _ -> return "Unknown command." ------------------------------------------------------------------------ listPolls :: VoteState -> String-listPolls fm = show $ map fst (M.toList fm)+listPolls fm = pprList pprPoll $ map fst (M.toList fm) -showPoll :: VoteState -> String -> String+showPoll :: VoteState -> PollName -> 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)+ case M.lookup poll fm of+ Nothing -> "No such poll: " ++ pprPoll poll ++ " Use @poll-list to see the available polls."+ Just p -> pprList pprChoice $ map fst (snd p) -addPoll :: VoteState -> VoteWriter -> String -> Cmd Vote String+addPoll :: VoteState -> VoteWriter -> PollName -> 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 +++ case M.lookup poll fm of+ Nothing -> do writer $ M.insert poll newPoll fm+ return $ "Added new poll: " ++ pprPoll poll+ Just _ -> return $ "Poll " ++ pprPoll 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 ++ "."+addChoice :: VoteState -> VoteWriter -> PollName -> Choice -> Cmd Vote String+addChoice fm writer poll choice = case M.lookup poll fm of+ Nothing -> return $ "No such poll: " ++ pprPoll poll+ Just _ -> do writer $ M.update (appendPoll choice) poll fm+ return $ "New candidate " ++ pprChoice choice +++ ", added to poll " ++ pprPoll 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 !"+vote :: VoteState -> VoteWriter -> PollName -> Choice -> Cmd Vote String+vote fm writer poll choice = case M.lookup poll fm of+ Nothing -> return $ "No such poll: " ++ pprPoll poll+ Just (False,_) -> return $ "The "++ pprPoll 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+ writer $ M.update (const (Just np)) 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) ++ "): "+showResult :: VoteState -> PollName -> String+showResult fm poll = case M.lookup poll fm of+ Nothing -> "No such poll: " ++ pprPoll poll+ Just (o,p) -> "Poll results for " ++ pprPoll poll ++ " (" ++ status o ++ "): " ++ (concat $ intersperse ", " $ map ppr p) where status s | s = "Open" | otherwise = "Closed"- ppr (x,y) = x ++ "=" ++ show y+ ppr (x,y) = pprChoice x ++ "=" ++ show y -removePoll :: VoteState -> VoteWriter -> String -> Cmd Vote String-removePoll fm writer poll = case M.lookup (P.pack poll) fm of+removePoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String+removePoll fm writer poll = case M.lookup 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+ Just (False,_) -> do writer $ M.delete poll fm+ return $ "poll " ++ pprPoll poll ++ " removed."+ Nothing -> return $ "No such poll: " ++ pprPoll 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."+closePoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String+closePoll fm writer poll = case M.lookup poll fm of+ Nothing -> return $ "No such poll: " ++ pprPoll poll+ Just (_,p) -> do writer $ M.update (const (Just (False,p))) poll fm+ return $ "Poll " ++ pprPoll poll ++ " closed."++resetPoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String+resetPoll fm writer poll = case M.lookup poll fm of+ Just (_, vs) -> do let np = (True, map (\(c, _) -> (c, 0)) vs)+ writer $ M.update (const (Just np)) poll fm+ return $ "Poll " ++ pprPoll poll ++ " reset."+ Nothing -> return $ "No such poll: " ++ pprPoll poll++------------------------------------------------------------------------++-- we render strings verbatim but surround them with quotes,+-- relying on previous sanitization to disallow control characters+pprBS :: P.ByteString -> String+pprBS p = "\"" ++ P.unpack p ++ "\""++pprPoll :: PollName -> String+pprPoll = pprBS++pprChoice :: Choice -> String+pprChoice = pprBS++pprList :: (a -> String) -> [a] -> String+pprList f as = "[" ++ concat (intersperse "," (map f as)) ++ "]"
src/Lambdabot/Plugin/Social/Seen.hs view
@@ -27,7 +27,7 @@ import qualified Data.ByteString.Lazy as L import Data.Char import Data.List-import qualified Data.Map as M+import qualified Data.Map.Strict as M import Text.Printf type SeenState = (MaxMap, SeenMap)@@ -55,7 +55,7 @@ , moduleInit = do sequence_- [ registerCallback signal (withSeenFM cb)+ [ registerCallback signal (withSeenFM signal cb) | (signal, cb) <- zip ["JOIN", "PART", "QUIT", "NICK", "353", "PRIVMSG"] [joinCB, partCB, quitCB, nickCB, joinChanCB, msgCB]@@ -308,10 +308,11 @@ -- 'ReaderT IRC.Message (Seen IRC)' -- monad. withSeenFM :: G.Message a- => (a -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap)+ => String+ -> (a -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap) -> (a -> Seen ()) -withSeenFM f msg = do+withSeenFM signal f msg = do let chan = packNick . lcNick . head . G.channels $! msg nick = packNick . lcNick . G.nick $ msg @@ -324,10 +325,14 @@ [ () | (_,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+ | signal `elem` ["JOIN", "353"]+ = 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+ | otherwise -- ["PART", "QUIT", "NICK", "PRIVMSG"]+ = maxUsers newMax `seq` newstate `seq` writer (newMax, newstate)