module Network.IRC.Fun.Messages.Internal.Parse
(
parseMessage
, messageIsReply
, messageToReply
, parse
, 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
parseMessage :: String -> Maybe GenericMessage
parseMessage s =
match T.message $ if "\r\n" `isSuffixOf` s then s else s ++ "\r\n"
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
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 :: String -> Maybe (Either GenericReply GenericMessage)
parse s =
case parseMessage s 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 y) = Right y
analyzeMessage' :: Maybe Prefix
-> String
-> [Parameter]
-> Either String Message
analyzeMessage' _prefix cmd params = mapLeft show $
case map toUpper cmd of
"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"
_ ->
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
"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
"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"
"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
"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)
"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 s1 s2
"PONG" -> req1m2 params $ \ s1 s2 -> Right $ PongMessage s1 s2
"ERROR" -> Left $ OtherError "Not implemented yet"
"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"
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"
analyzeReply :: GenericReply -> Either String SpecificReply
analyzeReply gr =
fmap (SpecificReply (grSender gr) (grTarget gr)) $
analyzeReply' (grCode gr) (grTarget gr) (grParams gr)
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