{-#LANGUAGE OverloadedStrings #-}

{- |
Module      :  $Header$
Description :  γ0λ0bot is plaimi's IRC bot. It does various things.
Copyright   :  (c) Alexander Berntsen 2015
License     :  AGPL-3

Maintainer  :  alexander@plaimi.net
-} module Main where

import Control.Exception
  (
  bracket,
  bracket_,
  )
import Control.Monad.Reader
  (
  ReaderT,
  asks,
  liftIO,
  runReaderT,
  )
import qualified Data.ByteString       as B
import qualified Data.ByteString.Char8 as B8
import Data.Functor
  (
  (<$>),
  )
import Data.List
  (
  delete,
  )
import qualified Data.Map as M
import Data.Maybe
  (
  fromJust,
  )
import qualified Data.Set as Z
import Data.Time.Clock
  (
  UTCTime,
  getCurrentTime,
  )
import Data.Time.Format
  (
  formatTime,
  )
import Network
  (
  PortID (PortNumber),
  connectTo,
  )
import Safe
  (
  headMay,
  )
import System.IO
  (
  BufferMode (NoBuffering),
  Handle,
  hClose,
  hFlush,
  hSetBuffering,
  stdout,
  )
import System.IO.Error
  (
  catchIOError,
  )
import System.Locale
  (
  defaultTimeLocale,
  )
import Text.Printf
  (
  printf,
  )
 
server :: String
server = "irc.freenode.org"

port :: Int
port   = 6667

chan :: B.ByteString
chan   = "#plaimi"

nick :: B.ByteString
nick   = "y0l0bot"

type Net = ReaderT Bot IO

newtype Seens = MkSeens (M.Map B.ByteString UTCTime) deriving Show

newtype Tells =
  MkTells (M.Map B.ByteString (Z.Set B.ByteString)) deriving Show
 
data Bot = MkBot { socket :: Handle }

data BotData = MkBotData { seens :: Seens
                         , tells :: Tells
                         , users :: [B.ByteString]
                         } deriving Show
 
main :: IO ()
main = bracket connect (hClose . socket) $
       \st -> catchIOError (runReaderT run st) (const $ return ())
 
connect :: IO Bot
connect = notify $ do
    h <- connectTo server $ PortNumber (fromIntegral port)
    hSetBuffering h NoBuffering
    return $ MkBot h
  where
    notify = bracket_ (printf "Connecting to %s ... " server >> hFlush stdout)
                      (putStrLn "done.")
 
run :: Net ()
run = do
    write "NICK" nick
    write "USER" $ nick `B.append` " 0 * :plaimi's bot"
    write "JOIN" chan
    asks socket >>= listen
 
listen :: Handle -> Net ()
listen h = loop h MkBotData { seens = MkSeens $ M.fromList []
                            , tells = MkTells $ M.fromList []
                            , users = [] }

loop :: Handle -> BotData -> Net ()
loop h bd = do
  s <- B.init <$> liftIO (B.hGetLine h)
  liftIO (B8.putStrLn s)
  loop h =<< if ping s then pong s bd else eval bd s
 
ping :: B8.ByteString -> Bool
ping x = "PING :" `B.isPrefixOf` x

pong :: B8.ByteString -> BotData -> Net BotData
pong x bd = write "PONG" (':' `B8.cons` B.drop 6 x) >> return bd

eval :: BotData -> B.ByteString -> Net BotData
eval bd x | "#tell" `B.isPrefixOf`  clean x     =
  let (n, m) = tell x
  in  if n `elem` users bd
        then privmsg "tell them urslef, u dingus!!!" >> return bd
        else do
          privmsg ("OK, letting " `B.append` n `B.append` " know that "
                  `B.append` (B8.unwords . drop 6 . B8.words) m)
          return bd {tells = updateTells (n, m) (tells bd)}
          | "#seen " `B.isPrefixOf` clean x     = do
            privmsg (getSeenTime (B8.unwords . tail . B8.words . clean $ x)
                                 (seens bd) (users bd))
            return bd
          | (head . tail . B8.words) x == "353" = do
            t <- liftIO getCurrentTime
            return (foldr ((\u b -> b { seens = updateSeens u t (seens b)
                                      , users = updateUsers u (users b)
                                      })
                                    . nickClean) bd (drop 5 . B8.words $ x))
          | head (tail (B8.words x)) == "PART"  =
            return bd { users = dupdateUsers (uNickOf x)
                                             (users bd) }
          | head (tail (B8.words x)) == "JOIN"  = do
            sendTells (uNickOf x) (tells bd)
            t <- liftIO getCurrentTime
            return bd { users = updateUsers (uNickOf x) (users bd)
                      , tells = dupdateTells (uNickOf x) (tells bd)
                      , seens = updateSeens (uNickOf x) t (seens bd)
                      }
          | "#d" `B.isPrefixOf` clean x         = do
            privmsg (B8.pack $ show bd)
            return bd
          | otherwise                           = do
            t <- liftIO getCurrentTime
            case nickOf x of
              Just n  -> return bd { seens = updateSeens n t (seens bd) }
              Nothing -> return bd
  where uNickOf = fromJust . nickOf

tell :: B.ByteString -> (B.ByteString, B.ByteString)
tell s = (head m
         ,fromJust (nickOf s) `B.append` " wanted to tell you that "
                              `B.append` (B8.unwords . tail) m)
  where m = tail . B8.words . clean $ s

sendTells :: B.ByteString -> Tells -> Net ()
sendTells n (MkTells t) =
  case M.lookup n t of
    Just z  -> mapM_ (\m -> privmsg (n `B.append` ", "
                                       `B.append` m)) $ Z.toList z
    Nothing -> return ()

updateTells :: (B.ByteString, B.ByteString) -> Tells -> Tells
updateTells (n, m) (MkTells t) =
  MkTells $ flip (M.insert n) t $ case M.lookup n t of
                                    Just z  -> Z.insert m z
                                    Nothing -> Z.fromList [m]

dupdateTells :: B.ByteString -> Tells -> Tells
dupdateTells d (MkTells t) = MkTells $ M.delete d t

updateUsers :: B.ByteString -> [B.ByteString] -> [B.ByteString]
updateUsers u us | u `elem` us = us
                 | otherwise   = u : us

dupdateUsers :: B.ByteString -> [B.ByteString] -> [B.ByteString]
dupdateUsers u us | u `elem` us = delete u us
                  | otherwise   = us

updateSeens :: B.ByteString -> UTCTime -> Seens -> Seens
updateSeens u t (MkSeens us) = MkSeens $ M.insert u t us

getSeenTime :: B.ByteString -> Seens -> [B.ByteString] -> B.ByteString
getSeenTime x (MkSeens xs) us | x `elem` us =
  "who, " `B.append` x `B.append` "?? they're right here, yah dingus!"
                              | otherwise   =
                              case M.lookup x xs of
                                Just y  -> B8.pack
                                        $ formatTime defaultTimeLocale
                                                     "%FT%T%z" y
                                Nothing -> "who's that??"

clean :: B.ByteString -> B.ByteString
clean = B.drop 1 . B8.dropWhile (/= ':') . B.drop 1

nickOf :: B.ByteString -> Maybe B.ByteString
nickOf xs = case ':' `B8.split` xs of
              (_:y:_) -> let sn = '!' `B8.split` y
                         in  if sn /= [y]
                               then case headMay sn of
                                      Just snn -> if " " `B8.isInfixOf` snn
                                                    then Nothing
                                                    else headMay sn
                                      Nothing  -> Nothing
                               else Nothing
              _       -> Nothing

privmsg :: B.ByteString -> Net ()
privmsg s | B.length s < 412 =  msg s
          | otherwise        =  msg (B.take 412 s) >> privmsg (B.drop 412 s)
          where msg m        =  write "PRIVMSG" $ chan `B.append` " :"
                                                       `B.append` m
 
write :: B.ByteString -> B.ByteString -> Net ()
write s t = do
    h <- asks socket
    liftIO $ B8.hPutStr h $ st `B.append` "\r\n"
    liftIO $ B8.putStr $ "> " `B.append` st `B.append` "\n"
    where st = s `B.append` " " `B.append` t

nickClean :: B.ByteString -> B.ByteString
nickClean n = case B8.head n of
                '@' -> B.tail n
                ':' -> B.tail n
                _   -> n