--
-- A simple, clean IRC client in Haskell
--
-- Inspired by sirc, 10kloc.org
--

import Data.List
import Data.Maybe
import Network
import System.IO
import System.Time
import System.Exit
import System.Environment
import Control.Monad.State
import Control.Exception
import Control.Concurrent
import Text.Printf
import System.Console.Readline
import Prelude hiding (catch)

server = "irc.freenode.org"
port   = 6667
nick   = "flipdons"
name   = "Don Stewart"
passwd = Nothing

--
-- The 'Net' monad, a wrapper over IO, carrying the client's immutable state.
-- A socket and the bot's start time.
--
type Net = StateT Bot IO
data Bot = Bot { socket  :: Handle
               , channel :: Maybe String }

--
-- 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    = handle (const $ return ()) $ do
                    forkIO $ runStateT writer st >> return ()
                    runStateT reader st
                    return ()

--
-- Connect to the server and return the initial bot state
--
connect :: IO Bot
connect = notify $ do
    h <- connectTo server (PortNumber (fromIntegral port))
    hSetBuffering h NoBuffering
    return $ Bot { socket  = h , channel = Nothing }
  where
    notify a = bracket_
        (printf "Connecting to %s ... " server >> hFlush stdout)
        (putStrLn "done.")
        a

--
-- Parse input from stdin
--
reader :: Net ()
reader = forever $ do
    s <- io (readline "> ")
    case s of
        Nothing -> quit
        Just s  -> parse s
  where
    parse "/quit"      = quit
    parse x | isJoin x = join (drop 6 x)
    parse msg          = privmsg msg

    isJoin = isPrefixOf "/join"

    join chan = do write "JOIN" chan
                   modify $ \s -> s { channel = Just chan }
    quit      = write "QUIT" ":Exiting" >> io (exitWith ExitSuccess)

--
-- We're in the Net monad now, so we've connected successfully
-- Join a channel, and start processing commands
--
writer :: Net ()
writer = do
    when (isJust passwd) $ write "PASS" (fromJust passwd)
    write "NICK" nick
    write "USER" (nick++" 0 * :" ++ name)
    gets socket >>= listen

--
-- Process each line from the server
--
--     <bufout>  ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
--     <prefix>   ::= <servername> | <nick> [ '!' <user> ] [ '@' <server> ]
--     <command>  ::= <letter> { <letter> } | <number> <number> <number>
--     <SPACE>    ::= ' ' { ' ' }
--     <params>   ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
--     <middle>   ::= <Any *non-empty* sequence of octets not including SPACE
--     or NUL or CR or LF, the first of which may not be ':'>
--     <trailing> ::= <Any, possibly *empty*, sequence of octets not including NUL or CR or LF>
--     <crlf>     ::= CR LF
--
listen :: Handle -> Net ()
listen h = forever $ do
    s <- init `fmap` io (hGetLine h)
    io (putStrLn s)
    if ping s then pong s else return ()
  where
    clean     = drop 1 . dropWhile (/= ':') . drop 1
    ping x    = "PING :" `isPrefixOf` x
    pong x    = write "PONG" (':' : drop 6 x)

--
-- Send a privmsg to the current chan + server
--
privmsg :: String -> Net ()
privmsg s = do
    chan <- gets channel
    case chan of
        Nothing   -> error "Not connected to a channel"
        Just chan -> 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     <- gets socket
    time  <- io getClockTime
    io $ hPrintf h "%s %s\r\n" s t
    io $ printf    "%s> %s %s\n" (show time) s t -- prettier

--
-- Convenience.
--
io :: IO a -> Net a
io = liftIO

--
-- Useful
--
forever :: Monad m => m a -> m a
forever a = a >> forever a