{- 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/>.
 -}

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

import Data.Bits (testBit)
import Data.Char (toUpper)
import Data.List (isSuffixOf, stripPrefix)
import Network.IRC.Fun.Messages.Mask (parseMask)
import Network.IRC.Fun.Messages.Modes (parseUserMode)
import Network.IRC.Fun.Messages.Internal.Types
import Network.IRC.Fun.Messages.Internal.Util
import Text.Regex.Applicative
import Text.Regex.Applicative.Common (decimal)

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

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

-- | Parse a raw IRC message string into a generic message structure.
parseMessage :: String -> Maybe GenericMessage
parseMessage s =
    match T.message $ if "\r\n" `isSuffixOf` s then s else s ++ "\r\n"

-- | 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 (Server _) -> True
                Just (Nick {})  -> False
        cmdOk =
            case gmCommand msg of
                StringCommand _  -> False
                NumericCommand _ -> 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 String GenericReply
messageToReply msg =
    case (gmPrefix msg, gmCommand msg, gmParams msg) of
        (Just (Server s),   NumericCommand n, p : ps) ->
            Right GenericReply
                { grSender = s
                , grCode   = n
                , grTarget = NickTarget p
                , grParams = ps
                }
        (Just (Server _),   NumericCommand _, []) ->
            Left "No parameters, must have at least one"
        (Just (Nick {}), NumericCommand _, _) ->
            Left "Sender prefix is a user, not a server"
        (Nothing,           NumericCommand _, _) ->
            Left "No sender prefix"
        (_,                 StringCommand _,  _) ->
            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 :: String -> Maybe (Either GenericReply GenericMessage)
parse s =
    case parseMessage s 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 y) = Right y

analyzeMessage' :: Maybe Prefix
                -> String
                -> [Parameter]
                -> Either String Message
analyzeMessage' _prefix cmd params = mapLeft show $
    case map toUpper cmd of
    -- Connection registration
        "PASS"     -> req1 params $ \ pass -> Right $ PassMessage pass
        "NICK"     -> req1 params $ \ nick -> Right $ NickMessage nick
        "USER"     -> req4 params $ \ user mode _ realname ->
            case match decimal mode :: Maybe Int of
                Just m  ->
                    Right $
                    UserMessage user (testBit m 3) (testBit m 2) realname
                Nothing ->
                    Left $
                    InvalidArg
                        (Just 2)
                        (Just "mode")
                        (Just "Should be a number")
        "OPER"     -> req2 params $ \ name pass ->
                        Right $ OperMessage name pass
        "MODE"     -> min1 params $ \ first rest ->
            case (match T.nickname first, match 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 nick m info
                Nothing ->
                    Left $
                    InvalidArg (Just 3) (Just "distribution mask") Nothing
        "QUIT"     -> req0m1 params $ \ msg -> Right $ QuitMessage msg
        "SQUIT"    -> req2 params $ \ server comment ->
            Right $ SQuitMessage server comment
    -- Channel operations
        "JOIN"     -> req1m2 params $ \ chans mkeys ->
            case (chans, mkeys) of
                ("0", Nothing) -> Right $ JoinMessage Nothing
                _              ->
                    let mcs = match (listOf T.channel) chans
                        mks = maybe (Just []) (match $ 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 match (listOf T.channel) chans of
                Just cs -> Right $ PartMessage cs msg
                Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing
        -- "MODE" -> Channel mode handled by MODE above
        "TOPIC"    -> req1m2 params $ \ chan topic ->
            Right $ TopicMessage chan topic
        "NAMES"    ->
            case params of
                []              -> Right $ NamesMessage [] Nothing
                [chans]         ->
                    case match (listOf T.channel) chans of
                        Just cs -> Right $ NamesMessage cs Nothing
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                [chans, target] ->
                    case match (listOf T.channel) chans of
                        Just cs -> Right $ NamesMessage cs (Just 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 match (listOf T.channel) chans of
                        Just cs -> Right $ ListMessage cs Nothing
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                [chans, target] ->
                    case match (listOf T.channel) chans of
                        Just cs -> Right $ ListMessage cs (Just target)
                        Nothing ->
                            Left $
                            InvalidArg (Just 1) (Just "channels") Nothing
                l               ->
                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)
        "INVITE"   -> req2 params $ \ nick chan ->
            case (match T.nickname nick, match 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 = match (listOf T.channel) chans
                ucs = match (listOf T.nickname) 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 comment
                                else Left $ OtherError "Invalid list lengths"
    -- Sending messages
        "PRIVMSG"  -> req2 params $ \ target text ->
            case match 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 $ init s
                                else PrivMsgMessage t text
                        Nothing -> PrivMsgMessage t text
        "NOTICE"   -> req2 params $ \ target text ->
            case match T.msgto target of
                Nothing ->
                    Left $ InvalidArg (Just 1) (Just "target") (Just target)
                Just t  ->
                    Right $ NoticeMessage t text
    -- Server queries and commands
        "MOTD"     -> req0m1 params $ \ target -> Right $ MotdMessage 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 match T.nickname t of
                        Just n  -> InfoMessage (Just $ NickTarget n)
                        Nothing -> InfoMessage (Just $ ServerTarget 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 s1 s2
        "PONG"     -> req1m2 params $ \ s1 s2 -> Right $ PongMessage s1 s2
        "ERROR"    -> Left $ OtherError "Not implemented yet"
    -- Optional features
        "AWAY"     -> req0m1 params $ \ text -> Right $ AwayMessage 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 String (Either GenericReply SpecificMessage)
analyzeMessage msg =
    if messageIsReply msg
        then fmap Left $ messageToReply msg
        else case gmCommand msg of
            StringCommand c ->
                fmap (Right . SpecificMessage (gmPrefix msg)) $
                analyzeMessage' (gmPrefix msg) c (gmParams msg)
            _               ->
                Left "Implementation error"

analyzeReply' :: Int -> Target -> [Parameter] -> Either String Reply
analyzeReply' c _ params =
    case c of
        353 ->
            case params of
                [priv, chan, nicks] ->
                    maybe (Left "Invalid parameters") Right $ do
                        chan' <- match T.channel chan
                        priv' <- match T.chanpriv priv
                        pnicks <- match 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 String SpecificReply
analyzeReply gr =
    fmap (SpecificReply (grSender gr) (grTarget gr)) $
    analyzeReply' (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 String (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