diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/src/HTML.hs b/src/HTML.hs --- a/src/HTML.hs +++ b/src/HTML.hs @@ -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 =~ "[^<]*" +extractTitle body = + case dropTillTitle (parseTags body) of + (TagText title:TagClose "title":_) -> pure (chomp $ "« " ++ title ++ " »") + _ -> Nothing -removeMarker ::String -> String -removeMarker = unpack . T.drop (length "") . dropEnd (length "") . 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. diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/tellbot.cabal b/tellbot.cabal --- a/tellbot.cabal +++ b/tellbot.cabal @@ -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