From f9a26401041d254cd1b252f8298d5148b290dbae Mon Sep 17 00:00:00 2001 From: Fabien Date: Sun, 7 Apr 2013 19:45:02 +0200 Subject: [PATCH] Add initial files for IRC bot. Add basic IRC bot main file. Add simple module to parse HMTL title from an url. --- HTMLParsing.hs | 33 +++++++++++++ main.hs | 130 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 163 insertions(+) create mode 100644 HTMLParsing.hs create mode 100644 main.hs diff --git a/HTMLParsing.hs b/HTMLParsing.hs new file mode 100644 index 0000000..c8252ce --- /dev/null +++ b/HTMLParsing.hs @@ -0,0 +1,33 @@ +module HTMLParsing +( getHTTPTitle +) where + +import Data.Tree.NTree.TypeDefs +import Data.Maybe +import Text.XML.HXT.Core +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Maybe +import Network.HTTP +import Network.URI + +-- http://adit.io/posts/2012-04-14-working_with_HTML_in_haskell.html + +openUrl :: String -> MaybeT IO String +openUrl url = case parseURI url of + Nothing -> fail "" + Just u -> liftIO (getResponseBody =<< simpleHTTP (mkRequest GET u)) + +css :: ArrowXml a => String -> a XmlTree XmlTree +css tag = multi (hasName tag) + +get :: String -> IO (IOSArrow XmlTree (NTree XNode)) +get url = do + contents <- runMaybeT $ openUrl url + return $ readString [withParseHTML yes, withWarnings no] (fromMaybe "" contents) + +getHTTPTitle :: String -> IO String +getHTTPTitle url = do + httpBody <- get url + title <- runX $ httpBody >>> css "title" /> getText + return $ head title \ No newline at end of file diff --git a/main.hs b/main.hs new file mode 100644 index 0000000..9cd9876 --- /dev/null +++ b/main.hs @@ -0,0 +1,130 @@ +-- +-- A simple, clean IRC bot in Haskell +-- +-- http://www.haskell.org/haskellwiki/Roll_your_own_IRC_bot + +import Data.List +import Network +import Network.HTTP +import System.IO +import System.Time +import System.Exit +import Control.Monad.Reader +--import Control.Exception -- for base-3, with base-4 use Control.OldException +import Control.OldException +import Text.Printf +import Prelude hiding (catch) + +import HTMLParsing + +server = "irc.freenode.net" +port = 6667 +chan = "#cheeseburger" +nick = "cheesebot" + +-- +-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state. +-- A socket and the bot's start time. +-- +type Net = ReaderT Bot IO +data Bot = Bot { socket :: Handle, starttime :: ClockTime } + +-- +-- Set up actions to run on start and end, and run the main loop +-- +main :: IO () +main = bracket connect disconnect loop + where + disconnect = hClose . socket + loop st = catch (runReaderT run st) (const $ return ()) + +-- +-- Connect to the server and return the initial bot state +-- +connect :: IO Bot +connect = notify $ do + t <- getClockTime + h <- connectTo server (PortNumber (fromIntegral Main.port)) + hSetBuffering h NoBuffering + return (Bot h t) + where + notify a = bracket_ + (printf "Connecting to %s ... " server >> hFlush stdout) + (putStrLn "done.") + a + +-- +-- We're in the Net monad now, so we've connected successfully +-- Join a channel, and start processing commands +-- +run :: Net () +run = do + write "NICK" nick + write "USER" (nick++" 0 * :tutorial bot") + write "JOIN" chan + asks socket >>= listen + +-- +-- Process each line from the server +-- +listen :: Handle -> Net () +listen h = forever $ do + s <- init `fmap` io (hGetLine h) + io (putStrLn s) + if ping s then pong s else eval (clean s) + where + forever a = a >> forever a + clean = drop 1 . dropWhile (/= ':') . dropWhile (/= ' ') + ping x = "PING :" `isPrefixOf` x + pong x = write "PONG" (':' : drop 6 x) + +-- +-- Dispatch a command +-- +eval :: String -> Net () +eval x | "cheesebot" `isPrefixOf` x = privmsg (answerRequest (drop 9 x)) +eval x | isYouTubeURL x = do + youtubeTitle <- io $ getHTTPTitle x + privmsg youtubeTitle +eval _ = return () -- ignore everything else + +-- +-- Send a privmsg to the current chan + server +-- +privmsg :: String -> Net () +privmsg s = write "PRIVMSG" (chan ++ " :" ++ s) + +-- +-- Send a message out to the server we're currently connected to +-- +write :: String -> String -> Net () +write s t = do + h <- asks socket + io $ hPrintf h "%s %s\r\n" s t + io $ printf "> %s %s\n" s t + +-- +-- Answer simple request +-- +answerRequest :: String -> String +answerRequest x + | "/quit" `isInfixOf` x = "Nice try" + | ":" `isPrefixOf` x = drop 1 x + | "," `isPrefixOf` x = drop 1 x + | otherwise = x + +-- +-- Youtube +-- +isYouTubeURL :: String -> Bool +isYouTubeURL s = + "http://www.youtube.com/" `isPrefixOf` s + || "https://www.youtube.com/" `isPrefixOf` s + || "http://youtu.be/" `isPrefixOf` s + || "https://youtu.be/" `isPrefixOf` s + +-- +-- Convenience. +-- +io :: IO a -> Net a +io = liftIO