-- Based on http://www.haskell.org/haskellwiki/Roll_your_own_IRC_bot
-- Extended with a concurrent console. It seems MVar is not necessary.

import Data.List
import Network
import System.IO
import System.Time
import System.Exit
import Control.Monad.Reader
import Control.Exception
import Control.Concurrent
import Text.Printf
import Prelude hiding (catch)
 
server = "irc.freenode.org"
port   = 6667
chan   = "#tutbot-testing"
nick   = "tutbot"
 
--
-- 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, mvar :: MVar Int }
 
--
-- 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 ((forkIO $ runReaderT run st) >> runReaderT console 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 port))
    hSetBuffering h NoBuffering
    m <- newEmptyMVar
    return (Bot h t m)
  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
    listen

console :: Net ()
console = forever $ do
    atomically $ liftIO $ do
                      putStr $ "chat> "
                      hFlush stdout
    s <- liftIO getLine
    eval s
         where 
           eval     "!uptime"             = uptime >>= privmsg
           eval     "!quit"               = write "QUIT" ":Exiting" >> liftIO (exitWith ExitSuccess)
           eval     x                     = privmsg x

-- Atomically executes an action using MVar, assuming its initial value is empty
atomically :: Net () -> Net ()          
atomically act = do
  act
    -- m <- asks mvar
    -- liftIO $ putMVar m 0
    -- act
    -- liftIO $ takeMVar m
    -- return ()
 
--
-- Process each line from the server
--
listen :: Net ()
listen = forever $ do
    h <- asks socket
    s <- init `fmap` liftIO (hGetLine h)
    atomically $ liftIO (putStrLn s)
    if ping s then pong s else eval (clean s)
  where
    clean     = drop 1 . dropWhile (/= ':') . drop 1
    ping x    = "PING :" `isPrefixOf` x
    pong x    = write "PONG" (':' : drop 6 x)
 
--
-- Dispatch a command
--
eval :: String -> Net ()
eval     "!uptime"             = uptime >>= privmsg
eval     "!quit"               = write "QUIT" ":Exiting" >> liftIO (exitWith ExitSuccess)
eval x | "!id " `isPrefixOf` x = privmsg (drop 4 x)
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 = atomically write'
    where write' = do
            h <- asks socket
            liftIO $ hPrintf h "%s %s\r\n" s t
            liftIO $ printf    "> %s %s\n" s t
 
--
-- Calculate and pretty print the uptime
--
uptime :: Net String
uptime = do
    now  <- liftIO getClockTime
    zero <- asks starttime
    return . pretty $ diffClockTimes now zero
 
--
-- Pretty print the date in '1d 9h 9m 17s' format
--
pretty :: TimeDiff -> String
pretty td = join . intersperse " " . filter (not . null) . map f $
    [(years          ,"y") ,(months `mod` 12,"m")
    ,(days   `mod` 28,"d") ,(hours  `mod` 24,"h")
    ,(mins   `mod` 60,"m") ,(secs   `mod` 60,"s")]
  where
    secs    = abs $ tdSec td  ; mins   = secs   `div` 60
    hours   = mins   `div` 60 ; days   = hours  `div` 24
    months  = days   `div` 28 ; years  = months `div` 12
    f (i,s) | i == 0    = []
            | otherwise = show i ++ s