{- 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)
--import Data.Maybe (fromMaybe)
import Network.IRC.Fun.Messages.Mask (parseMask)
import Network.IRC.Fun.Messages.Modes (parseUserMode)
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
import Network.IRC.Fun.Messages.Internal.Types
import Text.Regex.Applicative
import Text.Regex.Applicative.Common (decimal)

-------------------------------------------------------------------------------
-- 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 prefix msg of
                Nothing         -> False
                Just (Server _) -> True
                Just (Nick {})  -> False
        cmdOk =
            case command 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 (prefix msg, command msg, parameters msg) of
        (Just (Server s),   NumericCommand n, p : ps) ->
            Right GenericReply
                { sender = s
                , code   = n
                , target = NickTarget p
                , params = 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
-------------------------------------------------------------------------------

analyzeMessage' :: Maybe Prefix
                -> String
                -> [Parameter]
                -> Either String Message
analyzeMessage' prefix cmd params =
    case map toUpper cmd of
    -- Connection registration
        "PASS"     ->
            case params of
                [pass] -> Right $ PassMessage pass
                []     -> Left "Password missing"
                _      -> Left "Too many parameters"
        "NICK"     ->
            case params of
                [nick] -> Right $ NickMessage nick
                []     -> Left "Nickname missing"
                _      -> Left "Too many parameters"
        "USER"     ->
            case params of
                [user, mode, _, realname] ->
                    case match decimal mode :: Maybe Int of
                        (Just m) -> Right $ UserMessage user
                                            (testBit m 3)
                                            (testBit m 2)
                                            realname
                        Nothing  -> Left "<mode> should be a number"
                [_:_:_:_:_:_]             -> Left "Too many parameters"
                _                         -> Left "Too few parameters"
        "OPER"     ->
            case params of
                [name, pass] -> Right $ OperMessage name pass
                [_:_:_:_]    -> Left "Too many parameters"
                _            -> Left "Too few parameters"
        "MODE"     ->
            case params of
                (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 "Invalid user mode string"
                                []    -> Left "Too few parameters"
                                _     -> Left "Too many parameters"
                        (Nothing, Just chan) -> Left "Not implemented yet"
                            {-case parseChannelModeParams rest of
                                Just X ->
                                Nothing ->-}
                        _                    -> Left "First parameter invalid"
                _         ->
                    Left "Too new parameters"
        "SERVICE"  ->
            case params of
                [nick, _, dist, _, _, info] ->
                    case parseMask dist of
                        Just m  -> Right $ ServiceMessage nick m info
                        Nothing -> Left "Distribution mask invalid"
                [_:_:_:_:_:_:_:_]           -> Left "Too many parameters"
                _                           -> Left "Too few parameters"
        "QUIT"     ->
            case params of
                []    -> Right $ QuitMessage Nothing
                [msg] -> Right $ QuitMessage (Just msg)
                _     -> Left "Too many parameters"
        "SQUIT"    ->
            case params of
                [server, comment] -> Right $ SQuitMessage server comment
                [_:_:_:_]         -> Left "Too many parameters"
                _                 -> Left "Too few parameters"
    -- Channel operations
        "JOIN"     ->
            case params of
                ["0"]            -> Right $ JoinMessage Nothing
                [channels]       ->
                    let c = (:) <$> T.channel <*> many (sym ',' *> T.channel)
                    in  case match c channels of
                            Just cs -> Right $ JoinMessage $ Just (cs, [])
                            _       -> Left "Invalid parameters"
                [channels, keys] ->
                    let c = (:) <$> T.channel <*> many (sym ',' *> T.channel)
                        k = (:) <$> T.key     <*> many (sym ',' *> T.key)
                    in  case (match c channels, match k keys) of
                            (Just cs, Just ks) ->
                                Right $ JoinMessage $ Just (cs, ks)
                            _                  ->
                                Left "Invalid parameters"
                _                -> Left "Invalid parameters"
        "PART"     ->
            case params of
                [channels]      ->
                    case match c channels of
                        Just cs -> Right $ PartMessage cs Nothing
                        Nothing -> Left "Invalid channel list"
                [channels, msg] ->
                    case match c channels of
                        Just cs -> Right $ PartMessage cs $ Just msg
                        Nothing -> Left "Invalid channel list"
                _               -> Left "Wrong number of parameters"
                where
                c = (:) <$> T.channel <*> many (sym ',' *> T.channel)
        -- "MODE" -> Channel mode handled by MODE above
        "TOPIC"    ->
            case params of
                [channel]        -> Right $ TopicMessage channel Nothing
                [channel, topic] -> Right $ TopicMessage channel $ Just topic
                []               -> Left "No parameters given"
                _                -> Left "Too many parameters"
        "NAMES"    -> Left "Not implemented yet"
        "LIST"     -> Left "Not implemented yet"
        "INVITE"   -> Left "Not implemented yet"
        "KICK"     -> Left "Not implemented yet"
    -- Sending messages
        "PRIVMSG"  ->
            case params of
                [target, text] ->
                    case match T.msgto target of
                        Nothing -> Left $ "Invalid message target: " ++ target
                        Just t  -> Right $ PrivMsgMessage t text
                (_:_:_:_)      -> Left "Too many parameters"
                _              -> Left "Too few parameters"
        "NOTICE"   ->
            case params of
                [target, text] ->
                    case match T.msgto target of
                        Nothing -> Left $ "Invalid notice target: " ++ target
                        Just t  -> Right $ NoticeMessage t text
                (_:_:_:_)      -> Left "Too many parameters"
                _              -> Left "Too few parameters"
    -- Server queries and commands
        "MOTD"     -> Left "Not implemented yet"
        "LUSERS"   -> Left "Not implemented yet"
        "VERSION"  -> Left "Not implemented yet"
        "STATS"    -> Left "Not implemented yet"
        "LINKS"    -> Left "Not implemented yet"
        "TIME"     -> Left "Not implemented yet"
        "CONNECT"  -> Left "Not implemented yet"
        "TRACE"    -> Left "Not implemented yet"
        "ADMIN"    -> Left "Not implemented yet"
        "INFO"     -> Left "Not implemented yet"
    -- Service query and commands
        "SERVLIST" -> Left "Not implemented yet"
        "SQUERY"   -> Left "Not implemented yet"
    -- User based queries
        "WHO"      -> Left "Not implemented yet"
        "WHOIS"    -> Left "Not implemented yet"
        "WHOWAS"   -> Left "Not implemented yet"
    -- Miscellaneous messages
        "KILL"     -> Left "Not implemented yet"
        "PING"     ->
            case params of
                []       -> Left "No parameters given"
                [s]      -> Right $ PingMessage s Nothing
                [s1, s2] -> Right $ PingMessage s1 (Just s2)
                _        -> Left "Too many parameters"
        "PONG"     ->
            case params of
                []       -> Left "No parameters given"
                [s]      -> Right $ PongMessage s Nothing
                [s1, s2] -> Right $ PongMessage s1 (Just s2)
                _        -> Left "Too many parameters"
        "ERROR"    -> Left "Not implemented yet"
    -- Optional features
        "AWAY"     -> Left "Not implemented yet"
        "REHASH"   -> Left "Not implemented yet"
        "DIE"      -> Left "Not implemented yet"
        "RESTART"  -> Left "Not implemented yet"
        "SUMMON"   -> Left "Not implemented yet"
        "USERS"    -> Left "Not implemented yet"
        "WALLOPS"  -> Left "Not implemented yet"
        "USERHOST" -> Left "Not implemented yet"
        "ISON"     -> Left "Not implemented yet"
        _          -> Left "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 command msg of
            StringCommand c ->
                fmap (Right . SpecificMessage (prefix msg)) $
                analyzeMessage' (prefix msg) c (parameters 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 (sender gr) (target gr)) $
    analyzeReply' (code gr) (target gr) (params 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