diff --git a/lambdabot-social-plugins.cabal b/lambdabot-social-plugins.cabal --- a/lambdabot-social-plugins.cabal +++ b/lambdabot-social-plugins.cabal @@ -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 +maintainer: Bertram Felgenhauer 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 diff --git a/src/Lambdabot/Plugin/Social/Poll.hs b/src/Lambdabot/Plugin/Social/Poll.hs --- a/src/Lambdabot/Plugin/Social/Poll.hs +++ b/src/Lambdabot/Plugin/Social/Poll.hs @@ -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 Removes a poll" , process = process_ "poll-remove" } + , (command "poll-reset") + { help = say "poll-reset 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 " -- 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 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 " - "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-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-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-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-reset" -> case dat of + [poll] -> resetPoll fm writer poll + _ -> return "usage: @poll-reset " _ -> 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)) ++ "]" diff --git a/src/Lambdabot/Plugin/Social/Seen.hs b/src/Lambdabot/Plugin/Social/Seen.hs --- a/src/Lambdabot/Plugin/Social/Seen.hs +++ b/src/Lambdabot/Plugin/Social/Seen.hs @@ -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)