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)
import Network.IRC.Fun.Messages.Mask (parseMask)
import Network.IRC.Fun.Messages.Modes (parseUserMode)
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
import Network.IRC.Fun.Messages.Internal.Types
import Text.Regex.Applicative
import Text.Regex.Applicative.Common (decimal)
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 prefix msg of
Nothing -> False
Just (Server _) -> True
Just (Nick {}) -> False
cmdOk =
case command msg of
StringCommand _ -> False
NumericCommand _ -> True
in prefOk && cmdOk
messageToReply :: GenericMessage -> Either String GenericReply
messageToReply msg =
case (prefix msg, command msg, parameters msg) of
(Just (Server s), NumericCommand n, p : ps) ->
Right GenericReply
{ sender = s
, code = n
, target = NickTarget p
, params = 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
analyzeMessage' :: Maybe Prefix
-> String
-> [Parameter]
-> Either String Message
analyzeMessage' prefix cmd params =
case map toUpper cmd of
"PASS" ->
case params of
[pass] -> Right $ PassMessage pass
[] -> Left "Password missing"
_ -> Left "Too many parameters"
"NICK" ->
case params of
[nick] -> Right $ NickMessage nick
[] -> Left "Nickname missing"
_ -> Left "Too many parameters"
"USER" ->
case params of
[user, mode, _, realname] ->
case match decimal mode :: Maybe Int of
(Just m) -> Right $ UserMessage user
(testBit m 3)
(testBit m 2)
realname
Nothing -> Left "<mode> should be a number"
[_:_:_:_:_:_] -> Left "Too many parameters"
_ -> Left "Too few parameters"
"OPER" ->
case params of
[name, pass] -> Right $ OperMessage name pass
[_:_:_:_] -> Left "Too many parameters"
_ -> Left "Too few parameters"
"MODE" ->
case params of
(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 "Invalid user mode string"
[] -> Left "Too few parameters"
_ -> Left "Too many parameters"
(Nothing, Just chan) -> Left "Not implemented yet"
_ -> Left "First parameter invalid"
_ ->
Left "Too new parameters"
"SERVICE" ->
case params of
[nick, _, dist, _, _, info] ->
case parseMask dist of
Just m -> Right $ ServiceMessage nick m info
Nothing -> Left "Distribution mask invalid"
[_:_:_:_:_:_:_:_] -> Left "Too many parameters"
_ -> Left "Too few parameters"
"QUIT" ->
case params of
[] -> Right $ QuitMessage Nothing
[msg] -> Right $ QuitMessage (Just msg)
_ -> Left "Too many parameters"
"SQUIT" ->
case params of
[server, comment] -> Right $ SQuitMessage server comment
[_:_:_:_] -> Left "Too many parameters"
_ -> Left "Too few parameters"
"JOIN" ->
case params of
["0"] -> Right $ JoinMessage Nothing
[channels] ->
let c = (:) <$> T.channel <*> many (sym ',' *> T.channel)
in case match c channels of
Just cs -> Right $ JoinMessage $ Just (cs, [])
_ -> Left "Invalid parameters"
[channels, keys] ->
let c = (:) <$> T.channel <*> many (sym ',' *> T.channel)
k = (:) <$> T.key <*> many (sym ',' *> T.key)
in case (match c channels, match k keys) of
(Just cs, Just ks) ->
Right $ JoinMessage $ Just (cs, ks)
_ ->
Left "Invalid parameters"
_ -> Left "Invalid parameters"
"PART" ->
case params of
[channels] ->
case match c channels of
Just cs -> Right $ PartMessage cs Nothing
Nothing -> Left "Invalid channel list"
[channels, msg] ->
case match c channels of
Just cs -> Right $ PartMessage cs $ Just msg
Nothing -> Left "Invalid channel list"
_ -> Left "Wrong number of parameters"
where
c = (:) <$> T.channel <*> many (sym ',' *> T.channel)
"TOPIC" ->
case params of
[channel] -> Right $ TopicMessage channel Nothing
[channel, topic] -> Right $ TopicMessage channel $ Just topic
[] -> Left "No parameters given"
_ -> Left "Too many parameters"
"NAMES" -> Left "Not implemented yet"
"LIST" -> Left "Not implemented yet"
"INVITE" -> Left "Not implemented yet"
"KICK" -> Left "Not implemented yet"
"PRIVMSG" ->
case params of
[target, text] ->
case match T.msgto target of
Nothing -> Left $ "Invalid message target: " ++ target
Just t -> Right $ PrivMsgMessage t text
(_:_:_:_) -> Left "Too many parameters"
_ -> Left "Too few parameters"
"NOTICE" ->
case params of
[target, text] ->
case match T.msgto target of
Nothing -> Left $ "Invalid notice target: " ++ target
Just t -> Right $ NoticeMessage t text
(_:_:_:_) -> Left "Too many parameters"
_ -> Left "Too few parameters"
"MOTD" -> Left "Not implemented yet"
"LUSERS" -> Left "Not implemented yet"
"VERSION" -> Left "Not implemented yet"
"STATS" -> Left "Not implemented yet"
"LINKS" -> Left "Not implemented yet"
"TIME" -> Left "Not implemented yet"
"CONNECT" -> Left "Not implemented yet"
"TRACE" -> Left "Not implemented yet"
"ADMIN" -> Left "Not implemented yet"
"INFO" -> Left "Not implemented yet"
"SERVLIST" -> Left "Not implemented yet"
"SQUERY" -> Left "Not implemented yet"
"WHO" -> Left "Not implemented yet"
"WHOIS" -> Left "Not implemented yet"
"WHOWAS" -> Left "Not implemented yet"
"KILL" -> Left "Not implemented yet"
"PING" ->
case params of
[] -> Left "No parameters given"
[s] -> Right $ PingMessage s Nothing
[s1, s2] -> Right $ PingMessage s1 (Just s2)
_ -> Left "Too many parameters"
"PONG" ->
case params of
[] -> Left "No parameters given"
[s] -> Right $ PongMessage s Nothing
[s1, s2] -> Right $ PongMessage s1 (Just s2)
_ -> Left "Too many parameters"
"ERROR" -> Left "Not implemented yet"
"AWAY" -> Left "Not implemented yet"
"REHASH" -> Left "Not implemented yet"
"DIE" -> Left "Not implemented yet"
"RESTART" -> Left "Not implemented yet"
"SUMMON" -> Left "Not implemented yet"
"USERS" -> Left "Not implemented yet"
"WALLOPS" -> Left "Not implemented yet"
"USERHOST" -> Left "Not implemented yet"
"ISON" -> Left "Not implemented yet"
_ -> Left "Unrecognized command"
analyzeMessage :: GenericMessage
-> Either String (Either GenericReply SpecificMessage)
analyzeMessage msg =
if messageIsReply msg
then fmap Left $ messageToReply msg
else case command msg of
StringCommand c ->
fmap (Right . SpecificMessage (prefix msg)) $
analyzeMessage' (prefix msg) c (parameters 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 (sender gr) (target gr)) $
analyzeReply' (code gr) (target gr) (params 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