--
-- | The IRC module processes the IRC protocol and provides a nice API for sending
--   and recieving IRC messages with an IRC server.
--
module IRC ( IrcMessage
           , readerLoop
           , writerLoop
           , offlineReaderLoop
           , offlineWriterLoop
           , privmsg
           , quit
           , timeReply
           , errShowMsg -- TODO: remove
           , user
           , setNick
           ) where

import Message
import Lib.Util (split, breakOnGlue, clean)
import qualified Lib.Util as Util (concatWith) 

import Data.List (isPrefixOf)
import Data.Char (chr,isSpace)

import Control.Concurrent
import Control.Exception
import Control.Monad.Trans ( MonadIO, liftIO )
import Control.Monad (when)

import System.IO (Handle, hGetLine)
import System.Console.Readline  (readline, addHistory)

import qualified Data.ByteString.Char8 as P (pack, hPut, hPutStrLn)


-- | An IRC message is a prefix, a command and a list of parameters.
data IrcMessage
  = IrcMessage {
        msgPrefix   :: !String,
        msgCommand  :: !String,
        msgParams   :: ![String]
  }
  deriving (Show)

instance Message IrcMessage where
    nick        = IRC.nick
    fullName    = IRC.fullName
    names       = IRC.names
    channels    = IRC.channels
    joinChannel = IRC.join
    partChannel = IRC.part
    getTopic    = IRC.getTopic
    setTopic    = IRC.setTopic
    body        = IRC.msgParams
    command     = IRC.msgCommand

-- | 'mkMessage' creates a new message from a cmd and a list of parameters.
mkMessage :: String -- ^ Command
          -> [String] -- ^ Parameters
          -> IrcMessage -- ^ Returns: The created message

mkMessage cmd params = IrcMessage { msgPrefix = "", msgCommand = cmd, msgParams = params }

-- | 'nick' extracts the nickname involved in a given message.
nick :: IrcMessage -> String
nick = fst . breakOnGlue "!" . msgPrefix

-- | 'fullName' extracts the full user name involved in a given message.
fullName :: IrcMessage -> String
fullName = snd . breakOnGlue "!" . msgPrefix

-- | 'channels' extracts the channels a IrcMessage operate on.
channels :: IrcMessage -> [String]
channels msg
  = let cstr = head $ msgParams msg
    in map (\(x:xs) -> if x == ':' then xs else x:xs) (split "," cstr)
           -- solves what seems to be an inconsistency in the parser

-- | 'privmsg' creates a private message to the person designated.
privmsg :: String -- ^ Who should recieve the message (nick)
        -> String -- ^ What is the message?
        -> IrcMessage -- ^ Constructed message
privmsg who msg = if action then mkMessage "PRIVMSG" [who, ':':(chr 0x1):("ACTION " ++ clean_msg ++ ((chr 0x1):[]))]
                            else mkMessage "PRIVMSG" [who, ':' : clean_msg]
    where cleaned_msg = case concatMap clean msg of
              str@('@':_) -> ' ':str
              str         -> str
          (clean_msg,action) = case cleaned_msg of
              ('/':'m':'e':r) -> (dropWhile isSpace r,True)
              str             -> (str,False)

-- | 'setTopic' takes a channel and a topic. It then returns the message
--   which sets the channels topic.
setTopic :: String -- ^ Channel
         -> String -- ^ Topic
         -> IrcMessage
setTopic chan topic = mkMessage "TOPIC" [chan, ':' : topic]

-- | 'getTopic' Returns the topic for a channel, given as a String
getTopic :: String -> IrcMessage
getTopic chan = mkMessage "TOPIC" [chan]

-- | 'quit' creates a server QUIT message. The input string given is the
--   quit message, given to other parties when leaving the network.
quit :: String -> IrcMessage
quit msg = mkMessage "QUIT" [':' : msg]

-- | 'join' creates a join message. String given is the location (channel)
--   to join.
join :: String -> IrcMessage
join loc = mkMessage "JOIN" [loc]

-- | 'part' parts the channel given.
part :: String -> IrcMessage
part loc = mkMessage "PART" [loc]

-- | 'names' builds a NAMES message from a list of channels.
names :: [String] -> IrcMessage
names chans = mkMessage "NAMES" [Util.concatWith "," chans]

-- | Construct a privmsg from the CTCP TIME notice, to feed up to
-- the @localtime-reply plugin, which then passes the output to
-- the appropriate client.
timeReply :: IrcMessage -> IrcMessage
timeReply msg    = 
   IrcMessage { msgPrefix  = msgPrefix (msg)
              , msgCommand = "PRIVMSG"
              , msgParams  = [head (msgParams msg)
                             ,":@localtime-reply " ++ (IRC.nick msg) ++ ":" ++
                                (init $ drop 7 (last (msgParams msg))) ]
              }

-- Only needed for Base.hs
errShowMsg :: IrcMessage -> String
errShowMsg msg = "ERROR> <" ++ msgPrefix msg ++
      "> [" ++ msgCommand msg ++ "] " ++ show (msgParams msg)

user :: String -> String -> String -> IrcMessage
user nick_ server ircname = IRC.mkMessage "USER" [nick_, "localhost", server, ircname]

setNick :: String -> IrcMessage
setNick nick_ = IRC.mkMessage "NICK" [nick_]
----------------------------------------------------------------------
-- Encoding and decoding of messages

-- | 'encodeMessage' takes a message and converts it to a function.
--   giving this function a string will attach the string to the message
--   and output a string containing IRC protocol commands ready for writing
--   on the outgoing stream socket.
encodeMessage :: IrcMessage -> String -> String
encodeMessage msg
  = encodePrefix (msgPrefix msg) . encodeCommand (msgCommand msg)
          . encodeParams (msgParams msg)
  where
    encodePrefix [] = id
    encodePrefix prefix = showChar ':' . showString prefix . showChar ' '

    encodeCommand cmd = showString cmd

    encodeParams [] = id
    encodeParams (p:ps) = showChar ' ' . showString p . encodeParams ps

-- | 'decodeMessage' Takes an input line from the IRC protocol stream
--   and decodes it into a message.
decodeMessage :: String -> IrcMessage
decodeMessage line =
    let (prefix, rest1) = decodePrefix (,) line
        (cmd, rest2)    = decodeCmd (,) rest1
        params          = decodeParams rest2
    in IrcMessage { msgPrefix = prefix, msgCommand = cmd, msgParams = params }
  where
    decodePrefix k (':':cs) = decodePrefix' k cs
      where decodePrefix' j ""       = j "" ""
            decodePrefix' j (' ':ds) = j "" ds
            decodePrefix' j (c:ds)   = decodePrefix' (j . (c:)) ds

    decodePrefix k cs = k "" cs

    decodeCmd k []       = k "" ""
    decodeCmd k (' ':cs) = k "" cs
    decodeCmd k (c:cs)   = decodeCmd (k . (c:)) cs

    decodeParams :: String -> [String]
    decodeParams xs = decodeParams' [] [] xs
      where
        decodeParams' param params []
          | null param = reverse params
          | otherwise  = reverse (reverse param : params)
        decodeParams' param params (' ' : cs)
          | null param = decodeParams' [] params cs
          | otherwise  = decodeParams' [] (reverse param : params) cs
        decodeParams' param params rest@(c@':' : cs)
          | null param = reverse (rest : params)
          | otherwise  = decodeParams' (c:param) params cs
        decodeParams' param params (c:cs) = decodeParams' (c:param) params cs

------------------------------------------------------------------------
--
-- Lambdabot is asynchronous. We has reader and writer threads, and they
-- don't know about each other.
--
-- However, in Offline mode, we need to keep them in lock step. this
-- complicates things.
--
-- Online reader loop, the mvars are unused

readerLoop :: ThreadId -> Pipe IrcMessage -> Pipe IrcMessage -> Handle -> MVar () -> MVar () -> IO ()
readerLoop th chanr chanw h _ _ = handleIO th $ do
    io (putStrLn "Forking threads ...")
    readerLoop'
  where
    readerLoop' = do
        line <- hGetLine h
        let line' = filter (\c -> c /= '\n' && c /= '\r') line
        if pING `isPrefixOf` line'
            then writeChan chanw (Just $ IRC.mkMessage "PONG" [drop 5 line'])
            else writeChan chanr (Just $ IRC.decodeMessage line')
        readerLoop'

    pING = "PING "
{-# INLINE readerLoop #-}

--
-- online writer loop
--
-- Implements flood control: RFC 2813, section 5.8
--
writerLoop :: ThreadId -> Pipe IrcMessage -> Handle -> MVar () -> MVar () -> IO ()
writerLoop th chanw h _ _ = handleIO th $ do
    sem1 <- newQSem 0
    sem2 <- newQSem 5
    forkIO $ sequence_ . repeat $ do
           waitQSem sem1
           threadDelay 2000000
           signalQSem sem2
    writerLoop' (sem1,sem2)
  where
    writerLoop' sems@(sem1,sem2) = do
           mmsg <- readChan chanw
           waitQSem sem2
           case mmsg of
            Nothing  -> return ()
            Just msg -> P.hPut h $ P.pack $ IRC.encodeMessage msg "\r"
           signalQSem sem1
           writerLoop' sems
{-# INLINE writerLoop #-}


-- 
-- Offline reader and writer loops. A prompt with line editing
-- Takes a string from stdin, wraps it as an irc message, and _blocks_
-- waiting for the writer thread (to keep things in sync).
--
-- We (incorrectly) assume there's at least one write for every read.
-- If a command returns no output (i.e. @more on an empty buffer) then
-- we block in offline mode :(
-- 
-- the mvars are used to keep the normally async threads in step.
--
offlineReaderLoop :: ThreadId -> Pipe IrcMessage -> Pipe IrcMessage -> Handle
                  -> MVar () -> MVar () -> IO ()
offlineReaderLoop th chanr _chanw _h syncR syncW = handleIO th readerLoop'
  where
    readerLoop' = do
        takeMVar syncR  -- wait till writer lets us proceed
        s <- readline "lambdabot> " -- read stdin
        case s of
            Nothing -> error "<eof>"
            Just x -> let s' = dropWhile isSpace x
                      in if null s' then putMVar syncR () >> readerLoop' else do
                addHistory s'

                let mmsg = case s' of
                            "quit" -> Nothing
                            '>':xs -> Just $ "@run " ++ xs
                            _      -> Just $ "@"     ++ dropWhile (== ' ') s'

                msg <- case mmsg of
                    Nothing   -> error "<quit>"
                    Just msg' -> return msg'

                let m  = IRC.IrcMessage { IRC.msgPrefix  = "null!n=user@null"
                                        , IRC.msgCommand = "PRIVMSG"
                                        , IRC.msgParams  = ["#haskell",":" ++ msg ] }
                writeChan chanr (Just m)
                putMVar syncW () -- let writer go 
                readerLoop'

--
-- Offline writer. Print to stdout
--
offlineWriterLoop :: ThreadId -> Pipe IrcMessage -> Handle -> MVar () -> MVar () -> IO ()
offlineWriterLoop th chanw h syncR syncW = handleIO th writerLoop'
  where
    writerLoop' = do

        takeMVar syncW -- wait for reader to let us go

        let loop = do
            mmsg <- readChan chanw
            case mmsg of
                Nothing  -> return ()
                Just msg -> do
                    let str = case (tail . IRC.msgParams) msg of
                                []    -> []
                                (x:_) -> tail x
                    P.hPutStrLn h (P.pack str)
            threadDelay 25 -- just for fun.
            b <- isEmptyChan chanw
            when (not b) loop
        loop

        putMVar syncR () -- now allow writer to go
        writerLoop'

-- | convenience:
io :: forall a (m :: * -> *). (MonadIO m) => IO a -> m a
io = liftIO
{-# INLINE io #-}

-- Thread handler, just catch particular things we want to throw out to
-- the main thread, to force an exit. errorCalls are used by the
-- reader/writer loops to exit. ioErrors are probably sockets closing.
handleIO :: ThreadId -> IO () -> IO ()
handleIO th = handleJust
    (\e -> case () of { _
                | Just _ <- errorCalls e -> Just e
                | Just _ <- ioErrors   e -> Just e
                | otherwise              -> Nothing
    }) (\e -> throwTo th (error (show e)))