--
-- 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