diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,7 @@ The changes are recorded by the version control system, Darcs. To see a log quickly from the terminal, run: - $ darcs changes --repo http://dev.rel4tion.org/fr33domlover/irc-fun-messages + $ darcs changes --repo http://hub.darcs.net/fr33domlover/irc-fun-messages There is also a web interface at which, among other things, can display the history log. @@ -9,7 +9,7 @@ To see the log in a local clone, first get a copy of the repository if you haven't yet: - $ darcs get http://dev.rel4tion.org/fr33domlover/irc-fun-messages + $ darcs get http://hub.darcs.net/fr33domlover/irc-fun-messages Then move into the newly created directory and run darcs: diff --git a/NEWS.md b/NEWS.md --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,30 @@ +irc-fun-messages 0.4 2016-09-05 +====================================== + +General, build and documentation changes: + +* Change module names +* Build with stack + +New APIs, features and enhancements: + +* (None) + +Bug fixes: + +* (None) + +Dependency changes: + +* Require irc-fun-types >= 0.2 + + + + + irc-fun-messages 0.3.0.0 -- 2016-01-27 ====================================== diff --git a/irc-fun-messages.cabal b/irc-fun-messages.cabal --- a/irc-fun-messages.cabal +++ b/irc-fun-messages.cabal @@ -1,10 +1,9 @@ name: irc-fun-messages -version: 0.3.0.0 +version: 0.4 synopsis: Types and functions for working with the IRC protocol. description: Another IRC library. It doesn't provide a client API though. It just provides - datatypes, and functions for parsing and serializing IRC commands and - replies. + functions for parsing and serializing IRC commands and replies. . The package is based on RFC 2812, with modifications and extensions to work with Freenode. @@ -14,7 +13,7 @@ needed while working on , and of course patches are welcome. homepage: http://rel4tion.org/projects/irc-fun-messages/ -bug-reports: http://rel4tion.org/projects/irc-fun-messages/tickets/ +bug-reports: https://notabug.org/fr33domlover/funbot/issues license: PublicDomain license-file: COPYING author: fr33domlover @@ -30,24 +29,24 @@ location: http://hub.darcs.net/fr33domlover/irc-fun-messages library - exposed-modules: Network.IRC.Fun.Messages - , Network.IRC.Fun.Messages.Mask - , Network.IRC.Fun.Messages.Modes - , Network.IRC.Fun.Messages.Types - other-modules: Network.IRC.Fun.Messages.Internal.Parse - , Network.IRC.Fun.Messages.Internal.Serialize - , Network.IRC.Fun.Messages.Internal.Tokens.Message - , Network.IRC.Fun.Messages.Internal.Tokens.Other - , Network.IRC.Fun.Messages.Internal.Tokens.Reply - , Network.IRC.Fun.Messages.Internal.Tokens.Target - , Network.IRC.Fun.Messages.Internal.Tokens.Wildcards - , Network.IRC.Fun.Messages.Internal.Types - , Network.IRC.Fun.Messages.Internal.Util + exposed-modules: Network.Irc.Messages + , Network.Irc.Messages.Mask + , Network.Irc.Messages.Modes + , Network.Irc.Messages.Types + other-modules: Network.Irc.Messages.Internal.Parse + , Network.Irc.Messages.Internal.Serialize + , Network.Irc.Messages.Internal.Tokens.Message + , Network.Irc.Messages.Internal.Tokens.Other + , Network.Irc.Messages.Internal.Tokens.Reply + , Network.Irc.Messages.Internal.Tokens.Target + , Network.Irc.Messages.Internal.Tokens.Wildcards + , Network.Irc.Messages.Internal.Types + , Network.Irc.Messages.Internal.Util -- other-extensions: build-depends: base >=4.7 && <5 - , irc-fun-types - , regex-applicative >=0.3.1 - , text >=1 + , irc-fun-types >=0.2 + , regex-applicative + , text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Network/IRC/Fun/Messages.hs b/src/Network/IRC/Fun/Messages.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages.hs +++ /dev/null @@ -1,37 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - --- | This module handles parsing and serializing IRC messages and replies. --- Types and other functionality are provided in the submodules. -module Network.IRC.Fun.Messages - ( -- * Parsing - parseMessage - , messageIsReply - , messageToReply - , parse - , analyzeMessage - , analyzeReply - , analyze - -- * Serializing - , buildMessage - , buildReply - , messageFromReply - , serializeMessage - , serializeReply - ) -where - -import Network.IRC.Fun.Messages.Internal.Parse -import Network.IRC.Fun.Messages.Internal.Serialize diff --git a/src/Network/IRC/Fun/Messages/Internal/Parse.hs b/src/Network/IRC/Fun/Messages/Internal/Parse.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Parse.hs +++ /dev/null @@ -1,377 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -{-# 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 diff --git a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs +++ /dev/null @@ -1,308 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -{-# LANGUAGE OverloadedStrings #-} - -module Network.IRC.Fun.Messages.Internal.Serialize - ( -- * Building - buildMessage - , buildReply - , messageFromReply - -- * Serializing - , serializeMessage - , serializeReply - ) -where - -import Data.Bits (bit, zeroBits, (.|.)) -import Data.Maybe (maybeToList) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Network.IRC.Fun.Messages.Mask (serializeMask) -import Network.IRC.Fun.Messages.Internal.Util -import Network.IRC.Fun.Types - -import qualified Data.Text as T - -------------------------------------------------------------------------------- --- Building -------------------------------------------------------------------------------- - -showAddr :: Address -> Text -showAddr (IPv4 t) = t -showAddr (IPv6 t) = t - -showHost :: Host -> Text -showHost (HostByName hn) = unHostname hn -showHost (HostByAddr addr) = showAddr addr -showHost (HostCloak t) = t - -showTargetMask :: TargetMask -> Text -showTargetMask (HostMask m) = '#' `T.cons` serializeMask m -showTargetMask (ServerMask m) = '$' `T.cons` serializeMask m - -showTarget :: MessageTarget -> Text -showTarget (ChannelTarget chan) = unChannel chan -showTarget - (UserTarget - Nothing - (Just (UserAddress (Username user) mhost)) - (Just server) - ) = - let u = case mhost of - Nothing -> user - Just host -> user <> "%" <> showHost host - in u <> "@" <> unHostname server -showTarget - (UserTarget - Nothing - (Just (UserAddress (Username user) (Just host))) - Nothing - ) = - user <> "%" <> showHost host -showTarget - (UserTarget - (Just (Nickname nick)) - Nothing - Nothing - ) = - nick -showTarget - (UserTarget - (Just (Nickname nick)) - (Just (UserAddress (Username user) (Just host))) - Nothing - ) = - nick <> "!" <> user <> "@" <> showHost host -showTarget (MaskTarget mt) = showTargetMask mt -showTarget _ = "invalid_target" - --- Fill command name and parameters from specific message -buildMessage' :: Message -> (Text, [Parameter]) -buildMessage' msg = - case msg of - PassMessage pass -> - ("PASS", [unPassword pass]) - NickMessage nn -> - ("NICK", [unNickname nn]) - UserMessage un i w rn -> - ( "USER" - , [ unUsername un - , showt $ modebit 3 i .|. modebit 2 w - , "*" - , unRealName rn - ] - ) - where - modebit n b = if b then bit n else zeroBits :: Int - OperMessage _un _p -> - ("????", error "Not implemented") - UserModeMessage _n _remove _add -> - ("????", error "Not implemented") - ServiceMessage _n _m _s -> - ("????", error "Not implemented") - QuitMessage reason -> - ("QUIT", perhaps $ fmap unComment reason) - SQuitMessage _s _t -> - ("????", error "Not implemented") - JoinMessage Nothing -> - ("JOIN", ["0"]) - JoinMessage (Just (chans, keys)) -> - ( "JOIN" - , T.intercalate "," (map unChannel chans) : - if null keys - then [] - else [T.intercalate "," $ map unChannelKey keys] - ) - PartMessage chans reason -> - ( "PART" - , T.intercalate "," (map unChannel chans) ?: fmap unComment reason - ) - ChannelModeMessage _remove _add -> - ("????", error "Not implemented") - TopicMessage chan topic -> - ("TOPIC", unChannel chan ?: fmap unChannelTopic topic) - NamesMessage chans serv -> - ( "NAMES" - , T.intercalate "," (map unChannel chans) ?: fmap unHostname serv - ) - ListMessage _chans _serv -> - ("????", error "Not implemented") - InviteMessage _nn _chan -> - ("????", error "Not implemented") - KickMessage _chans _users _s -> - ("????", error "Not implemented") - PrivMsgMessage tgt (MsgContent mc) -> - ("PRIVMSG", [showTarget tgt, mc]) - PrivActionMessage tgt (MsgContent mc) -> - ("PRIVMSG", [showTarget tgt, "\1ACTION " <> mc <> "\1"]) - NoticeMessage tgt (MsgContent mc) -> - ("NOTICE", [showTarget tgt, mc]) - MotdMessage _serv -> - ("????", error "Not implemented") - LusersMessage _serv -> - ("????", error "Not implemented") - VersionMessage _serv -> - ("????", error "Not implemented") - StatsMessage _x -> - ("????", error "Not implemented") - LinksMessage _x -> - ("????", error "Not implemented") - TimeMessage _serv -> - ("????", error "Not implemented") - ConnectMessage _serv _portn _sm -> - ("????", error "Not implemented") - TraceMessage _t -> - ("????", error "Not implemented") - AdminMessage _t -> - ("????", error "Not implemented") - InfoMessage _t -> - ("????", error "Not implemented") - ServlistMessage _ -> - ("????", error "Not implemented") - SQueryMessage _ _ -> - ("????", error "Not implemented") - WhoMessage _ -> - ("????", error "Not implemented") - WhoisMessage _ _ -> - ("????", error "Not implemented") - WhowasMessage _ _ -> - ("????", error "Not implemented") - KillMessage _ _ -> - ("????", error "Not implemented") - PingMessage s1 s2 -> - ("PING", unHostname s1 ?: fmap unHostname s2) - PongMessage s1 s2 -> - ("PONG", unHostname s1 ?: fmap unHostname s2) - ErrorMessage _ -> - ("????", error "Not implemented") - AwayMessage _ -> - ("????", error "Not implemented") - RehashMessage -> - ("????", error "Not implemented") - DieMessage -> - ("????", error "Not implemented") - RestartMessage -> - ("????", error "Not implemented") - SummonMessage _ _ -> - ("????", error "Not implemented") - UsersMessage _ -> - ("????", error "Not implemented") - WallopsMessage _ -> - ("????", error "Not implemented") - UserhostMessage _ -> - ("????", error "Not implemented") - IsonMessage _ -> - ("????", error "Not implemented") - where - perhaps = maybeToList - x ?: my = x : perhaps my - --- | Fill a generic message record using a specific message's details. -buildMessage :: SpecificMessage -> GenericMessage -buildMessage (SpecificMessage pref msg) = - let (cmd, ps) = buildMessage' msg - in GenericMessage pref (NamedCmd $ CmdName cmd) ps - -channelPrivacyChar :: ChannelPrivacy -> Char -channelPrivacyChar Secret = '@' -channelPrivacyChar Private = '*' -channelPrivacyChar Public = '=' - -privilegeChar :: Privilege -> Maybe Char -privilegeChar Regular = Nothing -privilegeChar Voice = Just '+' -privilegeChar Operator = Just '@' - --- Fill reply code, target and parameters from specific reply -buildReply' :: Reply -> (Int, [Parameter]) -buildReply' reply = - case reply of - NamesReply priv chan pns -> - ( 353 - , [ T.singleton $ channelPrivacyChar priv - , unChannel chan - , T.unwords $ - map - (\ (p, (Nickname n)) -> - maybe n (`T.cons` n) $ privilegeChar p - ) - pns - ] - ) - _ -> error "Not implemented" - --- | Fill a generic reply record using a specific reply's details. -buildReply :: SpecificReply -> GenericReply -buildReply (SpecificReply sender tgt reply) = - let (code, ps) = buildReply' reply - in GenericReply sender (CmdNumber code) tgt ps - --- | Convert a reply, which is a message with a numeric command name, into a --- generic message value. -messageFromReply :: GenericReply -> GenericMessage -messageFromReply reply = GenericMessage - { gmPrefix = Just $ PrefixServer $ grSender reply - , gmCommand = NumericCmd $ grCode reply - , gmParams = target' reply : grParams reply - } - where - target' (GenericReply { grTarget = NickTarget n }) = unNickname n - target' (GenericReply { grTarget = ServerTarget s }) = unHostname s - -------------------------------------------------------------------------------- --- Serializing -------------------------------------------------------------------------------- - -serializePrefix :: Prefix -> Text -serializePrefix (PrefixServer sn) = unHostname sn -serializePrefix (PrefixNick n mu mh) = - unNickname n <> - maybe "" ('!' `T.cons`) (fmap unUsername mu) <> - maybe "" (('@' `T.cons`) . showHost) mh - -serializeCommand :: Command -> Text -serializeCommand (NamedCmd t) = unCmdName t -serializeCommand (NumericCmd n) = showt $ unCmdNumber n - -serializeParams :: [Parameter] -> Text -serializeParams = f . map (\ p -> if T.null p then "(?)" else p) - where - f [] = "" - f l = - let (ps, p) = (init l, last l) - in T.concat (map (' ' `T.cons`) ps) <> " " <> - if T.head p == ':' || T.any (== ' ') p - then ':' `T.cons` p - else p - --- | Write a message into an IRC protocol message formatted string. -serializeMessage :: GenericMessage -> Text -serializeMessage msg = T.concat - [ maybe - T.empty - (\ p -> ':' `T.cons` serializePrefix p `T.snoc` ' ') - (gmPrefix msg) - , serializeCommand $ gmCommand msg - , serializeParams $ gmParams msg - , "\r\n" - ] - --- | Write a reply into an IRC protocol message formatted string. --- --- This is essentially a combination of 'messageFromReply' and --- 'serializeMessage'. -serializeReply :: GenericReply -> Text -serializeReply = serializeMessage . messageFromReply diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs +++ /dev/null @@ -1,89 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Tokens.Message - ( message - ) -where - -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack) -import Network.IRC.Fun.Messages.Internal.Tokens.Other -import Network.IRC.Fun.Messages.Internal.Tokens.Target -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -----------TOTO -{- -- go over errata, make sure everything here is correct -- some regexes, such as matchone and target, seem not to be used in the rules - here. they're probably intended for later use, e.g. when matching a string - against a mask. in such case the API should probably import them --} - -message :: Regex GenericMessage -message = - GenericMessage <$> - optional (sym ':' *> prefix <* space) <*> - command <*> - (fromMaybe [] <$> optional params) <* - crlf - -prefix :: Regex Prefix -prefix = - PrefixServer <$> servername - <|> - nick <$> - nickname <*> - optional - ( (,) <$> - optional (sym '!' *> user) <* - sym '@' <*> - host - ) - where - nick n Nothing = PrefixNick n Nothing Nothing - nick n (Just (u, h)) = PrefixNick n u (Just h) - -command :: Regex Command -command = - let f a b c = NumericCmd $ CmdNumber $ read [a, b, c] - in NamedCmd . CmdName . pack <$> some letter - <|> - f <$> digit <*> digit <*> digit - -params :: Regex [Text] -params = - let f m (Just t) = m ++ [t] - f m Nothing = m - in f <$> - many (space *> middle) <*> - optional (space *> sym ':' *> trailing) - -middle :: Regex Text -middle = pack <$> ((:) <$> paramchar <*> many (sym ':' <|> paramchar)) - -trailing :: Regex Text -trailing = pack <$> many (sym ':' <|> sym ' ' <|> paramchar) - -paramchar :: Regex Char -paramchar = psym (`notElem` "\0\r\n :") - -space :: Regex Char -space = sym ' ' - -crlf :: Regex String -crlf = string "\r\n" diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs +++ /dev/null @@ -1,62 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Tokens.Other - ( user - , key - , letter - , digit - , hexdigit - , hexdigit' - , special - ) -where - -import Data.Char (isAscii, isDigit) -import Data.Text (pack) -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -user :: Regex Username -user = Username . pack <$> some (psym (`notElem` "\0\r\n @")) - -key :: Regex ChannelKey -key = - ChannelKey . pack <$> - some (psym $ \ c -> isAscii c && c `notElem` "\0\r\n\f\t\v ") - -letter :: Regex Char -letter = psym $ \ c -> 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' - -digit :: Regex Char -digit = psym isDigit - -hexdigit :: Regex Char -hexdigit = digit <|> upperhex - where - upperhex = psym $ \ c -> 'A' <= c && c <= 'F' - --- RFC 2812 assumes IPv6 addresses with uppercase hex digits. In practice, the --- recommendation it to use lowercase, and that's what really happens. So this --- regex accepts both lowercase and uppercase. -hexdigit' :: Regex Char -hexdigit' = digit <|> upperhex <|> lowerhex - where - upperhex = psym $ \ c -> 'A' <= c && c <= 'F' - lowerhex = psym $ \ c -> 'a' <= c && c <= 'f' - -special :: Regex Char -special = psym (`elem` "[]\\`_^{|}") diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs +++ /dev/null @@ -1,43 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Tokens.Reply - ( chanpriv - , prefnicks - ) -where - -import Data.Maybe (fromMaybe) -import Network.IRC.Fun.Messages.Internal.Tokens.Target -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -------------------------------------------------------------------------------- --- 353 RPL_NAMREPLY -------------------------------------------------------------------------------- - -chanpriv :: Regex ChannelPrivacy -chanpriv = Secret <$ sym '@' <|> Private <$ sym '*' <|> Public <$ sym '=' - -prefnicks :: Regex [(Privilege, Nickname)] -prefnicks = (:) <$> prefnick <*> many (sym ' ' *> prefnick) - -prefnick :: Regex (Privilege, Nickname) -prefnick = (,) <$> privilege <*> nickname - -privilege :: Regex Privilege -privilege = - fromMaybe Regular <$> optional (Voice <$ sym '+' <|> Operator <$ sym '@') diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs +++ /dev/null @@ -1,139 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Tokens.Target - ( target - , msgtarget - , msgto - , channel - , servername - , host - , nickname - ) -where - -import Data.Char (isAsciiUpper) -import Data.Text (Text, pack) -import Network.IRC.Fun.Messages.Internal.Tokens.Other -import Network.IRC.Fun.Messages.Internal.Tokens.Wildcards -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -target :: Regex Target -target = NickTarget <$> nickname <|> ServerTarget <$> servername - -msgtarget :: Regex [MessageTarget] -msgtarget = (:) <$> msgto <*> many (sym ',' *> msgto) - -msgto :: Regex MessageTarget -msgto = ChannelTarget <$> channel - <|> uhs <$> user - <*> optional (sym '%' *> host) <* sym '@' - <*> servername - <|> uh <$> user <* sym '%' - <*> host - <|> MaskTarget <$> targetmask - <|> nn <$> nickname - <|> nuh <$> nickname <* sym '!' - <*> user <* sym '@' - <*> host - where - uhs u h s = UserTarget Nothing (Just (UserAddress u h)) (Just s) - uh u h = UserTarget Nothing (Just (UserAddress u (Just h))) Nothing - nn n = UserTarget (Just n) Nothing Nothing - nuh n u h = UserTarget (Just n) (Just (UserAddress u (Just h))) Nothing - -channel :: Regex Channel -channel = - Channel . pack . snd <$> - withMatched - ( (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <* - chanstring <* - optional (sym ':' <* chanstring) - ) - -servername :: Regex Hostname -servername = hostname - -host :: Regex Host -host = - HostByAddr <$> hostaddr - <|> - HostByName <$> hostname - <|> - HostCloak <$> hostcloak - -hostname :: Regex Hostname -hostname = - Hostname . pack . snd <$> - withMatched (shortname <* many (sym '.' <* shortname)) - -shortname :: Regex String -shortname = - snd <$> withMatched - ( (letter <|> digit) <* - optional (many (letter <|> digit <|> sym '-') <* (letter <|> digit)) - ) - -hostaddr :: Regex Address -hostaddr = IPv4 <$> ip4addr <|> IPv6 <$> ip6addr - -ip4addr :: Regex Text -ip4addr = pack . snd <$> withMatched (s <* p <* s <* p <* s <* p <* s) - where - d = digit - s = snd <$> withMatched (d <|> d <* d <|> d <* d <* d) - p = sym '.' - -ip6addr :: Regex Text -ip6addr = pack . snd <$> withMatched (full <|> short <|> v4) - where - h = some hexdigit' - c = sym ':' - s = h <* many (c <* h) - full = h <* c <* h <* c <* - h <* c <* h <* c <* - h <* c <* h <* c <* - h <* c <* h - short = optional s *> string "::" <* optional s - v4 = string "0:0:0:0:0:" <* - (string "0" <|> string "FFFF") <* - sym ':' <* - ip4addr - -hostcloak :: Regex Text -hostcloak = - pack <$> some (letter <|> digit <|> special <|> psym (`elem` ".-/")) - -nickname :: Regex Nickname -nickname = - Nickname . pack <$> - ( (:) <$> - (letter <|> special) <*> - many (letter <|> digit <|> special <|> sym '-') - ) - -targetmask :: Regex TargetMask -targetmask = ServerMask <$> (sym '$' *> mask) - <|> HostMask <$> (sym '#' *> mask) - -chanstring :: Regex String -chanstring = many $ psym (`notElem` "\0\a\r\n ,:") - -channelid :: Regex String -channelid = snd <$> withMatched (c *> c *> c *> c *> c) - where - c = psym isAsciiUpper <|> digit diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs +++ /dev/null @@ -1,46 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Tokens.Wildcards - ( mask - , matchone - , matchmany - ) -where - -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -mask :: Regex Mask -mask = Mask <$> many (nowild <|> noesc *> wildone <|> noesc *> wildmany) - -wildone :: Regex MaskPart -wildone = MaskWildOne <$ sym '?' - -wildmany :: Regex MaskPart -wildmany = MaskWildMany <$ sym '*' - -nowild :: Regex MaskPart -nowild = MaskChar <$> psym (`notElem` "\0*?") - -noesc :: Regex Char -noesc = psym (`notElem` "\0\\") - -matchone :: Regex Char -matchone = psym (/= '\0') - -matchmany :: Regex String -matchmany = many matchone diff --git a/src/Network/IRC/Fun/Messages/Internal/Types.hs b/src/Network/IRC/Fun/Messages/Internal/Types.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Types.hs +++ /dev/null @@ -1,372 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015, 2016 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Types - ( -- * Type Aliases And Newtypes - Regex - -- * Reply - , CommandResponseCode (..) - , ErrorReplyCode (..) - , ReservedReplyCode (..) - , ReservedErrorCode (..) - ) -where - -import Text.Regex.Applicative (RE) - --- | TODO -type Regex = RE Char - -------------------------------------------------------------------------------- --- Reply -------------------------------------------------------------------------------- - --- | TODO -data CommandResponseCode - -- | TODO - = ReplyWelcome - -- | TODO - | ReplyYourHost - -- | TODO - | ReplyCreated - -- | TODO - | ReplyMyInfo - -- | TODO - | ReplyBounce - -- | TODO - | ReplyUserHost - -- | TODO - | ReplyIsOn - -- | TODO - | ReplyAway - -- | TODO - | ReplyUnAway - -- | TODO - | ReplyNoAway - -- | TODO - | ReplyWhoIsUser - -- | TODO - | ReplyWhoIsServer - -- | TODO - | ReplyWhoIsOperator - -- | TODO - | ReplyWhoIsIdle - -- | TODO - | ReplyEndOfWhoIs - -- | TODO - | ReplyWhoIsChannels - -- | TODO - | ReplyWhoWasUser - -- | TODO - | ReplyEndOfWhoWas - -- | TODO - | ReplyListStart - -- | TODO - | ReplyList - -- | TODO - | ReplyListEnd - -- | TODO - | ReplyUniqueOpIs - -- | TODO - | ReplyChannelModeIs - -- | TODO - | ReplyNoTopic - -- | TODO - | ReplyTopic - -- | TODO - | ReplyInviting - -- | TODO - | ReplySummoning - -- | TODO - | ReplyInviteList - -- | TODO - | ReplyEndOfInviteList - -- | TODO - | ReplyExceptList - -- | TODO - | ReplyEndOfExceptList - -- | TODO - | ReplyVersion - -- | TODO - | ReplyWhoReply - -- | TODO - | ReplyEndOfWho - -- | TODO - | ReplyNameReply - -- | TODO - | ReplyEndOfNames - -- | TODO - | ReplyLinks - -- | TODO - | ReplyEndOfLinks - -- | TODO - | ReplyBanList - -- | TODO - | ReplyEndOfBanList - -- | TODO - | ReplyInfo - -- | TODO - | ReplyEndOfInfo - -- | TODO - | ReplyMotdStart - -- | TODO - | ReplyMessageOfTheDay - -- | TODO - | ReplyEndOfMessageOfTheDay - -- | TODO - | ReplyYoureOper - -- | TODO - | ReplyRehashing - -- | TODO - | ReplyYoureService - -- | TODO - | ReplyTime - -- | TODO - | ReplyUsersStart - -- | TODO - | ReplyUsers - -- | TODO - | ReplyEndOfUsers - -- | TODO - | ReplyNoUsers - -- | TODO - | ReplyTraceLink - -- | TODO - | ReplyTraceConnecting - -- | TODO - | ReplyTraceHandshake - -- | TODO - | ReplyTraceUnknown - -- | TODO - | ReplyTraceOperator - -- | TODO - | ReplyTraceUser - -- | TODO - | ReplyTraceServer - -- | TODO - | ReplyTraceService - -- | TODO - | ReplyTraceNewType - -- | TODO - | ReplyTraceClass - -- | TODO - | ReplyTraceReconnect - -- | TODO - | ReplyTraceLog - -- | TODO - | ReplyTraceEnd - -- | TODO - | ReplyStatsLinkInfo - -- | TODO - | ReplyStatsCommands - -- | TODO - | ReplyEndOfStats - -- | TODO - | ReplyStatsUptime - -- | TODO - | ReplyStatsOLine - -- | TODO - | ReplyUModeIs - -- | TODO - | ReplyServList - -- | TODO - | ReplyServListEnd - -- | TODO - | ReplyLuserClient - -- | TODO - | ReplyLuserOp - -- | TODO - | ReplyLuserUnknown - -- | TODO - | ReplyLuserChannels - -- | TODO - | ReplyLuserMe - -- | TODO - | ReplyAdminMe - -- | TODO - | ReplyAdminLocation1 - -- | TODO - | ReplyAdminLocation2 - -- | TODO - | ReplyAdminEmail - -- | TODO - | ReplyTryAgain - -- | TODO - | ReplyFreenodeISupport - deriving (Eq, Show) - -data ErrorReplyCode - -- | TODO - = ErrorNoSuchNick - -- | TODO - | ErrorNoSuchServer - -- | TODO - | ErrorNoSuchChannel - -- | TODO - | ErrorCannotSendToChannel - -- | TODO - | ErrorTooManyChannels - -- | TODO - | ErrorWasNoSuchNick - -- | TODO - | ErrorTooManyTargets - -- | TODO - | ErrorNoSuchService - -- | TODO - | ErrorNoOrigin - -- | TODO - | ErrorNoRecipient - -- | TODO - | ErrorNoTextToSend - -- | TODO - | ErrorNoTopLevel - -- | TODO - | ErrorWildTopLevel - -- | TODO - | ErrorBadMask - -- | TODO - | ErrorUnknownCommand - -- | TODO - | ErrorNoMessageOfTheDay - -- | TODO - | ErrorNoAdminInfo - -- | TODO - | ErrorFileError - -- | TODO - | ErrorNoNicknameGiven - -- | TODO - | ErrorErroneousNickname - -- | TODO - | ErrorNicknameInUse - -- | TODO - | ErrorNickCollision - -- | TODO - | ErrorUnavailableResource - -- | TODO - | ErrorUserNotInChannel - -- | TODO - | ErrorNotOnChannel - -- | TODO - | ErrorUserOnChannel - -- | TODO - | ErrorNoLogin - -- | TODO - | ErrorSummonDisabled - -- | TODO - | ErrorUsersDisabled - -- | TODO - | ErrorNotRegistered - -- | TODO - | ErrorNeedMoreParams - -- | TODO - | ErrorAlreadyRegistered - -- | TODO - | ErrorNoPermissionForHost - -- | TODO - | ErrorPasswordMismatch - -- | TODO - | ErrorYoureBannedCreep - -- | TODO - | ErrorYouWillBeBanned - -- | TODO - | ErrorKeySet - -- | TODO - | ErrorChannelIsFull - -- | TODO - | ErrorUnknownMode - -- | TODO - | ErrorInviteOnlyChannel - -- | TODO - | ErrorBannedFromChannel - -- | TODO - | ErrorBadChannelKey - -- | TODO - | ErrorBadChannelMask - -- | TODO - | ErrorNoChannelModes - -- | TODO - | ErrorBanListFull - -- | TODO - | ErrorNoPrivileges - -- | TODO - | ErrorChannelOpPrivilegesNeeded - -- | TODO - | ErrorCantKillServer - -- | TODO - | ErrorRestricted - -- | TODO - | ErrorUniqueOpPrivilegesNeeded - -- | TODO - | ErrorNoOperHost - -- | TODO - | ErrorUModeUnknownFlag - -- | TODO - | ErrorUsersDontMatch - deriving (Eq, Show) - -data ReservedReplyCode - -- | TODO - = ReservedReplyServiceInfo - -- | TODO - | ReservedReplyEndOfServices - -- | TODO - | ReservedReplyService - -- | TODO - | ReservedReplyNone - -- | TODO - | ReservedReplyWhoIsChannelOp - -- | TODO - | ReservedReplyKillDone - -- | TODO - | ReservedReplyClosing - -- | TODO - | ReservedReplyCloseEnd - -- | TODO - | ReservedReplyInfoStart - -- | TODO - | ReservedReplyMyPortIs - -- | TODO - | ReservedReplyStatsCLine - -- | TODO - | ReservedReplyStatsNLine - -- | TODO - | ReservedReplyStatsILine - -- | TODO - | ReservedReplyStatsKLine - -- | TODO - | ReservedReplyStatsQLine - -- | TODO - | ReservedReplyStatsYLine - -- | TODO - | ReservedReplyStatsVLine - -- | TODO - | ReservedReplyStatsLLine - -- | TODO - | ReservedReplyStatsHLine - -- | TODO - | ReservedReplyStatsSLine - -- | TODO - | ReservedReplyStatsPing - -- | TODO - | ReservedReplyStatsBLine - -- | TODO - | ReservedReplyStatsDLine - deriving (Eq, Show) - --- | TODO -data ReservedErrorCode - -- | TODO - = ReservedErrorNoServiceHost - deriving (Eq, Show) diff --git a/src/Network/IRC/Fun/Messages/Internal/Util.hs b/src/Network/IRC/Fun/Messages/Internal/Util.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Internal/Util.hs +++ /dev/null @@ -1,148 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - -module Network.IRC.Fun.Messages.Internal.Util - ( showt - , listOf - , req0 - , req1 - , req2 - , req3 - , req4 - , req5 - , req6 - , req0m1 - , req1m2 - , req2m3 - , req3m4 - , min1 - ) -where - -import Data.Text (Text, pack) -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -showt :: Int -> Text -showt = pack . show - -listOf :: Regex a -> Regex [a] -listOf re = (:) <$> re <*> many (sym ',' *> re) - -req0 :: [Parameter] - -> Either AnalysisError Message - -> Either AnalysisError Message -req0 [] f = f -req0 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 0) - -req1 :: [Parameter] - -> (Parameter -> Either AnalysisError Message) - -> Either AnalysisError Message -req1 [p1] f = f p1 -req1 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 1) - -req2 :: [Parameter] - -> (Parameter -> Parameter -> Either AnalysisError Message) - -> Either AnalysisError Message -req2 [p1, p2] f = f p1 p2 -req2 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 2) - -req3 :: [Parameter] - -> (Parameter -> Parameter -> Parameter -> Either AnalysisError Message) - -> Either AnalysisError Message -req3 [p1, p2, p3] f = f p1 p2 p3 -req3 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 3) - -req4 :: [Parameter] - -> ( Parameter - -> Parameter - -> Parameter - -> Parameter - -> Either AnalysisError Message - ) - -> Either AnalysisError Message -req4 [p1, p2, p3, p4] f = f p1 p2 p3 p4 -req4 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 4) - -req5 :: [Parameter] - -> ( Parameter - -> Parameter - -> Parameter - -> Parameter - -> Parameter - -> Either AnalysisError Message - ) - -> Either AnalysisError Message -req5 [p1, p2, p3, p4, p5] f = f p1 p2 p3 p4 p5 -req5 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 5) - -req6 :: [Parameter] - -> ( Parameter - -> Parameter - -> Parameter - -> Parameter - -> Parameter - -> Parameter - -> Either AnalysisError Message - ) - -> Either AnalysisError Message -req6 [p1, p2, p3, p4, p5,p6] f = f p1 p2 p3 p4 p5 p6 -req6 l _ = Left $ - WrongNumArgs (length l) (Just $ Exactly 6) - -req0m1 :: [Parameter] - -> (Maybe Parameter -> Either AnalysisError Message) - -> Either AnalysisError Message -req0m1 [] f = f Nothing -req0m1 [p1] f = f $ Just p1 -req0m1 l _ = Left $ WrongNumArgs (length l) (Just $ Between 0 1) - -req1m2 :: [Parameter] - -> (Parameter -> Maybe Parameter -> Either AnalysisError Message) - -> Either AnalysisError Message -req1m2 [p1] f = f p1 Nothing -req1m2 [p1, p2] f = f p1 (Just p2) -req1m2 l _ = Left $ WrongNumArgs (length l) (Just $ Between 1 2) - -req2m3 :: [Parameter] - -> ( Parameter - -> Parameter - -> Maybe Parameter - -> Either AnalysisError Message - ) - -> Either AnalysisError Message -req2m3 [p1, p2] f = f p1 p2 Nothing -req2m3 [p1, p2, p3] f = f p1 p2 (Just p3) -req2m3 l _ = Left $ WrongNumArgs (length l) (Just $ Between 2 3) - -req3m4 :: [Parameter] - -> ( Parameter - -> Parameter - -> Parameter - -> Maybe Parameter - -> Either AnalysisError Message - ) - -> Either AnalysisError Message -req3m4 [p1, p2, p3] f = f p1 p2 p3 Nothing -req3m4 [p1, p2, p3, p4] f = f p1 p2 p3 (Just p4) -req3m4 l _ = Left $ - WrongNumArgs (length l) (Just $ Between 3 4) - -min1 :: [Parameter] - -> (Parameter -> [Parameter] -> Either AnalysisError Message) - -> Either AnalysisError Message -min1 [] _ = Left $ WrongNumArgs 0 (Just $ AtLeast 1) -min1 (p1:ps) f = f p1 ps diff --git a/src/Network/IRC/Fun/Messages/Mask.hs b/src/Network/IRC/Fun/Messages/Mask.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Mask.hs +++ /dev/null @@ -1,72 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - --- | This module deals with wildcard based masks, used for selecting users and --- servers. -module Network.IRC.Fun.Messages.Mask - ( parseMask - , serializeMask - , matches - ) -where - -import Data.Maybe (isJust) -import Data.Text (Text, cons, unpack) -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -import qualified Network.IRC.Fun.Messages.Internal.Tokens.Wildcards as T - -{- -TODO -"The mask MUST - have at least 1 (one) "." in it and no wildcards following the last - ".". This requirement exists to prevent people sending messages to - "#*" or "$*", which would broadcast to all users." - -handle this somehow! e.g. a function that tests a mask for validity --} - --- | Parse a mask string (e.g. @"*!*@*"@) into a 'Mask' value. Returns --- 'Nothing' if the string isn't a valid mask. -parseMask :: Text -> Maybe Mask -parseMask = match T.mask . unpack - ---TODO what about escaping and invalid chars? are they handled correctly? ---prepend mapped part to given string -serializeMaskPart :: MaskPart -> Text -> Text -serializeMaskPart (MaskChar '?') t = '\\' `cons` '?' `cons` t -serializeMaskPart (MaskChar '*') t = '\\' `cons` '*' `cons` t -serializeMaskPart (MaskChar c) t = c `cons` t -serializeMaskPart (MaskWildOne) t = '?' `cons` t -serializeMaskPart (MaskWildMany) t = '*' `cons` t - --- | Converts a 'Mask' value into its string representation in IRC messages. -serializeMask :: Mask -> Text -serializeMask (Mask parts) = foldr serializeMaskPart mempty parts - --- TODO maybe fold MaskChars into strings? how much faster will it be? -maskToRegex :: Mask -> Regex String -maskToRegex (Mask parts) = snd <$> withMatched (foldr f (pure "") parts) - where - f (MaskChar c) regex = sym c *> regex - f MaskWildOne regex = T.matchone *> regex - f MaskWildMany regex = T.matchmany *> regex - -matches :: String -> Mask -> Bool -matches s m = isJust $ match (maskToRegex m) s - -infix 2 `matches` diff --git a/src/Network/IRC/Fun/Messages/Modes.hs b/src/Network/IRC/Fun/Messages/Modes.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Modes.hs +++ /dev/null @@ -1,201 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - --- | This module handles user modes and channel modes. -module Network.IRC.Fun.Messages.Modes - ( -- * User Modes - umodeToLetter - , umodeFromLetter - , parseUserMode - -- * Channel Modes - , cmodeToLetter - , cmodeFromLetter - , parseChannelModeParams - ) -where - -import Data.Either (isRight) -import Data.Maybe (fromMaybe) -import Data.List (nub, partition) -import Data.Text (Text) -import Data.Tuple (swap) -import Network.IRC.Fun.Messages.Internal.Types -import Network.IRC.Fun.Types -import Text.Regex.Applicative - -import qualified Data.Text as T - -userModeMap :: [(UserMode, Char)] -userModeMap = - [ (UModeInvisible, 'i') - , (UModeCallerID, 'g') - , (UModeSeeWallops, 'w') - , (UModeDeaf, 'D') - , (UModeNoForwarding, 'Q') - , (UModeBlockUnidentified, 'R') - , (UModeConnectedViaSSL, 'Z') - , (UModeAway, 'a') - , (UModeRestricted, 'r') - , (UModeOperator, 'o') - , (UModeLocalOperator, 'O') - , (UModeSeeNotices, 's') - ] - -umodeToLetter :: UserMode -> Char -umodeToLetter (UModeOther c) = c -umodeToLetter um = - fromMaybe - (error "Implementation error: User mode not assigned a letter") - (lookup um userModeMap) - -umodeFromLetter :: Char -> UserMode -umodeFromLetter c = fromMaybe (UModeOther c) (lookup c $ map swap userModeMap) - -isAsciiLetter :: Char -> Bool -isAsciiLetter c = 'a' <= c && c <= 'z' || 'A' <= c && c <= 'Z' - --- 1 to remove, 2 to add -umode :: Regex ([UserMode], [UserMode]) -umode = mix <$> many section - where - section = (,) <$> (True <$ sym '+' <|> False <$ sym '-') - <*> (nub <$> many (psym isAsciiLetter)) - mix l = - let (add, remove) = partition fst l - add' = nub $ concatMap snd add - remove' = nub $ concatMap snd remove - in (map umodeFromLetter remove', map umodeFromLetter add') - --- the one from the MODE irc message -parseUserMode :: Text -> Maybe ([UserMode], [UserMode]) -parseUserMode = match umode . T.unpack - ---TODO add modes from https://freenode.net/using_the_network.shtml --- freenode it the main target anyway... --- also maybe add a system for server-specific non-standard flags -channelModeMap :: [(ChannelMode, Char, ChannelModeType)] -channelModeMap = --eIbq,k,flj,CFLMPQScgimnprstz -- o and v type B syntax-wise - [ (CModeCreator, 'O', ModeTypeMaybeSetting) - , (CModeOperator, 'o', ModeTypeSetting) - , (CModeVoice, 'v', ModeTypeSetting) - , (CModeAnonymous, 'a', ModeTypeFlag) - , (CModeInviteOnly, 'i', ModeTypeFlag) - , (CModeModerated, 'm', ModeTypeFlag) - , (CModeNoMessagesFromOutside, 'n', ModeTypeFlag) - , (CModeQuiet, 'q', ModeTypeFlag) - , (CModePrivate, 'p', ModeTypeFlag) - , (CModeSecret, 's', ModeTypeFlag) - , (CModeServerReop, 'r', ModeTypeFlag) - , (CModeTopicSettableByChannelOpOnly, 't', ModeTypeFlag) - , (CModeKey Nothing, 'k', ModeTypeFlag) - , (CModeUserLimit Nothing, 'l', ModeTypeMaybeSetting) - , (CModeBanMask Nothing, 'b', ModeTypeList) - , (CModeExceptionMask Nothing, 'e', ModeTypeList) - , (CModeInvitationMask Nothing, 'I', ModeTypeList) - ] - -freenodeOverride :: [(ChannelMode, Char, ChannelModeType)] -freenodeOverride = - [ (CModeFreenodeQuiet Nothing, 'q', ModeTypeSetting) - ] - -lookupCLetter - :: ChannelMode - -> [(ChannelMode, Char, ChannelModeType)] - -> Maybe Char -lookupCLetter _ [] = Nothing -lookupCLetter q ((m, l, _t):rest) = - if q == m - then Just l - else lookupCLetter q rest - ---TODO make the bool=True mean we use the freenode override -cmodeToLetter :: ChannelMode -> Bool -> Char -cmodeToLetter (CModeOther c _) _ = c -cmodeToLetter cm freenode = - let m = - if freenode - then freenodeOverride ++ channelModeMap - else channelModeMap - in fromMaybe - (error "Implementation error: Channel mode not assigned a letter") - (lookupCLetter cm m) - -lookupCMode - :: Char - -> [(ChannelMode, Char, ChannelModeType)] - -> Maybe ChannelMode -lookupCMode _ [] = Nothing -lookupCMode c ((m, l, _):rest) = if c == l then Just m else lookupCMode c rest - ---TODO make the bool=True mean we use the freenode override -cmodeFromLetter :: Char -> Bool -> ChannelMode -cmodeFromLetter c freenode = - let m = - if freenode - then freenodeOverride ++ channelModeMap - else channelModeMap - in fromMaybe (CModeOther c []) (lookupCMode c m) - --- the one from the MODE irc message --- http://www.irc.org/tech_docs/005.html -{- -some rules: - -A - -B - -C - -suppose we are setting 'l', then: - -l : does nothing -+l : does nothing --l : unsets the mode -l 1000 : sets mode, same as +l 1000 -+l 1000 : sets mode --l 1000 : unsets mode, the 1000 is ignored - -D - --} -parseChannelModeParams :: [Text] - -> Bool -- whether to use freenode override - -> Maybe - ( [ChannelMode] -- list additions and boolean sets - , [ChannelMode] -- list removals and boolean unsets - , [ChannelMode] -- setting changes (sets and unsets) - ) -parseChannelModeParams l _freenode = - let _l' = map f l - -- Tag params, each is either a mode (e.g. +abc) or an arg (e.g. *!*@*) - f t = - case match section $ T.unpack t of - Just sect -> Right sect - Nothing -> Left t - section = (,) <$> optional (True <$ sym '+' <|> False <$ sym '-') - <*> (nub <$> many (psym isAsciiLetter)) - -- Collect (sign, modes, [arg]) tuples into a list - _parts [] = Just [] - _parts (Left _ : _) = Nothing - _parts (Right (sign, letters) : ss) = - let (args, next) = break isRight ss - in case _parts next of - Nothing -> Nothing - Just pn -> Just $ (sign, letters, args) : pn - -- Attach args to their modes by mode type - --attach ( - in Nothing diff --git a/src/Network/IRC/Fun/Messages/Types.hs b/src/Network/IRC/Fun/Messages/Types.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/Types.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - --- | Most of the types that were once in this module moved to --- "Network.IRC.Fun.Types" in a separate package. The few types left here may --- move in the future too. -module Network.IRC.Fun.Messages.Types - ( CommandResponseCode (..) - , ErrorReplyCode (..) - , ReservedReplyCode (..) - , ReservedErrorCode (..) - ) -where - -import Network.IRC.Fun.Messages.Internal.Types diff --git a/src/Network/Irc/Messages.hs b/src/Network/Irc/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages.hs @@ -0,0 +1,37 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | This module handles parsing and serializing IRC messages and replies. +-- Types and other functionality are provided in the submodules. +module Network.Irc.Messages + ( -- * Parsing + parseMessage + , messageIsReply + , messageToReply + , parse + , analyzeMessage + , analyzeReply + , analyze + -- * Serializing + , buildMessage + , buildReply + , messageFromReply + , serializeMessage + , serializeReply + ) +where + +import Network.Irc.Messages.Internal.Parse +import Network.Irc.Messages.Internal.Serialize diff --git a/src/Network/Irc/Messages/Internal/Parse.hs b/src/Network/Irc/Messages/Internal/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Parse.hs @@ -0,0 +1,377 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Network.Irc.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.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 + +------------------------------------------------------------------------------- +-- 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 diff --git a/src/Network/Irc/Messages/Internal/Serialize.hs b/src/Network/Irc/Messages/Internal/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Serialize.hs @@ -0,0 +1,308 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Network.Irc.Messages.Internal.Serialize + ( -- * Building + buildMessage + , buildReply + , messageFromReply + -- * Serializing + , serializeMessage + , serializeReply + ) +where + +import Data.Bits (bit, zeroBits, (.|.)) +import Data.Maybe (maybeToList) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Network.Irc.Messages.Mask (serializeMask) +import Network.Irc.Messages.Internal.Util +import Network.Irc.Types + +import qualified Data.Text as T + +------------------------------------------------------------------------------- +-- Building +------------------------------------------------------------------------------- + +showAddr :: Address -> Text +showAddr (IPv4 t) = t +showAddr (IPv6 t) = t + +showHost :: Host -> Text +showHost (HostByName hn) = unHostname hn +showHost (HostByAddr addr) = showAddr addr +showHost (HostCloak t) = t + +showTargetMask :: TargetMask -> Text +showTargetMask (HostMask m) = '#' `T.cons` serializeMask m +showTargetMask (ServerMask m) = '$' `T.cons` serializeMask m + +showTarget :: MessageTarget -> Text +showTarget (ChannelTarget chan) = unChannel chan +showTarget + (UserTarget + Nothing + (Just (UserAddress (Username user) mhost)) + (Just server) + ) = + let u = case mhost of + Nothing -> user + Just host -> user <> "%" <> showHost host + in u <> "@" <> unHostname server +showTarget + (UserTarget + Nothing + (Just (UserAddress (Username user) (Just host))) + Nothing + ) = + user <> "%" <> showHost host +showTarget + (UserTarget + (Just (Nickname nick)) + Nothing + Nothing + ) = + nick +showTarget + (UserTarget + (Just (Nickname nick)) + (Just (UserAddress (Username user) (Just host))) + Nothing + ) = + nick <> "!" <> user <> "@" <> showHost host +showTarget (MaskTarget mt) = showTargetMask mt +showTarget _ = "invalid_target" + +-- Fill command name and parameters from specific message +buildMessage' :: Message -> (Text, [Parameter]) +buildMessage' msg = + case msg of + PassMessage pass -> + ("PASS", [unPassword pass]) + NickMessage nn -> + ("NICK", [unNickname nn]) + UserMessage un i w rn -> + ( "USER" + , [ unUsername un + , showt $ modebit 3 i .|. modebit 2 w + , "*" + , unRealName rn + ] + ) + where + modebit n b = if b then bit n else zeroBits :: Int + OperMessage _un _p -> + ("????", error "Not implemented") + UserModeMessage _n _remove _add -> + ("????", error "Not implemented") + ServiceMessage _n _m _s -> + ("????", error "Not implemented") + QuitMessage reason -> + ("QUIT", perhaps $ fmap unComment reason) + SQuitMessage _s _t -> + ("????", error "Not implemented") + JoinMessage Nothing -> + ("JOIN", ["0"]) + JoinMessage (Just (chans, keys)) -> + ( "JOIN" + , T.intercalate "," (map unChannel chans) : + if null keys + then [] + else [T.intercalate "," $ map unChannelKey keys] + ) + PartMessage chans reason -> + ( "PART" + , T.intercalate "," (map unChannel chans) ?: fmap unComment reason + ) + ChannelModeMessage _remove _add -> + ("????", error "Not implemented") + TopicMessage chan topic -> + ("TOPIC", unChannel chan ?: fmap unChannelTopic topic) + NamesMessage chans serv -> + ( "NAMES" + , T.intercalate "," (map unChannel chans) ?: fmap unHostname serv + ) + ListMessage _chans _serv -> + ("????", error "Not implemented") + InviteMessage _nn _chan -> + ("????", error "Not implemented") + KickMessage _chans _users _s -> + ("????", error "Not implemented") + PrivMsgMessage tgt (MsgContent mc) -> + ("PRIVMSG", [showTarget tgt, mc]) + PrivActionMessage tgt (MsgContent mc) -> + ("PRIVMSG", [showTarget tgt, "\1ACTION " <> mc <> "\1"]) + NoticeMessage tgt (MsgContent mc) -> + ("NOTICE", [showTarget tgt, mc]) + MotdMessage _serv -> + ("????", error "Not implemented") + LusersMessage _serv -> + ("????", error "Not implemented") + VersionMessage _serv -> + ("????", error "Not implemented") + StatsMessage _x -> + ("????", error "Not implemented") + LinksMessage _x -> + ("????", error "Not implemented") + TimeMessage _serv -> + ("????", error "Not implemented") + ConnectMessage _serv _portn _sm -> + ("????", error "Not implemented") + TraceMessage _t -> + ("????", error "Not implemented") + AdminMessage _t -> + ("????", error "Not implemented") + InfoMessage _t -> + ("????", error "Not implemented") + ServlistMessage _ -> + ("????", error "Not implemented") + SQueryMessage _ _ -> + ("????", error "Not implemented") + WhoMessage _ -> + ("????", error "Not implemented") + WhoisMessage _ _ -> + ("????", error "Not implemented") + WhowasMessage _ _ -> + ("????", error "Not implemented") + KillMessage _ _ -> + ("????", error "Not implemented") + PingMessage s1 s2 -> + ("PING", unHostname s1 ?: fmap unHostname s2) + PongMessage s1 s2 -> + ("PONG", unHostname s1 ?: fmap unHostname s2) + ErrorMessage _ -> + ("????", error "Not implemented") + AwayMessage _ -> + ("????", error "Not implemented") + RehashMessage -> + ("????", error "Not implemented") + DieMessage -> + ("????", error "Not implemented") + RestartMessage -> + ("????", error "Not implemented") + SummonMessage _ _ -> + ("????", error "Not implemented") + UsersMessage _ -> + ("????", error "Not implemented") + WallopsMessage _ -> + ("????", error "Not implemented") + UserhostMessage _ -> + ("????", error "Not implemented") + IsonMessage _ -> + ("????", error "Not implemented") + where + perhaps = maybeToList + x ?: my = x : perhaps my + +-- | Fill a generic message record using a specific message's details. +buildMessage :: SpecificMessage -> GenericMessage +buildMessage (SpecificMessage pref msg) = + let (cmd, ps) = buildMessage' msg + in GenericMessage pref (NamedCmd $ CmdName cmd) ps + +channelPrivacyChar :: ChannelPrivacy -> Char +channelPrivacyChar Secret = '@' +channelPrivacyChar Private = '*' +channelPrivacyChar Public = '=' + +privilegeChar :: Privilege -> Maybe Char +privilegeChar Regular = Nothing +privilegeChar Voice = Just '+' +privilegeChar Operator = Just '@' + +-- Fill reply code, target and parameters from specific reply +buildReply' :: Reply -> (Int, [Parameter]) +buildReply' reply = + case reply of + NamesReply priv chan pns -> + ( 353 + , [ T.singleton $ channelPrivacyChar priv + , unChannel chan + , T.unwords $ + map + (\ (p, (Nickname n)) -> + maybe n (`T.cons` n) $ privilegeChar p + ) + pns + ] + ) + _ -> error "Not implemented" + +-- | Fill a generic reply record using a specific reply's details. +buildReply :: SpecificReply -> GenericReply +buildReply (SpecificReply sender tgt reply) = + let (code, ps) = buildReply' reply + in GenericReply sender (CmdNumber code) tgt ps + +-- | Convert a reply, which is a message with a numeric command name, into a +-- generic message value. +messageFromReply :: GenericReply -> GenericMessage +messageFromReply reply = GenericMessage + { gmPrefix = Just $ PrefixServer $ grSender reply + , gmCommand = NumericCmd $ grCode reply + , gmParams = target' reply : grParams reply + } + where + target' (GenericReply { grTarget = NickTarget n }) = unNickname n + target' (GenericReply { grTarget = ServerTarget s }) = unHostname s + +------------------------------------------------------------------------------- +-- Serializing +------------------------------------------------------------------------------- + +serializePrefix :: Prefix -> Text +serializePrefix (PrefixServer sn) = unHostname sn +serializePrefix (PrefixNick n mu mh) = + unNickname n <> + maybe "" ('!' `T.cons`) (fmap unUsername mu) <> + maybe "" (('@' `T.cons`) . showHost) mh + +serializeCommand :: Command -> Text +serializeCommand (NamedCmd t) = unCmdName t +serializeCommand (NumericCmd n) = showt $ unCmdNumber n + +serializeParams :: [Parameter] -> Text +serializeParams = f . map (\ p -> if T.null p then "(?)" else p) + where + f [] = "" + f l = + let (ps, p) = (init l, last l) + in T.concat (map (' ' `T.cons`) ps) <> " " <> + if T.head p == ':' || T.any (== ' ') p + then ':' `T.cons` p + else p + +-- | Write a message into an IRC protocol message formatted string. +serializeMessage :: GenericMessage -> Text +serializeMessage msg = T.concat + [ maybe + T.empty + (\ p -> ':' `T.cons` serializePrefix p `T.snoc` ' ') + (gmPrefix msg) + , serializeCommand $ gmCommand msg + , serializeParams $ gmParams msg + , "\r\n" + ] + +-- | Write a reply into an IRC protocol message formatted string. +-- +-- This is essentially a combination of 'messageFromReply' and +-- 'serializeMessage'. +serializeReply :: GenericReply -> Text +serializeReply = serializeMessage . messageFromReply diff --git a/src/Network/Irc/Messages/Internal/Tokens/Message.hs b/src/Network/Irc/Messages/Internal/Tokens/Message.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Tokens/Message.hs @@ -0,0 +1,89 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Tokens.Message + ( message + ) +where + +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import Network.Irc.Messages.Internal.Tokens.Other +import Network.Irc.Messages.Internal.Tokens.Target +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +----------TOTO +{- +- go over errata, make sure everything here is correct +- some regexes, such as matchone and target, seem not to be used in the rules + here. they're probably intended for later use, e.g. when matching a string + against a mask. in such case the API should probably import them +-} + +message :: Regex GenericMessage +message = + GenericMessage <$> + optional (sym ':' *> prefix <* space) <*> + command <*> + (fromMaybe [] <$> optional params) <* + crlf + +prefix :: Regex Prefix +prefix = + PrefixServer <$> servername + <|> + nick <$> + nickname <*> + optional + ( (,) <$> + optional (sym '!' *> user) <* + sym '@' <*> + host + ) + where + nick n Nothing = PrefixNick n Nothing Nothing + nick n (Just (u, h)) = PrefixNick n u (Just h) + +command :: Regex Command +command = + let f a b c = NumericCmd $ CmdNumber $ read [a, b, c] + in NamedCmd . CmdName . pack <$> some letter + <|> + f <$> digit <*> digit <*> digit + +params :: Regex [Text] +params = + let f m (Just t) = m ++ [t] + f m Nothing = m + in f <$> + many (space *> middle) <*> + optional (space *> sym ':' *> trailing) + +middle :: Regex Text +middle = pack <$> ((:) <$> paramchar <*> many (sym ':' <|> paramchar)) + +trailing :: Regex Text +trailing = pack <$> many (sym ':' <|> sym ' ' <|> paramchar) + +paramchar :: Regex Char +paramchar = psym (`notElem` "\0\r\n :") + +space :: Regex Char +space = sym ' ' + +crlf :: Regex String +crlf = string "\r\n" diff --git a/src/Network/Irc/Messages/Internal/Tokens/Other.hs b/src/Network/Irc/Messages/Internal/Tokens/Other.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Tokens/Other.hs @@ -0,0 +1,62 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Tokens.Other + ( user + , key + , letter + , digit + , hexdigit + , hexdigit' + , special + ) +where + +import Data.Char (isAscii, isDigit) +import Data.Text (pack) +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +user :: Regex Username +user = Username . pack <$> some (psym (`notElem` "\0\r\n @")) + +key :: Regex ChannelKey +key = + ChannelKey . pack <$> + some (psym $ \ c -> isAscii c && c `notElem` "\0\r\n\f\t\v ") + +letter :: Regex Char +letter = psym $ \ c -> 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' + +digit :: Regex Char +digit = psym isDigit + +hexdigit :: Regex Char +hexdigit = digit <|> upperhex + where + upperhex = psym $ \ c -> 'A' <= c && c <= 'F' + +-- RFC 2812 assumes IPv6 addresses with uppercase hex digits. In practice, the +-- recommendation it to use lowercase, and that's what really happens. So this +-- regex accepts both lowercase and uppercase. +hexdigit' :: Regex Char +hexdigit' = digit <|> upperhex <|> lowerhex + where + upperhex = psym $ \ c -> 'A' <= c && c <= 'F' + lowerhex = psym $ \ c -> 'a' <= c && c <= 'f' + +special :: Regex Char +special = psym (`elem` "[]\\`_^{|}") diff --git a/src/Network/Irc/Messages/Internal/Tokens/Reply.hs b/src/Network/Irc/Messages/Internal/Tokens/Reply.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Tokens/Reply.hs @@ -0,0 +1,43 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Tokens.Reply + ( chanpriv + , prefnicks + ) +where + +import Data.Maybe (fromMaybe) +import Network.Irc.Messages.Internal.Tokens.Target +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +------------------------------------------------------------------------------- +-- 353 RPL_NAMREPLY +------------------------------------------------------------------------------- + +chanpriv :: Regex ChannelPrivacy +chanpriv = Secret <$ sym '@' <|> Private <$ sym '*' <|> Public <$ sym '=' + +prefnicks :: Regex [(Privilege, Nickname)] +prefnicks = (:) <$> prefnick <*> many (sym ' ' *> prefnick) + +prefnick :: Regex (Privilege, Nickname) +prefnick = (,) <$> privilege <*> nickname + +privilege :: Regex Privilege +privilege = + fromMaybe Regular <$> optional (Voice <$ sym '+' <|> Operator <$ sym '@') diff --git a/src/Network/Irc/Messages/Internal/Tokens/Target.hs b/src/Network/Irc/Messages/Internal/Tokens/Target.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Tokens/Target.hs @@ -0,0 +1,139 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Tokens.Target + ( target + , msgtarget + , msgto + , channel + , servername + , host + , nickname + ) +where + +import Data.Char (isAsciiUpper) +import Data.Text (Text, pack) +import Network.Irc.Messages.Internal.Tokens.Other +import Network.Irc.Messages.Internal.Tokens.Wildcards +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +target :: Regex Target +target = NickTarget <$> nickname <|> ServerTarget <$> servername + +msgtarget :: Regex [MessageTarget] +msgtarget = (:) <$> msgto <*> many (sym ',' *> msgto) + +msgto :: Regex MessageTarget +msgto = ChannelTarget <$> channel + <|> uhs <$> user + <*> optional (sym '%' *> host) <* sym '@' + <*> servername + <|> uh <$> user <* sym '%' + <*> host + <|> MaskTarget <$> targetmask + <|> nn <$> nickname + <|> nuh <$> nickname <* sym '!' + <*> user <* sym '@' + <*> host + where + uhs u h s = UserTarget Nothing (Just (UserAddress u h)) (Just s) + uh u h = UserTarget Nothing (Just (UserAddress u (Just h))) Nothing + nn n = UserTarget (Just n) Nothing Nothing + nuh n u h = UserTarget (Just n) (Just (UserAddress u (Just h))) Nothing + +channel :: Regex Channel +channel = + Channel . pack . snd <$> + withMatched + ( (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <* + chanstring <* + optional (sym ':' <* chanstring) + ) + +servername :: Regex Hostname +servername = hostname + +host :: Regex Host +host = + HostByAddr <$> hostaddr + <|> + HostByName <$> hostname + <|> + HostCloak <$> hostcloak + +hostname :: Regex Hostname +hostname = + Hostname . pack . snd <$> + withMatched (shortname <* many (sym '.' <* shortname)) + +shortname :: Regex String +shortname = + snd <$> withMatched + ( (letter <|> digit) <* + optional (many (letter <|> digit <|> sym '-') <* (letter <|> digit)) + ) + +hostaddr :: Regex Address +hostaddr = IPv4 <$> ip4addr <|> IPv6 <$> ip6addr + +ip4addr :: Regex Text +ip4addr = pack . snd <$> withMatched (s <* p <* s <* p <* s <* p <* s) + where + d = digit + s = snd <$> withMatched (d <|> d <* d <|> d <* d <* d) + p = sym '.' + +ip6addr :: Regex Text +ip6addr = pack . snd <$> withMatched (full <|> short <|> v4) + where + h = some hexdigit' + c = sym ':' + s = h <* many (c <* h) + full = h <* c <* h <* c <* + h <* c <* h <* c <* + h <* c <* h <* c <* + h <* c <* h + short = optional s *> string "::" <* optional s + v4 = string "0:0:0:0:0:" <* + (string "0" <|> string "FFFF") <* + sym ':' <* + ip4addr + +hostcloak :: Regex Text +hostcloak = + pack <$> some (letter <|> digit <|> special <|> psym (`elem` ".-/")) + +nickname :: Regex Nickname +nickname = + Nickname . pack <$> + ( (:) <$> + (letter <|> special) <*> + many (letter <|> digit <|> special <|> sym '-') + ) + +targetmask :: Regex TargetMask +targetmask = ServerMask <$> (sym '$' *> mask) + <|> HostMask <$> (sym '#' *> mask) + +chanstring :: Regex String +chanstring = many $ psym (`notElem` "\0\a\r\n ,:") + +channelid :: Regex String +channelid = snd <$> withMatched (c *> c *> c *> c *> c) + where + c = psym isAsciiUpper <|> digit diff --git a/src/Network/Irc/Messages/Internal/Tokens/Wildcards.hs b/src/Network/Irc/Messages/Internal/Tokens/Wildcards.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Tokens/Wildcards.hs @@ -0,0 +1,46 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Tokens.Wildcards + ( mask + , matchone + , matchmany + ) +where + +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +mask :: Regex Mask +mask = Mask <$> many (nowild <|> noesc *> wildone <|> noesc *> wildmany) + +wildone :: Regex MaskPart +wildone = MaskWildOne <$ sym '?' + +wildmany :: Regex MaskPart +wildmany = MaskWildMany <$ sym '*' + +nowild :: Regex MaskPart +nowild = MaskChar <$> psym (`notElem` "\0*?") + +noesc :: Regex Char +noesc = psym (`notElem` "\0\\") + +matchone :: Regex Char +matchone = psym (/= '\0') + +matchmany :: Regex String +matchmany = many matchone diff --git a/src/Network/Irc/Messages/Internal/Types.hs b/src/Network/Irc/Messages/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Types.hs @@ -0,0 +1,372 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015, 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Types + ( -- * Type Aliases And Newtypes + Regex + -- * Reply + , CommandResponseCode (..) + , ErrorReplyCode (..) + , ReservedReplyCode (..) + , ReservedErrorCode (..) + ) +where + +import Text.Regex.Applicative (RE) + +-- | TODO +type Regex = RE Char + +------------------------------------------------------------------------------- +-- Reply +------------------------------------------------------------------------------- + +-- | TODO +data CommandResponseCode + -- | TODO + = ReplyWelcome + -- | TODO + | ReplyYourHost + -- | TODO + | ReplyCreated + -- | TODO + | ReplyMyInfo + -- | TODO + | ReplyBounce + -- | TODO + | ReplyUserHost + -- | TODO + | ReplyIsOn + -- | TODO + | ReplyAway + -- | TODO + | ReplyUnAway + -- | TODO + | ReplyNoAway + -- | TODO + | ReplyWhoIsUser + -- | TODO + | ReplyWhoIsServer + -- | TODO + | ReplyWhoIsOperator + -- | TODO + | ReplyWhoIsIdle + -- | TODO + | ReplyEndOfWhoIs + -- | TODO + | ReplyWhoIsChannels + -- | TODO + | ReplyWhoWasUser + -- | TODO + | ReplyEndOfWhoWas + -- | TODO + | ReplyListStart + -- | TODO + | ReplyList + -- | TODO + | ReplyListEnd + -- | TODO + | ReplyUniqueOpIs + -- | TODO + | ReplyChannelModeIs + -- | TODO + | ReplyNoTopic + -- | TODO + | ReplyTopic + -- | TODO + | ReplyInviting + -- | TODO + | ReplySummoning + -- | TODO + | ReplyInviteList + -- | TODO + | ReplyEndOfInviteList + -- | TODO + | ReplyExceptList + -- | TODO + | ReplyEndOfExceptList + -- | TODO + | ReplyVersion + -- | TODO + | ReplyWhoReply + -- | TODO + | ReplyEndOfWho + -- | TODO + | ReplyNameReply + -- | TODO + | ReplyEndOfNames + -- | TODO + | ReplyLinks + -- | TODO + | ReplyEndOfLinks + -- | TODO + | ReplyBanList + -- | TODO + | ReplyEndOfBanList + -- | TODO + | ReplyInfo + -- | TODO + | ReplyEndOfInfo + -- | TODO + | ReplyMotdStart + -- | TODO + | ReplyMessageOfTheDay + -- | TODO + | ReplyEndOfMessageOfTheDay + -- | TODO + | ReplyYoureOper + -- | TODO + | ReplyRehashing + -- | TODO + | ReplyYoureService + -- | TODO + | ReplyTime + -- | TODO + | ReplyUsersStart + -- | TODO + | ReplyUsers + -- | TODO + | ReplyEndOfUsers + -- | TODO + | ReplyNoUsers + -- | TODO + | ReplyTraceLink + -- | TODO + | ReplyTraceConnecting + -- | TODO + | ReplyTraceHandshake + -- | TODO + | ReplyTraceUnknown + -- | TODO + | ReplyTraceOperator + -- | TODO + | ReplyTraceUser + -- | TODO + | ReplyTraceServer + -- | TODO + | ReplyTraceService + -- | TODO + | ReplyTraceNewType + -- | TODO + | ReplyTraceClass + -- | TODO + | ReplyTraceReconnect + -- | TODO + | ReplyTraceLog + -- | TODO + | ReplyTraceEnd + -- | TODO + | ReplyStatsLinkInfo + -- | TODO + | ReplyStatsCommands + -- | TODO + | ReplyEndOfStats + -- | TODO + | ReplyStatsUptime + -- | TODO + | ReplyStatsOLine + -- | TODO + | ReplyUModeIs + -- | TODO + | ReplyServList + -- | TODO + | ReplyServListEnd + -- | TODO + | ReplyLuserClient + -- | TODO + | ReplyLuserOp + -- | TODO + | ReplyLuserUnknown + -- | TODO + | ReplyLuserChannels + -- | TODO + | ReplyLuserMe + -- | TODO + | ReplyAdminMe + -- | TODO + | ReplyAdminLocation1 + -- | TODO + | ReplyAdminLocation2 + -- | TODO + | ReplyAdminEmail + -- | TODO + | ReplyTryAgain + -- | TODO + | ReplyFreenodeISupport + deriving (Eq, Show) + +data ErrorReplyCode + -- | TODO + = ErrorNoSuchNick + -- | TODO + | ErrorNoSuchServer + -- | TODO + | ErrorNoSuchChannel + -- | TODO + | ErrorCannotSendToChannel + -- | TODO + | ErrorTooManyChannels + -- | TODO + | ErrorWasNoSuchNick + -- | TODO + | ErrorTooManyTargets + -- | TODO + | ErrorNoSuchService + -- | TODO + | ErrorNoOrigin + -- | TODO + | ErrorNoRecipient + -- | TODO + | ErrorNoTextToSend + -- | TODO + | ErrorNoTopLevel + -- | TODO + | ErrorWildTopLevel + -- | TODO + | ErrorBadMask + -- | TODO + | ErrorUnknownCommand + -- | TODO + | ErrorNoMessageOfTheDay + -- | TODO + | ErrorNoAdminInfo + -- | TODO + | ErrorFileError + -- | TODO + | ErrorNoNicknameGiven + -- | TODO + | ErrorErroneousNickname + -- | TODO + | ErrorNicknameInUse + -- | TODO + | ErrorNickCollision + -- | TODO + | ErrorUnavailableResource + -- | TODO + | ErrorUserNotInChannel + -- | TODO + | ErrorNotOnChannel + -- | TODO + | ErrorUserOnChannel + -- | TODO + | ErrorNoLogin + -- | TODO + | ErrorSummonDisabled + -- | TODO + | ErrorUsersDisabled + -- | TODO + | ErrorNotRegistered + -- | TODO + | ErrorNeedMoreParams + -- | TODO + | ErrorAlreadyRegistered + -- | TODO + | ErrorNoPermissionForHost + -- | TODO + | ErrorPasswordMismatch + -- | TODO + | ErrorYoureBannedCreep + -- | TODO + | ErrorYouWillBeBanned + -- | TODO + | ErrorKeySet + -- | TODO + | ErrorChannelIsFull + -- | TODO + | ErrorUnknownMode + -- | TODO + | ErrorInviteOnlyChannel + -- | TODO + | ErrorBannedFromChannel + -- | TODO + | ErrorBadChannelKey + -- | TODO + | ErrorBadChannelMask + -- | TODO + | ErrorNoChannelModes + -- | TODO + | ErrorBanListFull + -- | TODO + | ErrorNoPrivileges + -- | TODO + | ErrorChannelOpPrivilegesNeeded + -- | TODO + | ErrorCantKillServer + -- | TODO + | ErrorRestricted + -- | TODO + | ErrorUniqueOpPrivilegesNeeded + -- | TODO + | ErrorNoOperHost + -- | TODO + | ErrorUModeUnknownFlag + -- | TODO + | ErrorUsersDontMatch + deriving (Eq, Show) + +data ReservedReplyCode + -- | TODO + = ReservedReplyServiceInfo + -- | TODO + | ReservedReplyEndOfServices + -- | TODO + | ReservedReplyService + -- | TODO + | ReservedReplyNone + -- | TODO + | ReservedReplyWhoIsChannelOp + -- | TODO + | ReservedReplyKillDone + -- | TODO + | ReservedReplyClosing + -- | TODO + | ReservedReplyCloseEnd + -- | TODO + | ReservedReplyInfoStart + -- | TODO + | ReservedReplyMyPortIs + -- | TODO + | ReservedReplyStatsCLine + -- | TODO + | ReservedReplyStatsNLine + -- | TODO + | ReservedReplyStatsILine + -- | TODO + | ReservedReplyStatsKLine + -- | TODO + | ReservedReplyStatsQLine + -- | TODO + | ReservedReplyStatsYLine + -- | TODO + | ReservedReplyStatsVLine + -- | TODO + | ReservedReplyStatsLLine + -- | TODO + | ReservedReplyStatsHLine + -- | TODO + | ReservedReplyStatsSLine + -- | TODO + | ReservedReplyStatsPing + -- | TODO + | ReservedReplyStatsBLine + -- | TODO + | ReservedReplyStatsDLine + deriving (Eq, Show) + +-- | TODO +data ReservedErrorCode + -- | TODO + = ReservedErrorNoServiceHost + deriving (Eq, Show) diff --git a/src/Network/Irc/Messages/Internal/Util.hs b/src/Network/Irc/Messages/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Internal/Util.hs @@ -0,0 +1,148 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Irc.Messages.Internal.Util + ( showt + , listOf + , req0 + , req1 + , req2 + , req3 + , req4 + , req5 + , req6 + , req0m1 + , req1m2 + , req2m3 + , req3m4 + , min1 + ) +where + +import Data.Text (Text, pack) +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +showt :: Int -> Text +showt = pack . show + +listOf :: Regex a -> Regex [a] +listOf re = (:) <$> re <*> many (sym ',' *> re) + +req0 :: [Parameter] + -> Either AnalysisError Message + -> Either AnalysisError Message +req0 [] f = f +req0 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 0) + +req1 :: [Parameter] + -> (Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req1 [p1] f = f p1 +req1 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 1) + +req2 :: [Parameter] + -> (Parameter -> Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req2 [p1, p2] f = f p1 p2 +req2 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 2) + +req3 :: [Parameter] + -> (Parameter -> Parameter -> Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req3 [p1, p2, p3] f = f p1 p2 p3 +req3 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 3) + +req4 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req4 [p1, p2, p3, p4] f = f p1 p2 p3 p4 +req4 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 4) + +req5 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Parameter + -> Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req5 [p1, p2, p3, p4, p5] f = f p1 p2 p3 p4 p5 +req5 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 5) + +req6 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Parameter + -> Parameter + -> Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req6 [p1, p2, p3, p4, p5,p6] f = f p1 p2 p3 p4 p5 p6 +req6 l _ = Left $ + WrongNumArgs (length l) (Just $ Exactly 6) + +req0m1 :: [Parameter] + -> (Maybe Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req0m1 [] f = f Nothing +req0m1 [p1] f = f $ Just p1 +req0m1 l _ = Left $ WrongNumArgs (length l) (Just $ Between 0 1) + +req1m2 :: [Parameter] + -> (Parameter -> Maybe Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req1m2 [p1] f = f p1 Nothing +req1m2 [p1, p2] f = f p1 (Just p2) +req1m2 l _ = Left $ WrongNumArgs (length l) (Just $ Between 1 2) + +req2m3 :: [Parameter] + -> ( Parameter + -> Parameter + -> Maybe Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req2m3 [p1, p2] f = f p1 p2 Nothing +req2m3 [p1, p2, p3] f = f p1 p2 (Just p3) +req2m3 l _ = Left $ WrongNumArgs (length l) (Just $ Between 2 3) + +req3m4 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Maybe Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req3m4 [p1, p2, p3] f = f p1 p2 p3 Nothing +req3m4 [p1, p2, p3, p4] f = f p1 p2 p3 (Just p4) +req3m4 l _ = Left $ + WrongNumArgs (length l) (Just $ Between 3 4) + +min1 :: [Parameter] + -> (Parameter -> [Parameter] -> Either AnalysisError Message) + -> Either AnalysisError Message +min1 [] _ = Left $ WrongNumArgs 0 (Just $ AtLeast 1) +min1 (p1:ps) f = f p1 ps diff --git a/src/Network/Irc/Messages/Mask.hs b/src/Network/Irc/Messages/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Mask.hs @@ -0,0 +1,72 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | This module deals with wildcard based masks, used for selecting users and +-- servers. +module Network.Irc.Messages.Mask + ( parseMask + , serializeMask + , matches + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text, cons, unpack) +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +import qualified Network.Irc.Messages.Internal.Tokens.Wildcards as T + +{- +TODO +"The mask MUST + have at least 1 (one) "." in it and no wildcards following the last + ".". This requirement exists to prevent people sending messages to + "#*" or "$*", which would broadcast to all users." + +handle this somehow! e.g. a function that tests a mask for validity +-} + +-- | Parse a mask string (e.g. @"*!*@*"@) into a 'Mask' value. Returns +-- 'Nothing' if the string isn't a valid mask. +parseMask :: Text -> Maybe Mask +parseMask = match T.mask . unpack + +--TODO what about escaping and invalid chars? are they handled correctly? +--prepend mapped part to given string +serializeMaskPart :: MaskPart -> Text -> Text +serializeMaskPart (MaskChar '?') t = '\\' `cons` '?' `cons` t +serializeMaskPart (MaskChar '*') t = '\\' `cons` '*' `cons` t +serializeMaskPart (MaskChar c) t = c `cons` t +serializeMaskPart (MaskWildOne) t = '?' `cons` t +serializeMaskPart (MaskWildMany) t = '*' `cons` t + +-- | Converts a 'Mask' value into its string representation in IRC messages. +serializeMask :: Mask -> Text +serializeMask (Mask parts) = foldr serializeMaskPart mempty parts + +-- TODO maybe fold MaskChars into strings? how much faster will it be? +maskToRegex :: Mask -> Regex String +maskToRegex (Mask parts) = snd <$> withMatched (foldr f (pure "") parts) + where + f (MaskChar c) regex = sym c *> regex + f MaskWildOne regex = T.matchone *> regex + f MaskWildMany regex = T.matchmany *> regex + +matches :: String -> Mask -> Bool +matches s m = isJust $ match (maskToRegex m) s + +infix 2 `matches` diff --git a/src/Network/Irc/Messages/Modes.hs b/src/Network/Irc/Messages/Modes.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Modes.hs @@ -0,0 +1,201 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | This module handles user modes and channel modes. +module Network.Irc.Messages.Modes + ( -- * User Modes + umodeToLetter + , umodeFromLetter + , parseUserMode + -- * Channel Modes + , cmodeToLetter + , cmodeFromLetter + , parseChannelModeParams + ) +where + +import Data.Either (isRight) +import Data.Maybe (fromMaybe) +import Data.List (nub, partition) +import Data.Text (Text) +import Data.Tuple (swap) +import Network.Irc.Messages.Internal.Types +import Network.Irc.Types +import Text.Regex.Applicative + +import qualified Data.Text as T + +userModeMap :: [(UserMode, Char)] +userModeMap = + [ (UModeInvisible, 'i') + , (UModeCallerID, 'g') + , (UModeSeeWallops, 'w') + , (UModeDeaf, 'D') + , (UModeNoForwarding, 'Q') + , (UModeBlockUnidentified, 'R') + , (UModeConnectedViaSSL, 'Z') + , (UModeAway, 'a') + , (UModeRestricted, 'r') + , (UModeOperator, 'o') + , (UModeLocalOperator, 'O') + , (UModeSeeNotices, 's') + ] + +umodeToLetter :: UserMode -> Char +umodeToLetter (UModeOther c) = c +umodeToLetter um = + fromMaybe + (error "Implementation error: User mode not assigned a letter") + (lookup um userModeMap) + +umodeFromLetter :: Char -> UserMode +umodeFromLetter c = fromMaybe (UModeOther c) (lookup c $ map swap userModeMap) + +isAsciiLetter :: Char -> Bool +isAsciiLetter c = 'a' <= c && c <= 'z' || 'A' <= c && c <= 'Z' + +-- 1 to remove, 2 to add +umode :: Regex ([UserMode], [UserMode]) +umode = mix <$> many section + where + section = (,) <$> (True <$ sym '+' <|> False <$ sym '-') + <*> (nub <$> many (psym isAsciiLetter)) + mix l = + let (add, remove) = partition fst l + add' = nub $ concatMap snd add + remove' = nub $ concatMap snd remove + in (map umodeFromLetter remove', map umodeFromLetter add') + +-- the one from the MODE irc message +parseUserMode :: Text -> Maybe ([UserMode], [UserMode]) +parseUserMode = match umode . T.unpack + +--TODO add modes from https://freenode.net/using_the_network.shtml +-- freenode it the main target anyway... +-- also maybe add a system for server-specific non-standard flags +channelModeMap :: [(ChannelMode, Char, ChannelModeType)] +channelModeMap = --eIbq,k,flj,CFLMPQScgimnprstz -- o and v type B syntax-wise + [ (CModeCreator, 'O', ModeTypeMaybeSetting) + , (CModeOperator, 'o', ModeTypeSetting) + , (CModeVoice, 'v', ModeTypeSetting) + , (CModeAnonymous, 'a', ModeTypeFlag) + , (CModeInviteOnly, 'i', ModeTypeFlag) + , (CModeModerated, 'm', ModeTypeFlag) + , (CModeNoMessagesFromOutside, 'n', ModeTypeFlag) + , (CModeQuiet, 'q', ModeTypeFlag) + , (CModePrivate, 'p', ModeTypeFlag) + , (CModeSecret, 's', ModeTypeFlag) + , (CModeServerReop, 'r', ModeTypeFlag) + , (CModeTopicSettableByChannelOpOnly, 't', ModeTypeFlag) + , (CModeKey Nothing, 'k', ModeTypeFlag) + , (CModeUserLimit Nothing, 'l', ModeTypeMaybeSetting) + , (CModeBanMask Nothing, 'b', ModeTypeList) + , (CModeExceptionMask Nothing, 'e', ModeTypeList) + , (CModeInvitationMask Nothing, 'I', ModeTypeList) + ] + +freenodeOverride :: [(ChannelMode, Char, ChannelModeType)] +freenodeOverride = + [ (CModeFreenodeQuiet Nothing, 'q', ModeTypeSetting) + ] + +lookupCLetter + :: ChannelMode + -> [(ChannelMode, Char, ChannelModeType)] + -> Maybe Char +lookupCLetter _ [] = Nothing +lookupCLetter q ((m, l, _t):rest) = + if q == m + then Just l + else lookupCLetter q rest + +--TODO make the bool=True mean we use the freenode override +cmodeToLetter :: ChannelMode -> Bool -> Char +cmodeToLetter (CModeOther c _) _ = c +cmodeToLetter cm freenode = + let m = + if freenode + then freenodeOverride ++ channelModeMap + else channelModeMap + in fromMaybe + (error "Implementation error: Channel mode not assigned a letter") + (lookupCLetter cm m) + +lookupCMode + :: Char + -> [(ChannelMode, Char, ChannelModeType)] + -> Maybe ChannelMode +lookupCMode _ [] = Nothing +lookupCMode c ((m, l, _):rest) = if c == l then Just m else lookupCMode c rest + +--TODO make the bool=True mean we use the freenode override +cmodeFromLetter :: Char -> Bool -> ChannelMode +cmodeFromLetter c freenode = + let m = + if freenode + then freenodeOverride ++ channelModeMap + else channelModeMap + in fromMaybe (CModeOther c []) (lookupCMode c m) + +-- the one from the MODE irc message +-- http://www.irc.org/tech_docs/005.html +{- +some rules: + +A + +B + +C + +suppose we are setting 'l', then: + +l : does nothing ++l : does nothing +-l : unsets the mode +l 1000 : sets mode, same as +l 1000 ++l 1000 : sets mode +-l 1000 : unsets mode, the 1000 is ignored + +D + +-} +parseChannelModeParams :: [Text] + -> Bool -- whether to use freenode override + -> Maybe + ( [ChannelMode] -- list additions and boolean sets + , [ChannelMode] -- list removals and boolean unsets + , [ChannelMode] -- setting changes (sets and unsets) + ) +parseChannelModeParams l _freenode = + let _l' = map f l + -- Tag params, each is either a mode (e.g. +abc) or an arg (e.g. *!*@*) + f t = + case match section $ T.unpack t of + Just sect -> Right sect + Nothing -> Left t + section = (,) <$> optional (True <$ sym '+' <|> False <$ sym '-') + <*> (nub <$> many (psym isAsciiLetter)) + -- Collect (sign, modes, [arg]) tuples into a list + _parts [] = Just [] + _parts (Left _ : _) = Nothing + _parts (Right (sign, letters) : ss) = + let (args, next) = break isRight ss + in case _parts next of + Nothing -> Nothing + Just pn -> Just $ (sign, letters, args) : pn + -- Attach args to their modes by mode type + --attach ( + in Nothing diff --git a/src/Network/Irc/Messages/Types.hs b/src/Network/Irc/Messages/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Irc/Messages/Types.hs @@ -0,0 +1,27 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | Most of the types that were once in this module moved to +-- "Network.Irc.Types" in a separate package. The few types left here may +-- move in the future too. +module Network.Irc.Messages.Types + ( CommandResponseCode (..) + , ErrorReplyCode (..) + , ReservedReplyCode (..) + , ReservedErrorCode (..) + ) +where + +import Network.Irc.Messages.Internal.Types