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