irc-fun-messages-0.1.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/>.
-}
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.List (isSuffixOf)
--import Data.Maybe (fromMaybe)
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)
-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------
-- | Parse a raw IRC message string into a generic message structure.
parseMessage :: String -> Maybe GenericMessage
parseMessage s =
match T.message $ if "\r\n" `isSuffixOf` s then s else s ++ "\r\n"
-- | 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 prefix msg of
Nothing -> False
Just (Server _) -> True
Just (Nick {}) -> False
cmdOk =
case command msg of
StringCommand _ -> False
NumericCommand _ -> 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 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 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 :: String -> Maybe (Either GenericReply GenericMessage)
parse s =
case parseMessage s of
Nothing -> Nothing
Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg
-------------------------------------------------------------------------------
-- Analysis
-------------------------------------------------------------------------------
analyzeMessage' :: Maybe Prefix
-> String
-> [Parameter]
-> Either String Message
analyzeMessage' prefix cmd params =
case map toUpper cmd of
-- Connection registration
"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"
{-case parseChannelModeParams rest of
Just X ->
Nothing ->-}
_ -> 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"
-- Channel operations
"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)
-- "MODE" -> Channel mode handled by MODE above
"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"
-- Sending messages
"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"
-- Server queries and commands
"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"
-- Service query and commands
"SERVLIST" -> Left "Not implemented yet"
"SQUERY" -> Left "Not implemented yet"
-- User based queries
"WHO" -> Left "Not implemented yet"
"WHOIS" -> Left "Not implemented yet"
"WHOWAS" -> Left "Not implemented yet"
-- Miscellaneous messages
"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"
-- Optional features
"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"
-- | 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 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"
-- | Read a generic reply structure into specific reply details. Return
-- 'Left' an error description if analysis fails.
analyzeReply :: GenericReply -> Either String SpecificReply
analyzeReply gr =
fmap (SpecificReply (sender gr) (target gr)) $
analyzeReply' (code gr) (target gr) (params 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 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