hbot

HBot.hs

-- A simple IRC bot using http://www.haskell.org/haskellwiki/Roll_your_own_IRC_bot
-- as a starting point
module HBot where

import Data.List
import Network
import System.IO
import System.Console.ANSI
import Control.Applicative ((<$))
import Control.Monad.Reader hiding (join)
import Control.Exception hiding (try)
import Text.Printf
import Text.ParserCombinators.Parsec
import Prelude hiding (catch)

-- Default connection information
server = "irc.v8d.org"
port = 6667
nick = "hbot"
autojoin = ["#hbot-test"]
prefix = "!"

-- The 'Net' monad, combining IO monad with immutable Bot state
type Net = ReaderT Bot IO
data Bot = Bot { socket :: Handle }

main :: IO ()
main = bracket connect disconnect loop
  where
    disconnect = hClose . socket
    loop st    = catch (runReaderT run st) (\e -> putStrLn $ show (e :: SomeException))

-- Connect to IRC server and send identification
connect :: IO Bot
connect = do
    h <- connectTo server (PortNumber (fromIntegral port))
    hSetBuffering h NoBuffering
    hSetNewlineMode h NewlineMode{inputNL=CRLF, outputNL=CRLF}
    return (Bot h)

-- Process the received data a line at a time
run :: Net ()
run = do
    h <- asks socket
    send $ printf "NICK %s" nick
    send $ printf "USER %s 0 * :%s" nick nick
    liftIO (fmap lines $ hGetContents h) >>= mapM_ recv

-- Handle a single raw IRC command
recv :: String -> Net ()
recv s = do
    liftIO $ putStrLnSGR colorRecv $ "<<< " ++ s
    case parseEvent s of
        Left err ->
            liftIO $ putStrLnSGR colorError $ "!!! Parse error"
        Right evt ->
            --(liftIO $ print evt) >> 
            evalEvent $ processEvent evt

-- Send a single raw IRC command
send :: String -> Net ()
send s = do
    h <- asks socket
    liftIO $ hPutStrLn h           $ printf "%s"     s
    liftIO $ putStrLnSGR colorSent $ printf ">>> %s" s

-- Basic event information
data Event = Event { raw :: String
                   , source :: Source
                   , command :: String
                   , args :: String
                   , info :: EventInfo
                   , content :: String }
           deriving (Show)
data Source = NoSource
            | Server String
            | User String String String
            deriving (Show)
data EventInfo = NoInfo
               | ChanMsg String
               | PrivMsg String
               deriving (Show)

-- Parse an event
parseEvent :: String -> Either ParseError Event
parseEvent input = parse eventParser "(unknown)" input
  where
    eventParser = do
        s   <- sourceParser
        cmd <- manyTill alphaNum (char ' ')
        a   <- manyTill anyChar (try (string ":" <|> string " :" <|> fmap (const "") eof))
        c   <- many anyChar
        return Event {raw=input, source=s, command=cmd, args=a, info=NoInfo, content=c}
    sourceParser =
        (char ':' >> (
            try (do
                n <- manyTill (noneOf " !") (char '!')
                u <- manyTill (noneOf " @") (char '@')
                h <- manyTill (noneOf " ") (char ' ')
                return (User n u h)
            )
            <|> (do
                s <- manyTill (noneOf " ") (char ' ')
                return (Server s)
            )
        ))
        <|> return NoSource

-- Populate the "info" part of an Event if necessary
processEvent :: Event -> Event
processEvent e = case command e of
    "PRIVMSG"   -> if "#" `isPrefixOf` (args e) then e {info=ChanMsg (args e)}
                                                else let (User n _ _) = source e in e {info=PrivMsg n}
    otherwise   -> e

evalEvent :: Event -> Net ()
evalEvent e = case command e of
    -- Join channels once server confirms authentication
    "001"       -> mapM_ (send . printf "JOIN %s") autojoin
    -- Respond to PING to keep connection alive
    "PING"      -> send $ printf "PONG :%s" $ content e
    "PRIVMSG"   -> case info e of
        (ChanMsg channel) -> send $ printf "PRIVMSG %s :%s" channel (show e)
        (PrivMsg nick)    -> send $ printf "PRIVMSG %s :%s" nick (show e)
        otherwise         -> return ()
    -- Default: ignore event
    otherwise   -> return ()

putStrLnSGR :: [SGR] -> String -> IO ()
putStrLnSGR sgr s = setSGR sgr >> putStrLn s >> setSGR [Reset]

colorRecv = [SetColor Foreground Dull White]
colorSent = [SetColor Foreground Dull Green]
colorError = [SetColor Foreground Vivid Red]