From f9a26401041d254cd1b252f8298d5148b290dbae Mon Sep 17 00:00:00 2001
From: Fabien <HiSoKa@Tethys.local>
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