module Network.Irc.Messages.Internal.Parse
(
parseMessage
, messageIsReply
, messageToReply
, parse
, 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
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'
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
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 :: Text -> Maybe (Either GenericReply GenericMessage)
parse t =
case parseMessage t of
Nothing -> Nothing
Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg
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
"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"
_ ->
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)
"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
"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"
"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)
"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)
"SERVLIST" -> Left $ OtherError "Not implemented yet"
"SQUERY" -> Left $ OtherError "Not implemented yet"
"WHO" -> Left $ OtherError "Not implemented yet"
"WHOIS" -> Left $ OtherError "Not implemented yet"
"WHOWAS" -> Left $ OtherError "Not implemented yet"
"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"
"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"
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"
analyzeReply :: GenericReply -> Either Text SpecificReply
analyzeReply gr =
fmap (SpecificReply (grSender gr) (grTarget gr)) $
analyzeReply' (unCmdNumber $ grCode gr) (grTarget gr) (grParams gr)
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