irc-fun-messages-0.3.0.0: src/Network/IRC/Fun/Messages/Internal/Parse.hs
{- 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/>.
-}
{-# LANGUAGE OverloadedStrings #-}
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.Monoid ((<>))
import Data.Text (Text, pack, unpack, isSuffixOf, stripPrefix, null, last,
init)
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 Network.IRC.Fun.Types
import Prelude hiding (null, last, init)
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 :: 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