tellbot 0.6.0.1 → 0.6.0.2
raw patch · 4 files changed
+179/−187 lines, 4 filesdep +regex-pcredep −regex-posixdep ~bifunctors
Dependencies added: regex-pcre
Dependencies removed: regex-posix
Dependency ranges changed: bifunctors
Files
- CHANGELOG.md +7/−0
- src/HTML.hs +15/−27
- src/Main.hs +154/−157
- tellbot.cabal +3/−3
CHANGELOG.md view
@@ -1,6 +1,13 @@ tellbot CHANGELOG ================= +### 0.6.0.2++#### Patch changes++- Fixed UTF-8 issues with titles.+- Fixed looping on failure (uncaught exception).+ ### 0.6.0.1 - Fixed CHANGELOG.md.
src/HTML.hs view
@@ -1,50 +1,38 @@ module HTML where import Control.Exception ( SomeException, catch )-import Control.Concurrent ( threadDelay )-import Control.Monad ( guard ) import Data.ByteString.Lazy ( toStrict )-import Data.List ( isPrefixOf ) import Network.HTTP.Conduit-import Data.Text as T ( drop, dropEnd, pack, strip, unpack )+import Data.Text ( pack, strip, unpack ) import Data.Text.Encoding ( decodeUtf8 ) import Text.HTML.TagSoup-import Text.Regex.Posix ( (=~) )+import Text.Regex.PCRE ( (=~) ) htmlTitle :: FilePath -> String -> IO (Maybe String)-htmlTitle regPath url = do- regexps <- flip catch handleException . fmap lines $ readFile regPath +htmlTitle regPath url = flip catch handleException $ do+ regexps <- fmap lines $ readFile regPath if (safeHost regexps url) then do- title <- flip catch handleException $ fmap (extractTitle . concat . lines . unpack . decodeUtf8 . toStrict) $ simpleHttp httpPrefixedURL- case title of- Just _ -> pure title- Nothing -> do- threadDelay 500- flip catch handleException $ fmap (extractTitle . unpack . decodeUtf8 . toStrict) $ simpleHttp httpsPrefixedURL+ putStrLn $ url ++ " is safe"+ fmap (extractTitle . unpack . decodeUtf8 . toStrict) (simpleHttp url) else pure Nothing where- httpPrefixedURL = if "http://" `isPrefixOf` url then url else "http://" ++ url- httpsPrefixedURL = if "https://" `isPrefixOf` url then url else "https://" ++ url- handleException :: (Monoid m) => SomeException -> IO m+ handleException :: SomeException -> IO (Maybe String) handleException _ = pure mempty extractTitle :: String -> Maybe String-extractTitle body = do- guard (not $ null titleHTML)- pure . escape . chomp $ removeMarker titleHTML- where- titleHTML :: String- titleHTML = body =~ "<title>[^<]*</title>"+extractTitle body =+ case dropTillTitle (parseTags body) of+ (TagText title:TagClose "title":_) -> pure (chomp $ "« " ++ title ++ " »")+ _ -> Nothing -removeMarker ::String -> String-removeMarker = unpack . T.drop (length "<title>") . dropEnd (length "</title>") . pack+dropTillTitle :: [Tag String] -> [Tag String]+dropTillTitle [] = []+dropTillTitle (TagOpen "title" _ : xs) = xs+dropTillTitle (_:xs) = dropTillTitle xs chomp :: String -> String chomp = unpack . strip . pack--escape :: String -> String-escape = fromTagText . head . parseTags -- Filter an URL so that we don’t make overviews of unknown hosts. Pretty -- cool to prevent people from going onto sensitive websites.
src/Main.hs view
@@ -1,8 +1,7 @@ import Control.Concurrent ( threadDelay ) import Control.Exception ( SomeException, try ) import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Except+import Control.Monad.Except import Control.Monad.Trans.RWS import Data.Bifunctor ( bimap, second ) import Data.Char ( toLower )@@ -15,19 +14,18 @@ import qualified Data.Map as M import HTML import Network-import Text.Regex.Posix ( (=~) )+import Text.Regex.PCRE ( (=~) ) import System.Environment ( getArgs ) import System.IO version :: Version-version = Version [0,6,0,1] ["Apfelschorle"]+version = Version [0,6,0,2] ["Apfelschorle"] -type Failable = Except String-type FailableIO = ExceptT String IO type Server = String type Chan = String type Session = RWST ConInfo () Stories IO +-- IRC connection information. data ConInfo = ConInfo { -- server host conHost :: String@@ -41,6 +39,7 @@ , conPwd :: String } +-- A 'Nick' is a case-insensitive 'String'. newtype Nick = Nick { unNick :: String } instance Eq Nick where@@ -49,199 +48,205 @@ instance Show Nick where show (Nick a) = map toLower a --- for each individual dudes, keep a list of stories to tell+-- For each individual person, keep a list of stories to tell them. type Stories = M.Map String [String] +-- Port to use to connect to the IRC server. ircPort :: Int ircPort = 6667 +-- Threshold limit we think we’ll be flooding a channel. floodThreshold :: Int floodThreshold = 3 +-- If think we’re about to flood, delay messages by this value. floodDelay :: Int floodDelay = 500000 -- 500ms +-- Time to reconnect to a server. reconnectDelay :: Int reconnectDelay = 1000000 -- 1s -regPath :: FilePath-regPath = "./regexps"--session :: ConInfo -> Session a -> IO a-session cinfo s = do- (a,_,_) <- runRWST s cinfo M.empty- return a+-- Path to the regular expressions to filter HTML titles.+htmlTitleRegPath :: FilePath+htmlTitleRegPath = "./regexps" +-- Send a message to IRC. That message should use the IRC protocol (RFC 1459). toIRC :: String -> Session () toIRC msg = asks conHandle >>= lift . flip hPutStrLn msg +-- Receive a line from IRC. The line is formatted using the IRC protocol (RFC 1459). fromIRC :: Session String fromIRC = asks conHandle >>= lift . hGetLine +-- Send a message to someone in the current IRC session. msgIRC :: String -> String -> Session () msgIRC to msg = toIRC $ "PRIVMSG " ++ to ++ " :" ++ msg +-- Notice a message to someone in the current IRC session. Can be a channel as well if the+-- destination starts with a dash ('#'). noticeIRC :: String -> String -> Session () noticeIRC to msg = toIRC $ "NOTICE " ++ to ++ " :" ++ msg -runFailable :: Failable a -> Either String a-runFailable = runExcept--runFailableIO :: FailableIO a -> IO (Either String a)-runFailableIO = runExceptT+-- Parse a list of arguments to retrieve information about the connection.+getConInfo :: [String] -> Either String (Server,Chan,String,String)+getConInfo args+ | length args == 4 = let [host,chan,nick,pwd] = args in Right (host,chan,nick,pwd)+ | otherwise = Left "expected server host, chan, nick and admin password" main :: IO () main = do- hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering-- putStrLn . showVersion $ version- args <- getArgs- runFailableIO (start args) >>= either errLn return--getChan :: [String] -> Failable (Server,Chan,String,String)-getChan args = do- unless ( length args == 4 ) . throwE $- "expected server host, chan, nick and admin password"- let [host,chan,nick,pwd] = args- return (host,chan,nick,pwd)+ hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering -start :: [String] -> FailableIO ()-start args = do- (serv,chan,nick,pwd) <- ExceptT . pure . runFailable $ getChan args- liftIO . withSocketsDo $ connectIRC serv chan nick pwd+ putStrLn . showVersion $ version+ args <- getArgs+ connectIRC args -connectIRC :: Server -> Chan -> String -> String -> IO ()-connectIRC serv chan nick pwd = do- putStrLn $ "connecting to " ++ serv+-- Connect to the IRC server with the given arguments. On a failure, outputs to stderr.+connectIRC :: [String] -> IO ()+connectIRC args = do+ case getConInfo args of+ Right (host,chan,nick,pwd) -> go host chan nick pwd+ Left e -> errLn $ "unable to get connection information: " ++ e+ where+ go host chan nick pwd = do+ putStrLn $ "connecting to " ++ host eitherCon <- try $ do- h <- connectTo serv (PortNumber . fromIntegral $ ircPort)+ h <- connectTo host (PortNumber . fromIntegral $ ircPort) hSetBuffering h NoBuffering- session (ConInfo serv chan nick h pwd) $ do+ session (ConInfo host chan nick h pwd) $ do initIRC nick- openChan- ircSession- either reconnect (const $ return ()) eitherCon- where- reconnect :: SomeException -> IO ()- reconnect e = do- err (show e)- threadDelay reconnectDelay- connectIRC serv chan nick pwd+ joinChan+ idle+ either (reconnect host chan nick pwd) (const $ pure ()) eitherCon+ reconnect host chan nick pwd e = do+ errLn $ "disconnected: " ++ show (e :: SomeException)+ threadDelay reconnectDelay+ go host chan nick pwd +-- Run a new session.+session :: ConInfo -> Session a -> IO a+session cinfo s = do+ (a,_,_) <- runRWST s cinfo M.empty+ return a++-- Initialize the IRC link. initIRC :: String -> Session () initIRC nick = do- toIRC "USER a b c :d"- toIRC $ "NICK " ++ nick--openChan :: Session ()-openChan = do- chan <- asks conChan- liftIO . putStrLn $ "joining " ++ chan- joinChan+ toIRC "USER a b c :d"+ toIRC ("NICK " ++ nick) +-- Join the channel. joinChan :: Session ()-joinChan = asks conChan >>= toIRC . ("JOIN "++)+joinChan = do+ chan <- asks conChan+ liftIO . putStrLn $ "joining " ++ chan+ toIRC ("JOIN " ++ chan) -ircSession :: Session ()-ircSession = forever $ fromIRC >>= onContent . purgeContent+-- Idle and wait for activity.+idle :: Session ()+idle = forever $ fromIRC >>= onIRCActivity . purgeContent +-- Purge the content of the message given by IRC by removing newlines. purgeContent :: String -> String-purgeContent = filter (\c -> not $ c `elem` "\n\r")+purgeContent = filter $ \c -> not $ c `elem` "\n\r" -onContent :: String -> Session ()-onContent c = do+-- Reactive function called whenever a new IRC activity has been detected.+onIRCActivity :: String -> Session ()+onIRCActivity c = do liftIO (putStrLn c)- treat+ dispatch where tailC = tail c- treat+ dispatch | isMsg c = treatMsg tailC- | isJoin c = treatJoin tailC | isKick c = treatKick c | isPing c = treatPing c- | otherwise = return ()+ | otherwise = pure () -- FIXME: those functions are not really safe and might be flaws+-- Is a message a ping? isPing :: String -> Bool isPing c = "PING" `elem` words c +-- Is a message a user message? isMsg :: String -> Bool isMsg c = "PRIVMSG" `elem` words c -isJoin :: String -> Bool-isJoin c = "JOIN" `elem` words c-+-- Is a message a kick? isKick :: String -> Bool isKick c = "KICK" `elem` words c +-- Respond to ping. treatPing :: String -> Session ()-treatPing ping = do- toIRC pong+treatPing ping = toIRC pong where- pong = "PONG" ++ numericPing+ pong = "PONG" ++ numericPing numericPing = snd . break (==' ') $ ping +-- When a user writes a message, we need to do several things.+--+-- In the first place, we want to filter out the case when we are the one to talk. In that case, we+-- just do nothing.+--+-- Then, if it’s someone else, we just try to tell them stories. Then, we look for a URL in their+-- message. If we’ve found a URL, we just try to extract its HTML title, and broadcast it on the+-- channel. If we don’t find a URL or we fail to parse the title, we just do nothing.+--+-- Finally, we check whether the message is not a command message. If so, we just branch on the+-- 'onCmd' function. treatMsg :: String -> Session () treatMsg msg = do nick <- asks conNick chan <- asks conChan- liftIO . putStrLn $ "from: " ++ fromNick ++ ", to: " ++ to ++ ": " ++ content- unless (null content || Nick fromNick == Nick nick) $ do- tellStories fromNick+ unless (null content || Nick emitter == Nick nick) $ do+ tellStories emitter let url = extractUrl content unless (null url) $ do- title <- liftIO $ htmlTitle regPath url- traverse_ (\t -> msgIRC chan $ "« " ++ t ++ " »") title+ title <- liftIO (htmlTitle htmlTitleRegPath url)+ traverse_ (\t -> msgIRC chan t) title when (head content == '!') $ do- onCmd fromNick to (tail content)+ onCmd emitter recipient (tail content) where- (fromNick,to,content) = emitterRecipientContent msg+ (emitter,recipient,content) = emitterRecipientContent msg +-- Extract the emitter, the recipient and the message.+emitterRecipientContent :: String -> (String,String,String)+emitterRecipientContent msg = (emitter,recipient,content)+ where+ (from':_:recipient:content') = splitOn " " msg+ emitter = fst . break (=='!') $ from'+ content = tailSafe (unwords content')++-- Extract the URL out of a message. If no URL is found, gives an empty string. extractUrl :: String -> String extractUrl = (=~ "https?://[^ ]+") -treatJoin :: String -> Session ()-treatJoin _ = do- return ()-{-- nick <- asks conNick- unless (from == nick) $ tellStories from- where- (from,to,_) = emitterRecipientContent msg--}-+-- We might want to know whether we got kicked. If so, we just rejoin the server and insult the+-- person who has kicked us! treatKick :: String -> Session () treatKick msg = do nick <- asks conNick chan <- asks conChan when (kicked == nick) $ do- liftIO . putStrLn $ "woah, I was kicked by " ++ from joinChan- msgIRC chan $ from ++ ": you sonavabitch."+ msgIRC chan $ emitter ++ ": you sonavabitch." where (from',_,content) = emitterRecipientContent msg- from = tailSafe from'- kicked = tailSafe $ dropWhile (/=':') content---- Extract the emitter, the recipient and the message.-emitterRecipientContent :: String -> (String,String,String)-emitterRecipientContent msg = (from,to,content)- where- (from':_:to:content') = splitOn " " msg- from = fst . break (=='!') $ from'- content = tailSafe (unwords content')+ emitter = tailSafe from'+ kicked = tailSafe $ dropWhile (/=':') content +-- When someone tries to enter a command, we need to validate the command. First, the command is+-- looked up. If it doesn’t exist, nothing is performed, because it could be someone trying to+-- bruteforce us. onCmd :: String -> String -> String -> Session ()-onCmd from to msg = do- liftIO . putStrLn $ "searching command " ++ cmd ++ ": " ++ show found- maybe unknownCmd treatCmd (M.lookup cmd commands)+onCmd emitter recipient msg = traverse_ treatCmd (M.lookup cmd commands) where- (cmd,arg) = second tailSafe . break (==' ') $ msg- unknownCmd = return ()- treatCmd c = c from to arg- found = cmd `M.member` commands+ (cmd,arg) = second tailSafe . break (==' ') $ msg+ treatCmd c = c emitter recipient arg +-- List of available commands. commands :: M.Map String (String -> String -> String -> Session ()) commands = M.fromList [@@ -250,91 +255,83 @@ , ("help",helpCmd) ] +-- Function associated with the "tell" command. tellCmd :: String -> String -> String -> Session ()-tellCmd from _ arg = do+tellCmd emitter _ arg = do chan <- asks conChan treat chan where treat chan | length arg > 1 && not (null msg) = do nick <- fmap Nick (asks conNick)- if fromNick == nick then+ if emitterNick == nick+ then msgIRC chan "I'll tell myself for sure pal!"- else do- -- FIXME: issue #2- {-- userPresent <- do- toIRC $ "NAMES " ++ chan- names <- (filter $ \c -> not $ c `elem` "?@!#:") `liftM` fromIRC- liftIO . putStrLn $ "names: " ++ names- return (fromNick `elem` words names)- if userPresent then- msgIRC chan "don't waste my time; that folk's here"- else do- -}- now <- liftIO $ utctDay `liftM` getCurrentTime- modify . M.insertWith (flip (++)) (show fromNick) $- [show now ++ ", " ++ from ++ " told " ++ (unNick fromNick) ++ ": " ++ msg]- msgIRC from "\\_o<"+ else do+ now <- liftIO $ utctDay `liftM` getCurrentTime+ modify . M.insertWith (flip (++)) (show emitterNick) $+ [show now ++ ", " ++ emitter ++ " told " ++ (unNick emitterNick) ++ ": " ++ msg]+ msgIRC emitter "\\_o<" | otherwise = msgIRC chan "nope!"- (fromNick,msg) = bimap Nick tailSafe . break (==' ') $ arg+ (emitterNick,msg) = bimap Nick tailSafe . break (==' ') $ arg +-- Function associated with the "do" command. That command is used to perform several administration+-- tasks by making the bot *do* things for us. doCmd :: String -> String -> String -> Session ()-doCmd from to arg = do+doCmd emitter recipient arg = do chan <- asks conChan myNick <- asks conNick pwd <- asks conPwd treatDo chan myNick pwd where treatDo chan myNick pwd- | to == chan = msgIRC from "I'm sorry, I feel naked in public ;)"- | Nick to == Nick myNick && length args >= 3 = executeDo chan pwd- | otherwise = msgIRC from "huhu, something went terribly wrong!"+ | recipient == chan = msgIRC emitter "I'm sorry, I feel naked in public ;)"+ | Nick recipient == Nick myNick && length args >= 3 = executeDo chan pwd+ | otherwise = msgIRC emitter "huhu, something went terribly wrong!" args = words arg userPwd:action:actionParams = args executeDo chan pwd- | pwd /= userPwd = msgIRC from "wrong password!"+ | pwd /= userPwd = msgIRC emitter "wrong password!" | otherwise = executeAction chan executeAction chan- | action == "op" = mapM_ (toIRC . (mode chan "+o"++)) actionParams- | action == "deop" = mapM_ (toIRC . (mode chan "-o"++)) actionParams+ | action == "op" = traverse_ (toIRC . (mode chan "+o"++)) actionParams+ | action == "deop" = traverse_ (toIRC . (mode chan "-o"++)) actionParams | action == "say" = msgIRC chan (unwords actionParams)- | action == "kick" = mapM_ (toIRC . (("KICK " ++ chan ++ " ")++)) actionParams+ | action == "kick" = traverse_ (toIRC . (("KICK " ++ chan ++ " ")++)) actionParams | action == "notice" = noticeIRC chan (unwords actionParams)- | otherwise = msgIRC from "unknown action"+ | otherwise = msgIRC emitter "unknown action" mode chan m = "MODE " ++ chan ++ " " ++ m ++ " " +-- Display the help to the recipient. helpCmd :: String -> String -> String -> Session ()-helpCmd from _ _ = do- myNick <- asks conNick- msgIRC from $ "!tell dest msg: leave a message to a beloved"- msgIRC from $ "!do pwd action params: perform an action"- msgIRC from $ "- - op user0 user1...: grant op privileges"- msgIRC from $ "- - deop user0 user1...: revoke op privileges"- msgIRC from $ "- - kick user0 user1...: kick them all!"- msgIRC from $ "- - say blabla: make " ++ myNick ++ " say something"- msgIRC from $ "- - notice msg: notice the channel something"- msgIRC from . showVersion $ version- msgIRC from $ "written in Haskell by phaazon"+helpCmd recipient _ _ = do+ myNick <- asks conNick+ msgIRC recipient $ "!tell dest msg: leave a message to a beloved"+ msgIRC recipient $ "!do pwd action params: perform an action"+ msgIRC recipient $ "- - op user0 user1...: grant op privileges"+ msgIRC recipient $ "- - deop user0 user1...: revoke op privileges"+ msgIRC recipient $ "- - kick user0 user1...: kick them all!"+ msgIRC recipient $ "- - say blabla: make " ++ myNick ++ " say something"+ msgIRC recipient $ "- - notice msg: notice the channel something"+ msgIRC recipient . showVersion $ version+ msgIRC recipient $ "written in Haskell by phaazon" --- FIXME: host & ident+-- Tell stories to someone. tellStories :: String -> Session ()-tellStories nick = do- stories <- gets (toList . M.lookup (show $ Nick nick))+tellStories recipient = do+ stories <- gets (toList . M.lookup (show $ Nick recipient)) let cstories = concat stories- chunks = map (mapM_ $ msgIRC nick) . chunksOf floodThreshold $ cstories+ chunks = map (mapM_ $ msgIRC recipient) . chunksOf floodThreshold $ cstories tells = intersperse (liftIO $ threadDelay floodDelay) chunks unless (null stories) $ do sequence_ tells- modify (M.delete . show $ Nick nick)--err :: (MonadIO m) => String -> m ()-err = liftIO . hPutStr stderr+ modify (M.delete . show $ Nick recipient) errLn :: (MonadIO m) => String -> m () errLn = liftIO . hPutStrLn stderr +-- Safer tail. tailSafe :: [a] -> [a] tailSafe [] = [] tailSafe (_:xs) = xs
tellbot.cabal view
@@ -1,5 +1,5 @@ name: tellbot-version: 0.6.0.1+version: 0.6.0.2 synopsis: IRC tellbot description: An IRC bot that can be used to create queuing message. It also offers a simple administration IRC bot interface.@@ -27,13 +27,13 @@ default-extensions: FlexibleInstances build-depends: base >= 4.5 && < 5- , bifunctors >= 4.1 && < 4.3+ , bifunctors >= 4.1 && < 5.1 , bytestring >= 0.10 && < 0.11 , containers >= 0.4 && < 0.6 , http-conduit >= 2.1 && < 2.2 , mtl >= 2.1 && < 2.3 , network >= 2.4 && < 2.7- , regex-posix >= 0.95 && < 0.96+ , regex-pcre >= 0.94 && < 0.95 , split >= 0.2 && < 0.3 , text >= 1.2 && < 1.3 , tagsoup >= 0.13 && < 0.14