diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +fr33domlover diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,17 @@ +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 + +There is also a web interface at which, among other +things, can display the history log. + +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 + +Then move into the newly created directory and run darcs: + + $ cd irc-fun-messages + $ darcs changes diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,13 @@ +Install from Hackage: + + $ cabal install irc-fun-messages + +Install from unpacked release tarball or source repo: + + $ cd irc-fun-messages + $ cabal install + +Just play with it without installing: + + $ cabal build + $ cabal repl diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,23 @@ +This file lists the user-visible interesting changes between releases. For a +full list of changes to the source, see the ChangeLog. + + + +irc-fun-messages 0.1.0.0 -- 2015-08-09 +====================================== + +General, build and documentation changes: + +* (This is the first release, so everything is new) + +New APIs, features and enhancements: + +* (This is the first release, so everything is a new feature) + +Bug fixes: + +* (This is the first release) + +Dependency changes: + +* (No dependencies at this point) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,14 @@ +See the .cabal file for more info and link to project website the version +control. + +The official download location is Hackage: + + + +This library is free software, and is committed to software freedom. It is +released to the public domain using the CC0 Public Domain Dedication. For the +boring "legal" details see the file 'COPYING'. + +See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains +how to see the history log of the changes done in the code. 'NEWS' provides a +friendly overview of the changes for each release. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/irc-fun-messages.cabal b/irc-fun-messages.cabal new file mode 100644 --- /dev/null +++ b/irc-fun-messages.cabal @@ -0,0 +1,50 @@ +name: irc-fun-messages +version: 0.1.0.0 +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. + . + The package is based on RFC 2812, with modifications and extensions to work + with Freenode. + . + NOTE: The handling of IRC protocol messages is FAR from complete, but there + is enough to e.g. create a basic IRC bot. Missing features are being added as + 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/ +license: PublicDomain +license-file: COPYING +author: fr33domlover +maintainer: fr33domlover@riseup.net +copyright: ♡ Copying is an act of love. Please copy, reuse and share. +category: Data +build-type: Simple +extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README +cabal-version: >=1.10 + +source-repository head + type: darcs + location: http://dev.rel4tion.org/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.TypeAliases + , 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 + -- other-extensions: + build-depends: base >=4.7 && <5 + , regex-applicative >=0.3.1 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Network/IRC/Fun/Messages.hs b/src/Network/IRC/Fun/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/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.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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Parse.hs @@ -0,0 +1,329 @@ +{- 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.Parse + ( -- * Parsing + parseMessage + , messageIsReply + , messageToReply + , parse + -- * Analysis + , analyzeMessage + , analyzeReply + , analyze + ) +where + +import Data.Bits (testBit) +import Data.Char (toUpper) +import Data.List (isSuffixOf) +--import Data.Maybe (fromMaybe) +import Network.IRC.Fun.Messages.Mask (parseMask) +import Network.IRC.Fun.Messages.Modes (parseUserMode) +import qualified Network.IRC.Fun.Messages.Internal.Tokens.Message as T +import qualified Network.IRC.Fun.Messages.Internal.Tokens.Other as T +import qualified Network.IRC.Fun.Messages.Internal.Tokens.Reply as T +import qualified Network.IRC.Fun.Messages.Internal.Tokens.Target as T +import Network.IRC.Fun.Messages.Internal.Types +import Text.Regex.Applicative +import Text.Regex.Applicative.Common (decimal) + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +-- | Parse a raw IRC message string into a generic message structure. +parseMessage :: String -> Maybe GenericMessage +parseMessage s = + match T.message $ if "\r\n" `isSuffixOf` s then s else s ++ "\r\n" + +-- | Check is a given message is a server reply, i.e. has a numeric command and +-- the sender is a server. +messageIsReply :: GenericMessage -> Bool +messageIsReply msg = + let prefOk = + case prefix msg of + Nothing -> False + Just (Server _) -> True + Just (Nick {}) -> False + cmdOk = + case command msg of + StringCommand _ -> False + NumericCommand _ -> True + in prefOk && cmdOk + +-- | Try to convert a generic message into a matching reply value. If +-- successful, return 'Right' the reply. If the message isn't a reply, return +-- 'Left' an error message. +messageToReply :: GenericMessage -> Either String GenericReply +messageToReply msg = + case (prefix msg, command msg, parameters msg) of + (Just (Server s), NumericCommand n, p : ps) -> + Right GenericReply + { sender = s + , code = n + , target = NickTarget p + , params = ps + } + (Just (Server _), NumericCommand _, []) -> + Left "No parameters, must have at least one" + (Just (Nick {}), NumericCommand _, _) -> + Left "Sender prefix is a user, not a server" + (Nothing, NumericCommand _, _) -> + Left "No sender prefix" + (_, StringCommand _, _) -> + Left "Command is not numeric" + +-- | Parse a raw IRC message string into a generic message structure. If the +-- message is detected to be a server reply, a generic reply structure is +-- returned. +-- +-- This is essentially a combination of 'parseMessage' and 'messageToReply'. +parse :: String -> Maybe (Either GenericReply GenericMessage) +parse s = + case parseMessage s of + Nothing -> Nothing + Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg + +------------------------------------------------------------------------------- +-- Analysis +------------------------------------------------------------------------------- + +analyzeMessage' :: Maybe Prefix + -> String + -> [Parameter] + -> Either String Message +analyzeMessage' prefix cmd params = + case map toUpper cmd of + -- Connection registration + "PASS" -> + case params of + [pass] -> Right $ PassMessage pass + [] -> Left "Password missing" + _ -> Left "Too many parameters" + "NICK" -> + case params of + [nick] -> Right $ NickMessage nick + [] -> Left "Nickname missing" + _ -> Left "Too many parameters" + "USER" -> + case params of + [user, mode, _, realname] -> + case match decimal mode :: Maybe Int of + (Just m) -> Right $ UserMessage user + (testBit m 3) + (testBit m 2) + realname + Nothing -> Left " should be a number" + [_:_:_:_:_:_] -> Left "Too many parameters" + _ -> Left "Too few parameters" + "OPER" -> + case params of + [name, pass] -> Right $ OperMessage name pass + [_:_:_:_] -> Left "Too many parameters" + _ -> Left "Too few parameters" + "MODE" -> + case params of + (first:rest) -> + case (match T.nickname first, match T.channel first) of + (Just nick, _) -> + case rest of + [mode] -> + case parseUserMode mode of + Just (remove, add) -> + Right $ UserModeMessage nick + remove + add + Nothing -> + Left "Invalid user mode string" + [] -> Left "Too few parameters" + _ -> Left "Too many parameters" + (Nothing, Just chan) -> Left "Not implemented yet" + {-case parseChannelModeParams rest of + Just X -> + Nothing ->-} + _ -> Left "First parameter invalid" + _ -> + Left "Too new parameters" + "SERVICE" -> + case params of + [nick, _, dist, _, _, info] -> + case parseMask dist of + Just m -> Right $ ServiceMessage nick m info + Nothing -> Left "Distribution mask invalid" + [_:_:_:_:_:_:_:_] -> Left "Too many parameters" + _ -> Left "Too few parameters" + "QUIT" -> + case params of + [] -> Right $ QuitMessage Nothing + [msg] -> Right $ QuitMessage (Just msg) + _ -> Left "Too many parameters" + "SQUIT" -> + case params of + [server, comment] -> Right $ SQuitMessage server comment + [_:_:_:_] -> Left "Too many parameters" + _ -> Left "Too few parameters" + -- Channel operations + "JOIN" -> + case params of + ["0"] -> Right $ JoinMessage Nothing + [channels] -> + let c = (:) <$> T.channel <*> many (sym ',' *> T.channel) + in case match c channels of + Just cs -> Right $ JoinMessage $ Just (cs, []) + _ -> Left "Invalid parameters" + [channels, keys] -> + let c = (:) <$> T.channel <*> many (sym ',' *> T.channel) + k = (:) <$> T.key <*> many (sym ',' *> T.key) + in case (match c channels, match k keys) of + (Just cs, Just ks) -> + Right $ JoinMessage $ Just (cs, ks) + _ -> + Left "Invalid parameters" + _ -> Left "Invalid parameters" + "PART" -> + case params of + [channels] -> + case match c channels of + Just cs -> Right $ PartMessage cs Nothing + Nothing -> Left "Invalid channel list" + [channels, msg] -> + case match c channels of + Just cs -> Right $ PartMessage cs $ Just msg + Nothing -> Left "Invalid channel list" + _ -> Left "Wrong number of parameters" + where + c = (:) <$> T.channel <*> many (sym ',' *> T.channel) + -- "MODE" -> Channel mode handled by MODE above + "TOPIC" -> + case params of + [channel] -> Right $ TopicMessage channel Nothing + [channel, topic] -> Right $ TopicMessage channel $ Just topic + [] -> Left "No parameters given" + _ -> Left "Too many parameters" + "NAMES" -> Left "Not implemented yet" + "LIST" -> Left "Not implemented yet" + "INVITE" -> Left "Not implemented yet" + "KICK" -> Left "Not implemented yet" + -- Sending messages + "PRIVMSG" -> + case params of + [target, text] -> + case match T.msgto target of + Nothing -> Left $ "Invalid message target: " ++ target + Just t -> Right $ PrivMsgMessage t text + (_:_:_:_) -> Left "Too many parameters" + _ -> Left "Too few parameters" + "NOTICE" -> + case params of + [target, text] -> + case match T.msgto target of + Nothing -> Left $ "Invalid notice target: " ++ target + Just t -> Right $ NoticeMessage t text + (_:_:_:_) -> Left "Too many parameters" + _ -> Left "Too few parameters" + -- Server queries and commands + "MOTD" -> Left "Not implemented yet" + "LUSERS" -> Left "Not implemented yet" + "VERSION" -> Left "Not implemented yet" + "STATS" -> Left "Not implemented yet" + "LINKS" -> Left "Not implemented yet" + "TIME" -> Left "Not implemented yet" + "CONNECT" -> Left "Not implemented yet" + "TRACE" -> Left "Not implemented yet" + "ADMIN" -> Left "Not implemented yet" + "INFO" -> Left "Not implemented yet" + -- Service query and commands + "SERVLIST" -> Left "Not implemented yet" + "SQUERY" -> Left "Not implemented yet" + -- User based queries + "WHO" -> Left "Not implemented yet" + "WHOIS" -> Left "Not implemented yet" + "WHOWAS" -> Left "Not implemented yet" + -- Miscellaneous messages + "KILL" -> Left "Not implemented yet" + "PING" -> + case params of + [] -> Left "No parameters given" + [s] -> Right $ PingMessage s Nothing + [s1, s2] -> Right $ PingMessage s1 (Just s2) + _ -> Left "Too many parameters" + "PONG" -> + case params of + [] -> Left "No parameters given" + [s] -> Right $ PongMessage s Nothing + [s1, s2] -> Right $ PongMessage s1 (Just s2) + _ -> Left "Too many parameters" + "ERROR" -> Left "Not implemented yet" + -- Optional features + "AWAY" -> Left "Not implemented yet" + "REHASH" -> Left "Not implemented yet" + "DIE" -> Left "Not implemented yet" + "RESTART" -> Left "Not implemented yet" + "SUMMON" -> Left "Not implemented yet" + "USERS" -> Left "Not implemented yet" + "WALLOPS" -> Left "Not implemented yet" + "USERHOST" -> Left "Not implemented yet" + "ISON" -> Left "Not implemented yet" + _ -> Left "Unrecognized command" + +-- | Read a generic message structure into specific message details. Return +-- 'Left' an error description if analysis fails. If the message is detected +-- to be a reply, return a generic reply structure without analyzing. +analyzeMessage :: GenericMessage + -> Either String (Either GenericReply SpecificMessage) +analyzeMessage msg = + if messageIsReply msg + then fmap Left $ messageToReply msg + else case command msg of + StringCommand c -> + fmap (Right . SpecificMessage (prefix msg)) $ + analyzeMessage' (prefix msg) c (parameters msg) + _ -> + Left "Implementation error" + +analyzeReply' :: Int -> Target -> [Parameter] -> Either String Reply +analyzeReply' c _ params = + case c of + 353 -> + case params of + [priv, chan, nicks] -> + maybe (Left "Invalid parameters") Right $ do + chan' <- match T.channel chan + priv' <- match T.chanpriv priv + pnicks <- match T.prefnicks nicks + return $ NamesReply priv' chan' pnicks + (_:_:_:_:_) -> Left "Too many parameters" + [] -> Left "Too few parameters" + _ -> Left "Not implemented yet" + +-- | Read a generic reply structure into specific reply details. Return +-- 'Left' an error description if analysis fails. +analyzeReply :: GenericReply -> Either String SpecificReply +analyzeReply gr = + fmap (SpecificReply (sender gr) (target gr)) $ + analyzeReply' (code gr) (target gr) (params gr) + +-- | Read a generic reply structure into specific message or reply details. +-- Return 'Left' an error description if analysis fails. +-- +-- This is essentially a combination or 'analyzeMessage' and 'analyzeReply. +analyze :: GenericMessage + -> Either String (Either SpecificReply SpecificMessage) +analyze gm = + case analyzeMessage gm of + Left e -> Left e + Right (Left rpl) -> fmap Left $ analyzeReply rpl + Right (Right msg) -> Right $ Right msg diff --git a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs @@ -0,0 +1,212 @@ +{- 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.Serialize + ( -- * Building + buildMessage + , buildReply + , messageFromReply + -- * Serializing + , serializeMessage + , serializeReply + ) +where + +import Data.Bits (bit, zeroBits, (.|.)) +--import Data.Char (toUpper) +import Data.List (intercalate) +import Data.Maybe (maybeToList) +import Network.IRC.Fun.Messages.Mask (serializeMask) +--import Network.IRC.Fun.Messages.Modes (parseUserMode) +--import Network.IRC.Fun.Messages.Reply (messageToReply, messageIsReply) +import Network.IRC.Fun.Messages.Internal.Types + +------------------------------------------------------------------------------- +-- Building +------------------------------------------------------------------------------- + +showAddr :: Address -> String +showAddr (IPv4 s) = s +showAddr (IPv6 s) = s + +showHost :: Host -> String +showHost (HostName hn) = hn +showHost (HostAddr addr) = showAddr addr +showHost (HostCloak s) = s + +showTargetMask :: TargetMask -> String +showTargetMask (HostMask m) = '#' : serializeMask m +showTargetMask (ServerMask m) = '$' : serializeMask m + +showTarget :: MessageTarget -> String +showTarget (ChannelTarget chan) = chan +showTarget (UserTarget Nothing (Just (UserAddr user mhost)) (Just server)) = + maybe user ((user ++) . ('%' :) . showHost) mhost ++ '@' : server +showTarget (UserTarget Nothing (Just (UserAddr user (Just host))) Nothing) = + user ++ '%' : showHost host +showTarget (UserTarget (Just nick) Nothing Nothing) = nick +showTarget (UserTarget (Just nick) (Just (UserAddr 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 -> (CommandName, [Parameter]) +buildMessage' msg = + case msg of + PassMessage pass -> ("PASS", [pass]) + NickMessage nn -> ("NICK", [nn]) + UserMessage un i w rn -> + ("USER", [un, show $ modebit 3 i .|. modebit 2 w, "*", 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 reason) + SQuitMessage s t -> ("????", error "Not implemented") + JoinMessage Nothing -> ("JOIN", ["0"]) + JoinMessage (Just (chans, keys)) -> + ("JOIN", intercalate "," chans : + if null keys then [] else [intercalate "," keys]) + PartMessage chans reason -> ("PART", intercalate "," chans ?: reason) + ChannelModeMessage remove add -> ("????", error "Not implemented") + TopicMessage chan topic -> ("TOPIC", chan ?: topic) + NamesMessage chans serv -> ("????", error "Not implemented") + ListMessage chans serv -> ("????", error "Not implemented") + InviteMessage nn chan -> ("????", error "Not implemented") + KickMessage chans users s -> ("????", error "Not implemented") + PrivMsgMessage tgt text -> ("PRIVMSG", [showTarget tgt, text]) + NoticeMessage tgt text -> ("NOTICE", [showTarget tgt, text]) + 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", s1 ?: s2) + PongMessage s1 s2 -> ("PONG", s1 ?: 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 (StringCommand 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 + , [ [channelPrivacyChar priv] + , chan + , unwords $ + map (\ (p, n) -> maybe n (: 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 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 + { prefix = Just $ Server $ sender reply + , command = NumericCommand $ code reply + , parameters = target' reply : params reply + } + where + target' (GenericReply { target = NickTarget n }) = n + target' (GenericReply { target = ServerTarget s }) = s + +------------------------------------------------------------------------------- +-- Serializing +------------------------------------------------------------------------------- + +serializePrefix :: Prefix -> String +serializePrefix (Server sn) = sn +serializePrefix (Nick n mu mh) = n + ++ maybe "" ('!' :) mu + ++ maybe "" (('@' :) . showHost) mh + +serializeCommand :: Command -> String +serializeCommand (StringCommand s) = s +serializeCommand (NumericCommand n) = show n + +serializeParams :: [Parameter] -> String +serializeParams = f . map (\ p -> if null p then "(?)" else p) + where + f [] = "" + f l = + let (ps, p) = (init l, last l) + in concatMap (' ' :) ps ++ ' ' : + if head p == ':' || ' ' `elem` p + then ':' : p + else p + +-- | Write a message into an IRC protocol message formatted string. +serializeMessage :: GenericMessage -> String +serializeMessage msg = concat + [ maybe "" (\ p -> ':' : serializePrefix p ++ " ") $ prefix msg + , serializeCommand $ command msg + , serializeParams $ parameters msg + , "\r\n" + ] + +-- | Write a reply into an IRC protocol message formatted string. +-- +-- This is essentially a combination of 'messageFromReply' and +-- 'serializeMessage'. +serializeReply :: GenericReply -> String +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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs @@ -0,0 +1,78 @@ +{- 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 Network.IRC.Fun.Messages.Internal.Tokens.Other +import Network.IRC.Fun.Messages.Internal.Tokens.Target +import Network.IRC.Fun.Messages.Internal.Types hiding ( prefix + , command + , params ) +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 = Server <$> servername + <|> nick <$> nickname + <*> optional ((,) <$> optional (sym '!' *> user) + <* sym '@' + <*> host) + where + nick n Nothing = Nick n Nothing Nothing + nick n (Just (u, h)) = Nick n u (Just h) + +command :: Regex Command +command = StringCommand <$> some letter <|> f <$> digit <*> digit <*> digit + where + f a b c = NumericCommand $ read [a, b, c] + +params :: Regex [Parameter] +params = f <$> many (space *> middle) + <*> optional (space *> sym ':' *> trailing) + where + f m (Just t) = m ++ [t] + f m Nothing = m + +middle :: Regex Parameter +middle = (:) <$> paramchar <*> many (sym ':' <|> paramchar) + +trailing :: Regex Parameter +trailing = 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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs @@ -0,0 +1,48 @@ +{- 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 + , special + ) +where + +import Data.Char (isAscii, isDigit) +import Network.IRC.Fun.Messages.Internal.Types +import Text.Regex.Applicative + +user :: Regex UserName +user = some $ psym (`notElem` "\0\r\n @") + +key :: Regex ChannelKey +key = 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' + +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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs @@ -0,0 +1,42 @@ +{- 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 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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs @@ -0,0 +1,122 @@ +{- 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 Network.IRC.Fun.Messages.Internal.Types hiding (target) +import Network.IRC.Fun.Messages.Internal.Tokens.Other +import Network.IRC.Fun.Messages.Internal.Tokens.Wildcards +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 (UserAddr u h)) (Just s) + uh u h = UserTarget Nothing (Just (UserAddr u (Just h))) Nothing + nn n = UserTarget (Just n) Nothing Nothing + nuh n u h = UserTarget (Just n) (Just (UserAddr u (Just h))) Nothing + +channel :: Regex ChannelName +channel = fmap snd $ withMatched $ + (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <* + chanstring <* + optional (sym ':' <* chanstring) + +servername :: Regex ServerName +servername = hostname + +host :: Regex Host +host = HostName <$> hostname + <|> HostAddr <$> hostaddr + <|> HostCloak <$> hostcloak + +hostname :: Regex String +hostname = 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 String +ip4addr = 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 String +ip6addr = snd <$> withMatched (a <|> b) + where + h = some hexdigit + c = sym ':' + a = h <* c <* h <* c <* + h <* c <* h <* c <* + h <* c <* h <* c <* + h <* c <* h <* c + b = string "0:0:0:0:0:" <* + (string "0" <|> string "FFFF") <* + sym ':' <* + ip4addr + +hostcloak :: Regex String +hostcloak = some $ letter <|> digit <|> special <|> psym (`elem` ".-/") + +nickname :: Regex NickName +nickname = (:) <$> (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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs @@ -0,0 +1,47 @@ +{- 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 ( MaskPart (..) + , Mask (..) + , Regex ) +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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Types.hs @@ -0,0 +1,881 @@ +{- 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.Types + ( -- * Type Aliases + ServerName + , ServiceName + , UserName + , NickName + , ChannelName + , CommandName + , Parameter + , Password + , ChannelKey + , ChannelTopic + , RealName + , Comment + , PortNumber + , Regex + -- * Message Parts + , Prefix (..) + , UserAddr (..) + , Target (..) + , Address (..) + , Host (..) + , Command (..) + -- * Mask + , MaskPart (..) + , Mask (..) + , TargetMask (..) + -- * Message + , GenericMessage (..) + , SpecificMessage (..) + , MessageTarget (..) + , Message (..) + -- * Modes + , UserMode (..) + , ChannelMode (..) + , ChannelModeType (..) + -- * Reply + , CommandResponseCode (..) + , ErrorReplyCode (..) + , ReservedReplyCode (..) + , ReservedErrorCode (..) + , GenericReply (..) + , Reply (..) + , SpecificReply (..) + , Privilege (..) + , ChannelPrivacy (..) + ) +where + +import Text.Regex.Applicative (RE) + +------------------------------------------------------------------------------- +-- Type Aliases +------------------------------------------------------------------------------- + +-- | IRC server hostname, e.g. @"orwell.freenode.net"@ +type ServerName = String + +-- | TODO +type ServiceName = String + +-- | System user name, i.e. the first part of user\@host.tld +type UserName = String + +-- | IRC nickname +type NickName = String + +-- | IRC channel name (including the prefix character), e.g. @"#freepost"@ +type ChannelName = String + +-- | IRC protocol command name, i.e. @"PRIVMSG"@ +type CommandName = String + +-- | IRC message parameter, e.g. second part of @JOIN #freepost@ +type Parameter = String + +-- | TODO +type Password = String + +-- | TODO +type ChannelKey = String + +-- | TODO +type ChannelTopic = String + +-- | TODO +type RealName = String + +-- | TODO +type Comment = String + +-- | TODO +type PortNumber = Int + +-- | TODO +type Regex = RE Char + +------------------------------------------------------------------------------- +-- Message Parts +------------------------------------------------------------------------------- + +-- | IRC message prefix. +data Prefix + -- | The server which sends the message + = Server ServerName + -- | The user which sends the message (if the message comes from a user) + | Nick NickName (Maybe UserName) (Maybe Host) + deriving (Eq, Show) + +-- | User address containing a name part (as in "user") and an optional host +-- part (as in "user@host"). +data UserAddr = UserAddr UserName (Maybe Host) deriving (Eq, Show) + +-- | TODO +data Target = NickTarget NickName | ServerTarget ServerName deriving (Eq, Show) + +-- | An IP address. +data Address = IPv4 String | IPv6 String deriving (Eq, Show) + +-- | A host, either a hostname (e.g. @irc.freenode.net@) or an IP address, or a +-- cloak assigned by the server. +data Host = HostName String | HostAddr Address | HostCloak String + deriving (Eq, Show) + +-- | TODO +data Command = StringCommand CommandName | NumericCommand Int + deriving (Eq, Show) + +------------------------------------------------------------------------------- +-- Masks +------------------------------------------------------------------------------- + +-- | Part of a 'Mask'. +data MaskPart + -- | A literal character. + = MaskChar Char + -- | A wildcard which matches a single character. + | MaskWildOne + -- | A wildcard which matches zero or more characters. + | MaskWildMany + deriving (Eq, Show) + +-- | A pattern for matching host and server names. A mask in the protocol is a +-- string which consists of literal characters and wildcards. There are two +-- wildcards: @'?'@, which matches a single character; @'*'@, which matches any +-- number of characters (zero or more). +newtype Mask = Mask [MaskPart] deriving (Eq, Show) + +-- | Some IRC command parameters are targets, and one way to specify a target +-- is using a 'Mask'. +data TargetMask + -- | Host mask, prefixed with @'#'@ in the protocol. Selects all the users + -- whose host matches the mask. + = HostMask Mask + -- | Server mask, prefixed with @'$'@ in the protocol. Selects all the + -- users connected to a server which matches the mask. + | ServerMask Mask + deriving (Eq, Show) + +------------------------------------------------------------------------------- +-- Message +------------------------------------------------------------------------------- + +-- | A generic IRC message. It consists of a sender prefix, command name +-- (string or numeric) and optionally a list of parameters. +data GenericMessage = GenericMessage + { prefix :: Maybe Prefix + , command :: Command + , parameters :: [Parameter] + } + deriving Show + +-- | An IRC message of a specific type. This includes only messages whose +-- command is a name. Messages with a numeric command are handled in the +-- "Network.IRC.Fun.Messages.Reply" module. +data SpecificMessage = SpecificMessage (Maybe Prefix) Message deriving Show + +-- | Some IRC commands have targets. For example, to which channel to send a +-- given text message. Targets are specified as parameters in IRC messages. +data MessageTarget + -- | An IRC channel. + = ChannelTarget ChannelName + -- | An IRC user. Possible combinations in the protocol are: + -- + -- * Address (address host is required) + -- * Address and server (address host is optional) + -- * Nickname + -- * Nickname and address (address host is required) + | UserTarget (Maybe NickName) (Maybe UserAddr) (Maybe ServerName) + -- | A mask which matches the server or host of the users to whom the + -- message should be sent. + | MaskTarget TargetMask + deriving Show + +-- | A server query. Can be sent through a 'StatsMessage'. +data Query + -- | TODO + = Connections + -- | TODO + | CommandUsage + -- | TODO + | PrivilegedUsers + -- | TODO + | Uptime + -- | TODO + | OtherQuery Char + deriving Show + +-- TODO in all the either-servername-mask occurences, make sure in the RFC +-- that they are " may contain wildcards" cases, and replace them with +-- plain ServerName - let's treat mask as a user mask (for bans etc.) +-- TODO in all the cases, do they mean a user can be specified too, +-- to mean "the server this user is connected to"? try with some IRC servers +-- over telnet, and change ServerName to Target if yes. Note that servername +-- has '.' chars while a nickname can't, so that's how one tells which is which +-- Also compare with existing irc packages, how they model these messages + +-- | An IRC message of specific type (excluding the optional sender prefix, see +-- 'SpecificMessage'). +data Message +-- Connection registration + = PassMessage Password + | NickMessage NickName + -- | first bool = whether invisible, second bool = whether sees wallops + | UserMessage UserName Bool Bool RealName + | OperMessage UserName Password + -- | first list: modes to remove (-), second list: modes to add (+) + | UserModeMessage NickName [UserMode] [UserMode] + | ServiceMessage NickName Mask String + | QuitMessage (Maybe String) + | SQuitMessage ServerName String +-- Channel operations + | JoinMessage (Maybe ([ChannelName], [ChannelKey])) + | PartMessage [ChannelName] (Maybe String) + -- first: remove (-), second: add/set (+) + | ChannelModeMessage [ChannelMode] [ChannelMode] + | TopicMessage ChannelName (Maybe ChannelTopic) + | NamesMessage [ChannelName] (Maybe ServerName) + | ListMessage [ChannelName] (Maybe (Either ServerName Mask)) + | InviteMessage NickName ChannelName + | KickMessage [ChannelName] [UserName] (Maybe Comment) +-- Sending messages + | PrivMsgMessage MessageTarget String + | NoticeMessage MessageTarget String +-- Server queries and commands + | MotdMessage (Maybe (Either ServerName Mask)) + | LusersMessage (Maybe (Mask, Maybe ServerName)) + | VersionMessage (Maybe (Either ServerName Mask)) + | StatsMessage (Maybe (Query, Maybe (Either ServerName Mask))) + | LinksMessage (Maybe (Maybe (Either ServerName Mask), Mask)) + | TimeMessage (Maybe (Either ServerName Mask)) + | ConnectMessage ServerName PortNumber (Either ServerName Mask) + | TraceMessage (Maybe Target) + | AdminMessage (Maybe Target) + | InfoMessage (Maybe Target) +-- Service query and commands + | ServlistMessage (Maybe (Mask, Maybe String)) + | SQueryMessage ServiceName String +-- User based queries + | WhoMessage (Maybe (Mask, Bool)) + | WhoisMessage (Maybe ServerName) [Mask] + | WhowasMessage [NickName] (Maybe (Int, Maybe ServerName)) +-- Miscellaneous messages + | KillMessage NickName Comment + | PingMessage ServerName (Maybe ServerName) + | PongMessage ServerName (Maybe ServerName) + | ErrorMessage String +-- Optional features + | AwayMessage (Maybe String) + | RehashMessage + | DieMessage + | RestartMessage + | SummonMessage UserName (Maybe (ServerName, Maybe ChannelName)) + | UsersMessage (Maybe ServerName) + | WallopsMessage String + | UserhostMessage [NickName] + | IsonMessage [NickName] + deriving Show + +------------------------------------------------------------------------------- +-- Modes +------------------------------------------------------------------------------- + +-- | TODO +data UserMode + -- http://toxin.jottit.com/freenode_user_modes + = UModeInvisible + | UModeCallerID + | UModeSeeWallops + | UModeDeaf + | UModeNoForwarding + | UModeBlockUnidentified + | UModeConnectedViaSSL + -- from the irc rfc, MODE message (section 3.1.5) + | UModeAway + | UModeRestricted + | UModeOperator + | UModeLocalOperator + | UModeSeeNotices + | UModeOther Char + deriving (Eq, Show) + +-- | TODO +data ChannelMode + = CModeCreator + | CModeOperator + | CModeVoice + | CModeAnonymous + | CModeInviteOnly + | CModeModerated + | CModeNoMessagesFromOutside + | CModeQuiet + | CModePrivate + | CModeSecret + | CModeServerReop + | CModeTopicSettableByChannelOpOnly + | CModeKey (Maybe ChannelKey) + | CModeUserLimit (Maybe Int) + | CModeBanMask (Maybe Mask) + | CModeExceptionMask (Maybe Mask) + | CModeInvitationMask (Maybe Mask) + | CModeOther Char [String] + | CModeFreenodeQuiet (Maybe Mask) + deriving (Eq, Show) + +data ChannelModeType + = ModeTypeList + | ModeTypeSetting + | ModeTypeMaybeSetting + | ModeTypeFlag + +------------------------------------------------------------------------------- +-- 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) + +-- | TODO +data GenericReply = GenericReply + { sender :: ServerName + , code :: Int + , target :: Target + , params :: [Parameter] + } + deriving Show + +-- | TODO +data Reply + -- | TODO + = WelcomeReply + -- | TODO + | YourHostReply + -- | TODO + | CreatedReply + -- | TODO + | MyInfoReply + -- | TODO + | BounceReply + -- | TODO + | ISupportReply + -- | TODO + | UserHostReply + -- | TODO + | IsOnReply + -- | TODO + | AwayReply + -- | TODO + | UnAwayReply + -- | TODO + | NoAwayReply + -- | TODO + | WhoIsUserReply + -- | TODO + | WhoIsServerReply + -- | TODO + | WhoIsOperatorReply + -- | TODO + | WhoIsIdleReply + -- | TODO + | EndOfWhoIsReply + -- | TODO + | WhoIsChannelsReply + -- | TODO + | WhoWasUserReply + -- | TODO + | EndOfWhoWasReply + -- | TODO + | ListStartReply + -- | TODO + | ListReply + -- | TODO + | ListEndReply + -- | TODO + | UniqueOpIsReply + -- | TODO + | ChannelModeIsReply + -- | TODO + | NoTopicReply + -- | TODO + | TopicReply + -- | TODO + | InvitingReply + -- | TODO + | SummoningReply + -- | TODO + | InviteListReply + -- | TODO + | EndOfInviteListReply + -- | TODO + | ExceptListReply + -- | TODO + | EndOfExceptListReply + -- | TODO + | VersionReply + -- | TODO + | WhoReply + -- | TODO + | EndOfWhoReply + -- | Lists members of IRC channels. Sent when JOINing a channel to list the + -- users in that channel, or as a response to the NAMES command. + | NamesReply ChannelPrivacy ChannelName [(Privilege, NickName)] + -- | Sent after a sequence of 0 or more 'NameReply's, to signal that the + -- list transmission is finished. + | EndOfNamesReply + -- | TODO + | LinksReply + -- | TODO + | EndOfLinksReply + -- | TODO + | BanListReply + -- | TODO + | EndOfBanListReply + -- | TODO + | InfoReply + -- | TODO + | EndOfInfoReply + -- | TODO + | MotdStartReply + -- | TODO + | MessageOfTheDayReply + -- | TODO + | EndOfMessageOfTheDayReply + -- | TODO + | YoureOperReply + -- | TODO + | RehashingReply + -- | TODO + | YoureServiceReply + -- | TODO + | TimeReply + -- | TODO + | UsersStartReply + -- | TODO + | UsersReply + -- | TODO + | EndOfUsersReply + -- | TODO + | NoUsersReply + -- | TODO + | TraceLinkReply + -- | TODO + | TraceConnectingReply + -- | TODO + | TraceHandshakeReply + -- | TODO + | TraceUnknownReply + -- | TODO + | TraceOperatorReply + -- | TODO + | TraceUserReply + -- | TODO + | TraceServerReply + -- | TODO + | TraceServiceReply + -- | TODO + | TraceNewTypeReply + -- | TODO + | TraceClassReply + -- | TODO + | TraceReconnectReply + -- | TODO + | TraceLogReply + -- | TODO + | TraceEndReply + -- | TODO + | StatsLinkInfoReply + -- | TODO + | StatsCommandsReply + -- | TODO + | EndOfStatsReply + -- | TODO + | StatsUptimeReply + -- | TODO + | StatsOLineReply + -- | TODO + | UModeIsReply + -- | TODO + | ServListReply + -- | TODO + | ServListEndReply + -- | TODO + | LuserClientReply + -- | TODO + | LuserOpReply + -- | TODO + | LuserUnknownReply + -- | TODO + | LuserChannelsReply + -- | TODO + | LuserMeReply + -- | TODO + | AdminMeReply + -- | TODO + | AdminLocation1Reply + -- | TODO + | AdminLocation2Reply + -- | TODO + | AdminEmailReply + -- | TODO + | TryAgainReply + deriving (Eq, Show) + +-- | An IRC server numeric reply of a specific type. +data SpecificReply = SpecificReply ServerName Target Reply deriving Show + +-- +data Privilege = Regular | Voice | Operator deriving (Eq, Show) + +-- +data ChannelPrivacy = Secret | Private | Public deriving (Eq, Show) diff --git a/src/Network/IRC/Fun/Messages/Mask.hs b/src/Network/IRC/Fun/Messages/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Mask.hs @@ -0,0 +1,69 @@ +{- 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 qualified Network.IRC.Fun.Messages.Internal.Tokens.Wildcards as T +import Network.IRC.Fun.Messages.Internal.Types +import Text.Regex.Applicative + +{- +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 :: String -> Maybe Mask +parseMask = match T.mask + +--TODO what about escaping and invalid chars? are they handled correctly? +--prepend mapped part to given string +serializeMaskPart :: MaskPart -> String -> String +serializeMaskPart (MaskChar '?') s = '\\' : '?' : s +serializeMaskPart (MaskChar '*') s = '\\' : '*' : s +serializeMaskPart (MaskChar c) s = c : s +serializeMaskPart (MaskWildOne) s = '?' : s +serializeMaskPart (MaskWildMany) s = '*' : s + +-- | Converts a 'Mask' value into its string representation in IRC messages. +serializeMask :: Mask -> String +serializeMask (Mask parts) = foldr serializeMaskPart "" 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 new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Modes.hs @@ -0,0 +1,188 @@ +{- 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.Tuple (swap) +import Network.IRC.Fun.Messages.Internal.Types +import Text.Regex.Applicative + +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 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 :: String -> Maybe ([UserMode], [UserMode]) +parseUserMode = match umode + +--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 _ [] = 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 _ [] = Nothing +lookupCMode c ((m, l, t):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 :: [String] + -> 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 s = + case match section s of + Just sect -> Right sect + Nothing -> Left s + 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/TypeAliases.hs b/src/Network/IRC/Fun/Messages/TypeAliases.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/TypeAliases.hs @@ -0,0 +1,35 @@ +{- 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 provides type aliases used throughout the package for +-- readability. +module Network.IRC.Fun.Messages.TypeAliases + ( ServerName + , ServiceName + , UserName + , NickName + , ChannelName + , CommandName + , Parameter + , Password + , ChannelKey + , ChannelTopic + , RealName + , Comment + , PortNumber + ) +where + +import Network.IRC.Fun.Messages.Internal.Types diff --git a/src/Network/IRC/Fun/Messages/Types.hs b/src/Network/IRC/Fun/Messages/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Types.hs @@ -0,0 +1,51 @@ +{- 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 provides datatypes for modeling parts of IRC messages. +module Network.IRC.Fun.Messages.Types + ( -- * Message Parts + Prefix (..) + , UserAddr (..) + , Target (..) + , Address (..) + , Host (..) + , Command (..) + -- * Mask + , MaskPart (..) + , Mask (..) + , TargetMask (..) + -- * Message + , GenericMessage (..) + , SpecificMessage (..) + , MessageTarget (..) + , Message (..) + -- * Modes + , UserMode (..) + , ChannelMode (..) + , ChannelModeType (..) + -- * Reply + , CommandResponseCode (..) + , ErrorReplyCode (..) + , ReservedReplyCode (..) + , ReservedErrorCode (..) + , GenericReply (..) + , Reply (..) + , SpecificReply (..) + , Privilege (..) + , ChannelPrivacy (..) + ) +where + +import Network.IRC.Fun.Messages.Internal.Types