{- 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, 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