challenge-258-I.hs

import Data.List
import Network
import System.IO
import System.Exit
import Control.Arrow
import Control.Monad
import Control.Monad.Reader
import Control.Exception
import Text.Printf

server        = "irc.freenode.org"
port          = 6667
chan          = "#reddit-dailyprogrammer"
nick          = "fvandepitte-bot"
welcomMessage = "I am the bot of fvandepitte"

data Bot = Bot { socket :: Handle }
type Net = ReaderT Bot IO

write :: String -> String -> Net ()
write s t = do
    h <- asks socket
    liftIO $ hPrintf h "%s %s\r\n" s t
    liftIO $ printf    "> %s %s\n" s t

privmsg :: String -> Net ()
privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)

connectIRC :: IO Bot
connectIRC = do 
    h <- connectTo server (PortNumber port)
    hSetBuffering h NoBuffering
    return (Bot h)

run :: Net ()
run = do
    write "NICK" nick
    write "USER" (nick++" 0 * :fvandepitte Bot")
    write "JOIN" chan
    asks socket >>= listen
  where 
    listen h = forever (handleIRCLine =<< liftIO (hGetLine h))

logLine :: String -> Net ()
logLine x = do
  liftIO (putStrLn $ "<" ++ x)
  return ()

handleMessage :: String -> Net ()
handleMessage x | isCommand x = handleCommand $ cleanCommand x
                | otherwise   = logLine $ clean x
    where 
      isCommand x = (nick ++ ":") `isPrefixOf` cleanMsg x

handleCommand :: String -> Net ()
handleCommand x  | cmd "shut up"  = privmsg "Ok, I'm leaving now..." >> write "QUIT" ":Goodbey, sir." >> liftIO exitSuccess
                 | cmd "random"   = privmsg "I would say '4', is that random enough?"
                 | otherwise      = privmsg $ "I don't know that command: " ++ x
        where
            cmd = flip isInfixOf x

clean :: String -> String
clean x   = cleanUser x ++ "> " ++ cleanMsg x

cleanUser :: String -> String
cleanUser = drop 1 . takeWhile (/= '!')

cleanMsg :: String -> String
cleanMsg = drop 1 . dropWhile (/= ':') . drop 1

cleanCommand :: String -> String
cleanCommand = drop 1 . dropWhile (/= ':') . cleanMsg

handleIRCLine :: String -> Net ()
handleIRCLine x = logLine x >> handleIRCLine' x

handleIRCLine' :: String -> Net ()
handleIRCLine' x | ping        = pong 
                 | isMessage   = handleMessage x
                 | isMyJoin    = privmsg welcomMessage
                 | otherwise   = return ()
    where
      ping       = "PING :" `isPrefixOf` x
      pong       = write "PONG" (':' : drop 6 x)
      isMessage  = "PRIVMSG" `isInfixOf` x
      isMyJoin   = cleanUser x == nick && "JOIN" `isInfixOf` x && chan `isInfixOf` x
      
main = bracket connectIRC closeBot loop
  where
    loop = runReaderT run
    closeBot = hClose . socket