{- This file is part of irc-fun-messages.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

module Network.Irc.Messages.Internal.Parse
    ( -- * Parsing
      parseMessage
    , messageIsReply
    , messageToReply
    , parse
      -- * Analysis
    , analyzeMessage
    , analyzeReply
    , analyze
    )
where

import Data.Bits (testBit)
import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Text (Text, pack, unpack, isSuffixOf, stripPrefix, null, last,
                  init)
import Network.Irc.Messages.Mask (parseMask)
import Network.Irc.Messages.Modes (parseUserMode)
import Network.Irc.Messages.Internal.Types
import Network.Irc.Messages.Internal.Util
import Network.Irc.Types
import Prelude hiding (null, last, init)
import Text.Regex.Applicative
import Text.Regex.Applicative.Common (decimal)

import qualified Network.Irc.Messages.Internal.Tokens.Message as T
import qualified Network.Irc.Messages.Internal.Tokens.Other as T
import qualified Network.Irc.Messages.Internal.Tokens.Reply as T
import qualified Network.Irc.Messages.Internal.Tokens.Target as T

-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------

-- | Parse a raw IRC message string into a generic message structure.
parseMessage :: Text -> Maybe GenericMessage
parseMessage t =
    let crlf = "\r\n"
        t' =
            if crlf `isSuffixOf` t
                then t
                else t <> crlf
    in  matcht T.message t'

-- | Check is a given message is a server reply, i.e. has a numeric command and
-- the sender is a server.
messageIsReply :: GenericMessage -> Bool
messageIsReply msg =
    let prefOk =
            case gmPrefix msg of
                Nothing         -> False
                Just (PrefixServer _) -> True
                Just (PrefixNick {})  -> False
        cmdOk =
            case gmCommand msg of
                NamedCmd _   -> False
                NumericCmd _ -> True
    in  prefOk && cmdOk

-- | Try to convert a generic message into a matching reply value. If
-- successful, return 'Right' the reply. If the message isn't a reply, return
-- 'Left' an error message.
messageToReply :: GenericMessage -> Either Text GenericReply
messageToReply msg =
    case (gmPrefix msg, gmCommand msg, gmParams msg) of
        (Just (PrefixServer s), NumericCmd n, p : ps) ->
            Right GenericReply
                { grSender = s
                , grCode   = n
                , grTarget = NickTarget $ Nickname p
                , grParams = ps
                }
        (Just (PrefixServer _), NumericCmd _, []) ->
            Left "No parameters, must have at least one"
        (Just (PrefixNick {}),  NumericCmd _, _) ->
            Left "Sender prefix is a user, not a server"
        (Nothing,               NumericCmd _, _) ->
            Left "No sender prefix"
        (_,                     NamedCmd _,  _) ->
            Left "Command is not numeric"

-- | Parse a raw IRC message string into a generic message structure. If the
-- message is detected to be a server reply, a generic reply structure is
-- returned.
--
-- This is essentially a combination of 'parseMessage' and 'messageToReply'.
parse :: Text -> Maybe (Either GenericReply GenericMessage)
parse t =
    case parseMessage t of
        Nothing  -> Nothing
        Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg

-------------------------------------------------------------------------------
-- Analysis
-------------------------------------------------------------------------------

mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft f (Left x)  = Left $ f x
mapLeft _ (Right x) = Right x

matcht :: Regex a -> Text -> Maybe a
matcht re = match re . unpack

analyzeMessage' :: Maybe Prefix
                -> String
                -> [Parameter]
                -> Either Text Message
analyzeMessage' _prefix cmd params = mapLeft (pack . show) $
    case map toUpper cmd of
    -- Connection registration
        "PASS"     -> req1 params $ \ pass ->
            Right $ PassMessage (Password pass)
        "NICK"     -> req1 params $ \ nick ->
            Right $ NickMessage (Nickname nick)
        "USER"     -> req4 params $ \ user mode _ realname ->
            case matcht decimal mode :: Maybe Int of
                Just m  ->
                    Right $
                    UserMessage
                        (Username user)
                        (testBit m 3)
                        (testBit m 2)
                        (RealName realname)
                Nothing ->
                    Left $
                    InvalidArg
                        (Just 2)
                        (Just "mode")
                        (Just "Should be a number")
        "OPER"     -> req2 params $ \ name pass ->
            Right $ OperMessage (Username name) (Password pass)
        "MODE"     -> min1 params $ \ first rest ->
            case (matcht T.nickname first, matcht T.channel first) of
                (Just nick, _)       ->
                    case rest of
                        [mode] ->
                            case parseUserMode mode of
                                Just (remove, add) ->
                                    Right $ UserModeMessage nick remove add
                                Nothing ->
                                    Left $
                                    InvalidArg (Just 1) (Just "mode") Nothing
                        l     -> Left $ WrongNumArgs (length l) Nothing
                (Nothing, Just _chan) ->
                    Left $ OtherError "Not implemented yet"
                    {-case parseChannelModeParams rest of
                        Just X ->
                        Nothing ->-}
                _                    ->
                    Left $ InvalidArg (Just 1) Nothing Nothing
        "SERVICE"  -> req6 params $ \ nick _ dist _ _ info ->
            case parseMask dist of
                Just m  -> Right $ ServiceMessage (Nickname nick) m info
                Nothing ->
                    Left $
                    InvalidArg (Just 3) (Just "distribution mask") Nothing
        "QUIT"     -> req0m1 params $ \ msg ->
            Right $ QuitMessage (fmap Comment msg)
        "SQUIT"    -> req2 params $ \ server comment ->
            Right $ SQuitMessage (Hostname server) (Comment comment)
    -- Channel operations
        "JOIN"     -> req1m2 params $ \ chans mkeys ->
            case (chans, mkeys) of
                ("0", Nothing) -> Right $ JoinMessage Nothing
                _              ->
                    let mcs = matcht (listOf T.channel) chans
                        mks = maybe (Just []) (matcht $ listOf T.key) mkeys
                    in  case (mcs, mks) of
                            (Nothing, _)       ->
                                Left $
                                InvalidArg (Just 1) (Just "channels") Nothing
                            (Just _,  Nothing) ->
                                Left $
                                InvalidArg (Just 2) (Just "keys") Nothing
                            (Just cs, Just ks) ->
                                Right $ JoinMessage $ Just (cs, ks)
        "PART"     -> req1m2 params $ \ chans msg ->
            case matcht (listOf T.channel) chans of
                Just cs -> Right $ PartMessage cs (fmap Comment msg)
                Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing
        -- "MODE" -> Channel mode handled by MODE above
        "TOPIC"    -> req1m2 params $ \ chan topic ->
            Right $ TopicMessage (Channel chan) (fmap ChannelTopic topic)
        "NAMES"    ->
            case params of
                []              -> Right $ NamesMessage [] Nothing
                [chans]         ->
                    case matcht (listOf T.channel) chans of
                        Just cs -> Right $ NamesMessage cs Nothing
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                [chans, target] ->
                    case matcht (listOf T.channel) chans of
                        Just cs ->
                            Right $ NamesMessage cs (Just $ Hostname target)
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                l               ->
                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)
        "LIST"     ->
            case params of
                []              -> Right $ ListMessage [] Nothing
                [chans]         ->
                    case matcht (listOf T.channel) chans of
                        Just cs -> Right $ ListMessage cs Nothing
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                [chans, target] ->
                    case matcht (listOf T.channel) chans of
                        Just cs ->
                            Right $ ListMessage cs (Just $ Hostname target)
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                l               ->
                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)
        "INVITE"   -> req2 params $ \ nick chan ->
            case (matcht T.nickname nick, matcht T.channel chan) of
                (Nothing, _)      ->
                    Left $ InvalidArg (Just 1) (Just "nickname") Nothing
                (Just _, Nothing) ->
                    Left $ InvalidArg (Just 2) (Just "channel") Nothing
                (Just n,  Just c) -> Right $ InviteMessage n c
        "KICK"     -> req2m3 params $ \ chans users comment ->
            let mcs = matcht (listOf T.channel) chans
                ucs = matcht (listOf T.user) users
            in  case (mcs, ucs) of
                    (Nothing, _)       ->
                        Left $ InvalidArg (Just 1) (Just "channels") Nothing
                    (Just _,  Nothing) ->
                        Left $ InvalidArg (Just 2) (Just "users") Nothing
                    (Just cs, Just us) ->
                        let lc = length cs
                            lu = length us
                        in  if lc == 1 || lc == lu
                                then Right $
                                     KickMessage cs us (fmap Comment comment)
                                else Left $ OtherError "Invalid list lengths"
    -- Sending messages
        "PRIVMSG"  -> req2 params $ \ target text ->
            case matcht T.msgto target of
                Nothing ->
                    Left $ InvalidArg (Just 1) (Just "target") (Just target)
                Just t ->
                    Right $ case stripPrefix "\1ACTION " text of
                        Just s  ->
                            if not (null s) && last s == '\1'
                                then PrivActionMessage t (MsgContent $ init s)
                                else PrivMsgMessage t (MsgContent text)
                        Nothing -> PrivMsgMessage t (MsgContent text)
        "NOTICE"   -> req2 params $ \ target text ->
            case matcht T.msgto target of
                Nothing ->
                    Left $ InvalidArg (Just 1) (Just "target") (Just target)
                Just t  ->
                    Right $ NoticeMessage t (MsgContent text)
    -- Server queries and commands
        "MOTD"     -> req0m1 params $ \ target ->
            Right $ MotdMessage (fmap Hostname target)
        "LUSERS"   -> Left $ OtherError "Not implemented yet"
        "VERSION"  -> Left $ OtherError "Not implemented yet"
        "STATS"    -> Left $ OtherError "Not implemented yet"
        "LINKS"    -> Left $ OtherError "Not implemented yet"
        "TIME"     -> Left $ OtherError "Not implemented yet"
        "CONNECT"  -> Left $ OtherError "Not implemented yet"
        "TRACE"    -> Left $ OtherError "Not implemented yet"
        "ADMIN"    -> Left $ OtherError "Not implemented yet"
        "INFO"     -> req0m1 params $ \ target ->
            case target of
                Nothing -> Right $ InfoMessage Nothing
                Just t  ->
                    Right $ case matcht T.nickname t of
                        Just n  ->
                            InfoMessage (Just $ NickTarget n)
                        Nothing ->
                            InfoMessage (Just $ ServerTarget $ Hostname t)
    -- Service query and commands
        "SERVLIST" -> Left $ OtherError "Not implemented yet"
        "SQUERY"   -> Left $ OtherError "Not implemented yet"
    -- User based queries
        "WHO"      -> Left $ OtherError "Not implemented yet"
        "WHOIS"    -> Left $ OtherError "Not implemented yet"
        "WHOWAS"   -> Left $ OtherError "Not implemented yet"
    -- Miscellaneous messages
        "KILL"     -> Left $ OtherError "Not implemented yet"
        "PING"     -> req1m2 params $ \ s1 s2 ->
            Right $ PingMessage (Hostname s1) (fmap Hostname s2)
        "PONG"     -> req1m2 params $ \ s1 s2 ->
            Right $ PongMessage (Hostname s1) (fmap Hostname s2)
        "ERROR"    -> Left $ OtherError "Not implemented yet"
    -- Optional features
        "AWAY"     -> req0m1 params $ \ text ->
            Right $ AwayMessage (fmap MsgContent text)
        "REHASH"   -> Left $ OtherError "Not implemented yet"
        "DIE"      -> Left $ OtherError "Not implemented yet"
        "RESTART"  -> Left $ OtherError "Not implemented yet"
        "SUMMON"   -> Left $ OtherError "Not implemented yet"
        "USERS"    -> Left $ OtherError "Not implemented yet"
        "WALLOPS"  -> Left $ OtherError "Not implemented yet"
        "USERHOST" -> Left $ OtherError "Not implemented yet"
        "ISON"     -> Left $ OtherError "Not implemented yet"
        _          -> Left $ OtherError "Unrecognized command"

-- | Read a generic message structure into specific message details. Return
-- 'Left' an error description if analysis fails. If the message is detected
-- to be a reply, return a generic reply structure without analyzing.
analyzeMessage
    :: GenericMessage
    -> Either Text (Either GenericReply SpecificMessage)
analyzeMessage msg =
    if messageIsReply msg
        then fmap Left $ messageToReply msg
        else case gmCommand msg of
            NamedCmd c ->
                fmap (Right . SpecificMessage (gmPrefix msg)) $
                analyzeMessage'
                    (gmPrefix msg)
                    (unpack $ unCmdName c)
                    (gmParams msg)
            _               ->
                Left "Implementation error"

analyzeReply' :: Int -> Target -> [Parameter] -> Either Text Reply
analyzeReply' c _ params =
    case c of
        353 ->
            case params of
                [priv, chan, nicks] ->
                    maybe (Left "Invalid parameters") Right $ do
                        chan' <- matcht T.channel chan
                        priv' <- matcht T.chanpriv priv
                        pnicks <- matcht T.prefnicks nicks
                        return $ NamesReply priv' chan' pnicks
                (_:_:_:_:_) -> Left "Too many parameters"
                _ -> Left "Too few parameters"
        _   -> Left "Not implemented yet"

-- | Read a generic reply structure into specific reply details. Return
-- 'Left' an error description if analysis fails.
analyzeReply :: GenericReply -> Either Text SpecificReply
analyzeReply gr =
    fmap (SpecificReply (grSender gr) (grTarget gr)) $
    analyzeReply' (unCmdNumber $ grCode gr) (grTarget gr) (grParams gr)

-- | Read a generic reply structure into specific message or reply details.
-- Return 'Left' an error description if analysis fails.
--
-- This is essentially a combination or 'analyzeMessage' and 'analyzeReply'.
analyze :: GenericMessage
        -> Either Text (Either SpecificReply SpecificMessage)
analyze gm =
    case analyzeMessage gm of
        Left e            -> Left e
        Right (Left rpl)  -> fmap Left $ analyzeReply rpl
        Right (Right msg) -> Right $ Right msg