{- This file is part of irc-fun-messages. - - Written in 2015 by fr33domlover . - - ♡ 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 - . -} 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 " 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