irc-fun-messages 0.2.0.1 → 0.3.0.0
raw patch · 16 files changed
+574/−951 lines, 16 filesdep +irc-fun-typesdep +text
Dependencies added: irc-fun-types, text
Files
- NEWS +0/−97
- NEWS.md +124/−0
- irc-fun-messages.cabal +4/−3
- src/Network/IRC/Fun/Messages/Internal/Parse.hs +103/−69
- src/Network/IRC/Fun/Messages/Internal/Serialize.hs +196/−102
- src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs +38/−25
- src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs +7/−3
- src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs +3/−2
- src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs +39/−24
- src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs +2/−3
- src/Network/IRC/Fun/Messages/Internal/Types.hs +6/−534
- src/Network/IRC/Fun/Messages/Internal/Util.hs +7/−1
- src/Network/IRC/Fun/Messages/Mask.hs +14/−11
- src/Network/IRC/Fun/Messages/Modes.hs +27/−14
- src/Network/IRC/Fun/Messages/TypeAliases.hs +0/−35
- src/Network/IRC/Fun/Messages/Types.hs +4/−28
− NEWS
@@ -1,97 +0,0 @@-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.2.0.1 -- 2015-12-17-======================================--General, build and documentation changes:--* (None)--New APIs, features and enhancements:--* (None)--Bug fixes:--* Fix bug in IPv6 parsing. It caused IPv6 users to be ignored by IRC clients- using this library, since their messages failed to parse. In fact the parser- *was* written according to the RFC, but now it really accepts the actually- used IPv6 text forms.--Dependency changes:--* (None)------irc-fun-messages 0.2.0.0 -- 2015-10-17-======================================--General, build and documentation changes:--* Prefix some record field names, they had too generic names--New APIs, features and enhancements:--* Recognize action messages (/me)-* Implement parsing of a few more IRC messages, previously unimplemented--Bug fixes:--* (None)--Dependency changes:--* (None)------irc-fun-messages 0.1.0.1 -- 2015-09-10-======================================--General, build and documentation changes:--* (None)--New APIs, features and enhancements:--* The NAMES command can be serialized now--Bug fixes:--* The reply parsing `case` had a typo which caused a missing pattern match, and- that would cause a crash during runtime.--Dependency changes:--* (None)------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)
+ NEWS.md view
@@ -0,0 +1,124 @@+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.3.0.0 -- 2016-01-27+======================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* Move from `String` to strict `Text`+* Some small name changes to several types+* Most type aliases replaced with `newtype`s+* Move most of the types into the new `irc-fun-types` package++Bug fixes:++* (None)++Dependency changes:++* Add irc-fun-types+ text >= 1++++++irc-fun-messages 0.2.0.1 -- 2015-12-17+======================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* (None)++Bug fixes:++* Fix bug in IPv6 parsing. It caused IPv6 users to be ignored by IRC clients+ using this library, since their messages failed to parse. In fact the parser+ *was* written according to the RFC, but now it really accepts the actually+ used IPv6 text forms.++Dependency changes:++* (None)++++++irc-fun-messages 0.2.0.0 -- 2015-10-17+======================================++General, build and documentation changes:++* Prefix some record field names, they had too generic names++New APIs, features and enhancements:++* Recognize action messages (/me)+* Implement parsing of a few more IRC messages, previously unimplemented++Bug fixes:++* (None)++Dependency changes:++* (None)++++++irc-fun-messages 0.1.0.1 -- 2015-09-10+======================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* The NAMES command can be serialized now++Bug fixes:++* The reply parsing `case` had a typo which caused a missing pattern match, and+ that would cause a crash during runtime.++Dependency changes:++* (None)++++++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)
irc-fun-messages.cabal view
@@ -1,5 +1,5 @@ name: irc-fun-messages-version: 0.2.0.1+version: 0.3.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@@ -22,7 +22,7 @@ copyright: ♡ Copying is an act of love. Please copy, reuse and share. category: Data, IRC, Network build-type: Simple-extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README.md+extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS.md README.md cabal-version: >=1.10 source-repository head@@ -33,7 +33,6 @@ 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@@ -46,7 +45,9 @@ , Network.IRC.Fun.Messages.Internal.Util -- other-extensions: build-depends: base >=4.7 && <5+ , irc-fun-types , regex-applicative >=0.3.1+ , text >=1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall
src/Network/IRC/Fun/Messages/Internal/Parse.hs view
@@ -13,6 +13,8 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} +{-# LANGUAGE OverloadedStrings #-}+ module Network.IRC.Fun.Messages.Internal.Parse ( -- * Parsing parseMessage@@ -28,11 +30,15 @@ import Data.Bits (testBit) import Data.Char (toUpper)-import Data.List (isSuffixOf, stripPrefix)+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) @@ -46,9 +52,14 @@ ------------------------------------------------------------------------------- -- | 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"+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.@@ -57,34 +68,34 @@ let prefOk = case gmPrefix msg of Nothing -> False- Just (Server _) -> True- Just (Nick {}) -> False+ Just (PrefixServer _) -> True+ Just (PrefixNick {}) -> False cmdOk = case gmCommand msg of- StringCommand _ -> False- NumericCommand _ -> True+ 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 String GenericReply+messageToReply :: GenericMessage -> Either Text GenericReply messageToReply msg = case (gmPrefix msg, gmCommand msg, gmParams msg) of- (Just (Server s), NumericCommand n, p : ps) ->+ (Just (PrefixServer s), NumericCmd n, p : ps) -> Right GenericReply { grSender = s , grCode = n- , grTarget = NickTarget p+ , grTarget = NickTarget $ Nickname p , grParams = ps }- (Just (Server _), NumericCommand _, []) ->+ (Just (PrefixServer _), NumericCmd _, []) -> Left "No parameters, must have at least one"- (Just (Nick {}), NumericCommand _, _) ->+ (Just (PrefixNick {}), NumericCmd _, _) -> Left "Sender prefix is a user, not a server"- (Nothing, NumericCommand _, _) ->+ (Nothing, NumericCmd _, _) -> Left "No sender prefix"- (_, StringCommand _, _) ->+ (_, NamedCmd _, _) -> Left "Command is not numeric" -- | Parse a raw IRC message string into a generic message structure. If the@@ -92,9 +103,9 @@ -- returned. -- -- This is essentially a combination of 'parseMessage' and 'messageToReply'.-parse :: String -> Maybe (Either GenericReply GenericMessage)-parse s =- case parseMessage s of+parse :: Text -> Maybe (Either GenericReply GenericMessage)+parse t =+ case parseMessage t of Nothing -> Nothing Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg @@ -104,22 +115,31 @@ mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f (Left x) = Left $ f x-mapLeft _ (Right y) = Right y+mapLeft _ (Right x) = Right x +matcht :: Regex a -> Text -> Maybe a+matcht re = match re . unpack+ analyzeMessage' :: Maybe Prefix -> String -> [Parameter]- -> Either String Message-analyzeMessage' _prefix cmd params = mapLeft show $+ -> Either Text Message+analyzeMessage' _prefix cmd params = mapLeft (pack . show) $ case map toUpper cmd of -- Connection registration- "PASS" -> req1 params $ \ pass -> Right $ PassMessage pass- "NICK" -> req1 params $ \ nick -> Right $ NickMessage nick+ "PASS" -> req1 params $ \ pass ->+ Right $ PassMessage (Password pass)+ "NICK" -> req1 params $ \ nick ->+ Right $ NickMessage (Nickname nick) "USER" -> req4 params $ \ user mode _ realname ->- case match decimal mode :: Maybe Int of+ case matcht decimal mode :: Maybe Int of Just m -> Right $- UserMessage user (testBit m 3) (testBit m 2) realname+ UserMessage+ (Username user)+ (testBit m 3)+ (testBit m 2)+ (RealName realname) Nothing -> Left $ InvalidArg@@ -127,9 +147,9 @@ (Just "mode") (Just "Should be a number") "OPER" -> req2 params $ \ name pass ->- Right $ OperMessage name pass+ Right $ OperMessage (Username name) (Password pass) "MODE" -> min1 params $ \ first rest ->- case (match T.nickname first, match T.channel first) of+ case (matcht T.nickname first, matcht T.channel first) of (Just nick, _) -> case rest of [mode] ->@@ -149,20 +169,21 @@ Left $ InvalidArg (Just 1) Nothing Nothing "SERVICE" -> req6 params $ \ nick _ dist _ _ info -> case parseMask dist of- Just m -> Right $ ServiceMessage nick m info+ Just m -> Right $ ServiceMessage (Nickname nick) m info Nothing -> Left $ InvalidArg (Just 3) (Just "distribution mask") Nothing- "QUIT" -> req0m1 params $ \ msg -> Right $ QuitMessage msg+ "QUIT" -> req0m1 params $ \ msg ->+ Right $ QuitMessage (fmap Comment msg) "SQUIT" -> req2 params $ \ server comment ->- Right $ SQuitMessage 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 = match (listOf T.channel) chans- mks = maybe (Just []) (match $ listOf T.key) mkeys+ let mcs = matcht (listOf T.channel) chans+ mks = maybe (Just []) (matcht $ listOf T.key) mkeys in case (mcs, mks) of (Nothing, _) -> Left $@@ -173,24 +194,25 @@ (Just cs, Just ks) -> Right $ JoinMessage $ Just (cs, ks) "PART" -> req1m2 params $ \ chans msg ->- case match (listOf T.channel) chans of- Just cs -> Right $ PartMessage cs msg+ 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 chan topic+ Right $ TopicMessage (Channel chan) (fmap ChannelTopic topic) "NAMES" -> case params of [] -> Right $ NamesMessage [] Nothing [chans] ->- case match (listOf T.channel) chans of+ case matcht (listOf T.channel) chans of Just cs -> Right $ NamesMessage cs Nothing Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing [chans, target] ->- case match (listOf T.channel) chans of- Just cs -> Right $ NamesMessage cs (Just target)+ case matcht (listOf T.channel) chans of+ Just cs ->+ Right $ NamesMessage cs (Just $ Hostname target) Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing@@ -200,29 +222,30 @@ case params of [] -> Right $ ListMessage [] Nothing [chans] ->- case match (listOf T.channel) chans of+ case matcht (listOf T.channel) chans of Just cs -> Right $ ListMessage cs Nothing Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing [chans, target] ->- case match (listOf T.channel) chans of- Just cs -> Right $ ListMessage cs (Just target)+ 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 (match T.nickname nick, match T.channel chan) of+ 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 = match (listOf T.channel) chans- ucs = match (listOf T.nickname) users+ 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@@ -232,28 +255,30 @@ let lc = length cs lu = length us in if lc == 1 || lc == lu- then Right $ KickMessage cs us comment+ then Right $+ KickMessage cs us (fmap Comment comment) else Left $ OtherError "Invalid list lengths" -- Sending messages "PRIVMSG" -> req2 params $ \ target text ->- case match T.msgto target of+ 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 $ init s- else PrivMsgMessage t text- Nothing -> PrivMsgMessage t text+ then PrivActionMessage t (MsgContent $ init s)+ else PrivMsgMessage t (MsgContent text)+ Nothing -> PrivMsgMessage t (MsgContent text) "NOTICE" -> req2 params $ \ target text ->- case match T.msgto target of+ case matcht T.msgto target of Nothing -> Left $ InvalidArg (Just 1) (Just "target") (Just target) Just t ->- Right $ NoticeMessage t text+ Right $ NoticeMessage t (MsgContent text) -- Server queries and commands- "MOTD" -> req0m1 params $ \ target -> Right $ MotdMessage target+ "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"@@ -266,9 +291,11 @@ case target of Nothing -> Right $ InfoMessage Nothing Just t ->- Right $ case match T.nickname t of- Just n -> InfoMessage (Just $ NickTarget n)- Nothing -> InfoMessage (Just $ ServerTarget t)+ 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"@@ -278,11 +305,14 @@ "WHOWAS" -> Left $ OtherError "Not implemented yet" -- Miscellaneous messages "KILL" -> Left $ OtherError "Not implemented yet"- "PING" -> req1m2 params $ \ s1 s2 -> Right $ PingMessage s1 s2- "PONG" -> req1m2 params $ \ s1 s2 -> Right $ PongMessage s1 s2+ "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 text+ "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"@@ -296,28 +326,32 @@ -- | 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+ :: GenericMessage+ -> Either Text (Either GenericReply SpecificMessage) analyzeMessage msg = if messageIsReply msg then fmap Left $ messageToReply msg else case gmCommand msg of- StringCommand c ->+ NamedCmd c -> fmap (Right . SpecificMessage (gmPrefix msg)) $- analyzeMessage' (gmPrefix msg) c (gmParams msg)+ analyzeMessage'+ (gmPrefix msg)+ (unpack $ unCmdName c)+ (gmParams msg) _ -> Left "Implementation error" -analyzeReply' :: Int -> Target -> [Parameter] -> Either String Reply+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' <- match T.channel chan- priv' <- match T.chanpriv priv- pnicks <- match T.prefnicks nicks+ 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"@@ -325,17 +359,17 @@ -- | Read a generic reply structure into specific reply details. Return -- 'Left' an error description if analysis fails.-analyzeReply :: GenericReply -> Either String SpecificReply+analyzeReply :: GenericReply -> Either Text SpecificReply analyzeReply gr = fmap (SpecificReply (grSender gr) (grTarget gr)) $- analyzeReply' (grCode gr) (grTarget gr) (grParams 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 String (Either SpecificReply SpecificMessage)+ -> Either Text (Either SpecificReply SpecificMessage) analyze gm = case analyzeMessage gm of Left e -> Left e
src/Network/IRC/Fun/Messages/Internal/Serialize.hs view
@@ -13,6 +13,8 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} +{-# LANGUAGE OverloadedStrings #-}+ module Network.IRC.Fun.Messages.Internal.Serialize ( -- * Building buildMessage@@ -25,101 +27,185 @@ where import Data.Bits (bit, zeroBits, (.|.))---import Data.Char (toUpper)-import Data.List (intercalate) import Data.Maybe (maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text) 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+import Network.IRC.Fun.Messages.Internal.Util+import Network.IRC.Fun.Types +import qualified Data.Text as T+ ------------------------------------------------------------------------------- -- Building ------------------------------------------------------------------------------- -showAddr :: Address -> String-showAddr (IPv4 s) = s-showAddr (IPv6 s) = s+showAddr :: Address -> Text+showAddr (IPv4 t) = t+showAddr (IPv6 t) = t -showHost :: Host -> String-showHost (HostName hn) = hn-showHost (HostAddr addr) = showAddr addr-showHost (HostCloak s) = s+showHost :: Host -> Text+showHost (HostByName hn) = unHostname hn+showHost (HostByAddr addr) = showAddr addr+showHost (HostCloak t) = t -showTargetMask :: TargetMask -> String-showTargetMask (HostMask m) = '#' : serializeMask m-showTargetMask (ServerMask m) = '$' : serializeMask m+showTargetMask :: TargetMask -> Text+showTargetMask (HostMask m) = '#' `T.cons` serializeMask m+showTargetMask (ServerMask m) = '$' `T.cons` 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 :: 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 -> (CommandName, [Parameter])+buildMessage' :: Message -> (Text, [Parameter]) buildMessage' msg = case msg of- PassMessage pass -> ("PASS", [pass])- NickMessage nn -> ("NICK", [nn])+ PassMessage pass ->+ ("PASS", [unPassword pass])+ NickMessage nn ->+ ("NICK", [unNickname nn]) UserMessage un i w rn ->- ("USER", [un, show $ modebit 3 i .|. modebit 2 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 reason)- SQuitMessage s t -> ("????", error "Not implemented")- JoinMessage Nothing -> ("JOIN", ["0"])+ 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", 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 -> ("NAMES", intercalate "," chans ?: serv)- 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])- PrivActionMessage tgt text ->- ("PRIVMSG", [showTarget tgt, "\1ACTION " ++ text ++ "\1"])- 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")+ ( "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@@ -128,7 +214,7 @@ buildMessage :: SpecificMessage -> GenericMessage buildMessage (SpecificMessage pref msg) = let (cmd, ps) = buildMessage' msg- in GenericMessage pref (StringCommand cmd) ps+ in GenericMessage pref (NamedCmd $ CmdName cmd) ps channelPrivacyChar :: ChannelPrivacy -> Char channelPrivacyChar Secret = '@'@@ -146,10 +232,14 @@ case reply of NamesReply priv chan pns -> ( 353- , [ [channelPrivacyChar priv]- , chan- , unwords $- map (\ (p, n) -> maybe n (: n) $ privilegeChar p) pns+ , [ T.singleton $ channelPrivacyChar priv+ , unChannel chan+ , T.unwords $+ map+ (\ (p, (Nickname n)) ->+ maybe n (`T.cons` n) $ privilegeChar p+ )+ pns ] ) _ -> error "Not implemented"@@ -158,49 +248,53 @@ buildReply :: SpecificReply -> GenericReply buildReply (SpecificReply sender tgt reply) = let (code, ps) = buildReply' reply- in GenericReply sender code tgt ps+ 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 $ Server $ grSender reply- , gmCommand = NumericCommand $ grCode reply+ { gmPrefix = Just $ PrefixServer $ grSender reply+ , gmCommand = NumericCmd $ grCode reply , gmParams = target' reply : grParams reply } where- target' (GenericReply { grTarget = NickTarget n }) = n- target' (GenericReply { grTarget = ServerTarget s }) = s+ target' (GenericReply { grTarget = NickTarget n }) = unNickname n+ target' (GenericReply { grTarget = ServerTarget s }) = unHostname s ------------------------------------------------------------------------------- -- Serializing ------------------------------------------------------------------------------- -serializePrefix :: Prefix -> String-serializePrefix (Server sn) = sn-serializePrefix (Nick n mu mh) = n- ++ maybe "" ('!' :) mu- ++ maybe "" (('@' :) . showHost) mh+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 -> String-serializeCommand (StringCommand s) = s-serializeCommand (NumericCommand n) = show n+serializeCommand :: Command -> Text+serializeCommand (NamedCmd t) = unCmdName t+serializeCommand (NumericCmd n) = showt $ unCmdNumber n -serializeParams :: [Parameter] -> String-serializeParams = f . map (\ p -> if null p then "(?)" else p)+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 concatMap (' ' :) ps ++ ' ' :- if head p == ':' || ' ' `elem` p- then ':' : p+ 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 -> String-serializeMessage msg = concat- [ maybe "" (\ p -> ':' : serializePrefix p ++ " ") $ gmPrefix msg+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"@@ -210,5 +304,5 @@ -- -- This is essentially a combination of 'messageFromReply' and -- 'serializeMessage'.-serializeReply :: GenericReply -> String+serializeReply :: GenericReply -> Text serializeReply = serializeMessage . messageFromReply
src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-messages. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -19,9 +19,11 @@ 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@@ -33,38 +35,49 @@ -} message :: Regex GenericMessage-message = GenericMessage <$> optional (sym ':' *> prefix <* space)- <*> command- <*> (fromMaybe [] <$> optional params)- <* crlf+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)+prefix =+ PrefixServer <$> 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)+ nick n Nothing = PrefixNick n Nothing Nothing+ nick n (Just (u, h)) = PrefixNick 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]+command =+ let f a b c = NumericCmd $ CmdNumber $ read [a, b, c]+ in NamedCmd . CmdName . pack <$> some letter+ <|>+ f <$> digit <*> digit <*> digit -params :: Regex [Parameter]-params = f <$> many (space *> middle)- <*> optional (space *> sym ':' *> trailing)- where- f m (Just t) = m ++ [t]- f m Nothing = m+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 Parameter-middle = (:) <$> paramchar <*> many (sym ':' <|> paramchar)+middle :: Regex Text+middle = pack <$> ((:) <$> paramchar <*> many (sym ':' <|> paramchar)) -trailing :: Regex Parameter-trailing = many $ sym ':' <|> sym ' ' <|> paramchar+trailing :: Regex Text+trailing = pack <$> many (sym ':' <|> sym ' ' <|> paramchar) paramchar :: Regex Char paramchar = psym (`notElem` "\0\r\n :")
src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs view
@@ -25,14 +25,18 @@ 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 = some $ psym (`notElem` "\0\r\n @")+user :: Regex Username+user = Username . pack <$> some (psym (`notElem` "\0\r\n @")) key :: Regex ChannelKey-key = some $ psym $ \ c -> isAscii c && c `notElem` "\0\r\n\f\t\v "+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'
src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs view
@@ -22,6 +22,7 @@ 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 -------------------------------------------------------------------------------@@ -31,10 +32,10 @@ chanpriv :: Regex ChannelPrivacy chanpriv = Secret <$ sym '@' <|> Private <$ sym '*' <|> Public <$ sym '=' -prefnicks :: Regex [(Privilege, NickName)]+prefnicks :: Regex [(Privilege, Nickname)] prefnicks = (:) <$> prefnick <*> many (sym ' ' *> prefnick) -prefnick :: Regex (Privilege, NickName)+prefnick :: Regex (Privilege, Nickname) prefnick = (,) <$> privilege <*> nickname privilege :: Regex Privilege
src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs view
@@ -25,9 +25,11 @@ where import Data.Char (isAsciiUpper)-import Network.IRC.Fun.Messages.Internal.Types+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@@ -49,27 +51,35 @@ <*> 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+ 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 (UserAddr u (Just h))) Nothing+ nuh n u h = UserTarget (Just n) (Just (UserAddress u (Just h))) Nothing -channel :: Regex ChannelName-channel = fmap snd $ withMatched $- (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <*- chanstring <*- optional (sym ':' <* chanstring)+channel :: Regex Channel+channel =+ Channel . pack . snd <$>+ withMatched+ ( (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <*+ chanstring <*+ optional (sym ':' <* chanstring)+ ) -servername :: Regex ServerName+servername :: Regex Hostname servername = hostname host :: Regex Host-host = HostAddr <$> hostaddr- <|> HostName <$> hostname- <|> HostCloak <$> hostcloak+host =+ HostByAddr <$> hostaddr+ <|>+ HostByName <$> hostname+ <|>+ HostCloak <$> hostcloak -hostname :: Regex String-hostname = snd <$> withMatched (shortname <* many (sym '.' <* shortname))+hostname :: Regex Hostname+hostname =+ Hostname . pack . snd <$>+ withMatched (shortname <* many (sym '.' <* shortname)) shortname :: Regex String shortname =@@ -81,15 +91,15 @@ hostaddr :: Regex Address hostaddr = IPv4 <$> ip4addr <|> IPv6 <$> ip6addr -ip4addr :: Regex String-ip4addr = snd <$> withMatched (s <* p <* s <* p <* s <* p <* s)+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 String-ip6addr = snd <$> withMatched (full <|> short <|> v4)+ip6addr :: Regex Text+ip6addr = pack . snd <$> withMatched (full <|> short <|> v4) where h = some hexdigit' c = sym ':'@@ -104,12 +114,17 @@ sym ':' <* ip4addr -hostcloak :: Regex String-hostcloak = some $ letter <|> digit <|> special <|> psym (`elem` ".-/")+hostcloak :: Regex Text+hostcloak =+ pack <$> some (letter <|> digit <|> special <|> psym (`elem` ".-/")) -nickname :: Regex NickName-nickname = (:) <$> (letter <|> special)- <*> many (letter <|> digit <|> special <|> sym '-')+nickname :: Regex Nickname+nickname =+ Nickname . pack <$>+ ( (:) <$>+ (letter <|> special) <*>+ many (letter <|> digit <|> special <|> sym '-')+ ) targetmask :: Regex TargetMask targetmask = ServerMask <$> (sym '$' *> mask)
src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs view
@@ -20,9 +20,8 @@ ) where -import Network.IRC.Fun.Messages.Internal.Types ( MaskPart (..)- , Mask (..)- , Regex )+import Network.IRC.Fun.Messages.Internal.Types+import Network.IRC.Fun.Types import Text.Regex.Applicative mask :: Regex Mask
src/Network/IRC/Fun/Messages/Internal/Types.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-messages. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -14,340 +14,22 @@ -} 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 (..)- , AnalysisError (..)- , ArgSpec (..)- -- * Modes- , UserMode (..)- , ChannelMode (..)- , ChannelModeType (..)+ ( -- * Type Aliases And Newtypes+ Regex -- * 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- { gmPrefix :: Maybe Prefix- , gmCommand :: Command- , gmParams :: [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 "<target> 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 <target> 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 ServerName)- | InviteMessage NickName ChannelName- | KickMessage [ChannelName] [UserName] (Maybe Comment)--- Sending messages- | PrivMsgMessage MessageTarget String- | PrivActionMessage MessageTarget String- | NoticeMessage MessageTarget String--- Server queries and commands- | MotdMessage (Maybe ServerName)- | 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 ------------------------------------------------------------------------------- @@ -563,11 +245,11 @@ -- | TODO | ErrorFileError -- | TODO- | ErrorNoNickNameGiven+ | ErrorNoNicknameGiven -- | TODO- | ErrorErroneousNickName+ | ErrorErroneousNickname -- | TODO- | ErrorNickNameInUse+ | ErrorNicknameInUse -- | TODO | ErrorNickCollision -- | TODO@@ -688,213 +370,3 @@ -- | TODO = ReservedErrorNoServiceHost deriving (Eq, Show)---- | TODO-data GenericReply = GenericReply- { grSender :: ServerName- , grCode :: Int- , grTarget :: Target- , grParams :: [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)-----data ArgSpec- = Exactly Int- | AtLeast Int- | AtMost Int- | Between Int Int- | OneOf [Int]- deriving (Show)-----data AnalysisError- = WrongNumArgs Int (Maybe ArgSpec)- | InvalidArg (Maybe Int) (Maybe String) (Maybe String)- | OtherError String- deriving (Show)
src/Network/IRC/Fun/Messages/Internal/Util.hs view
@@ -14,7 +14,8 @@ -} module Network.IRC.Fun.Messages.Internal.Util- ( listOf+ ( showt+ , listOf , req0 , req1 , req2@@ -30,8 +31,13 @@ ) 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)
src/Network/IRC/Fun/Messages/Mask.hs view
@@ -23,10 +23,13 @@ where import Data.Maybe (isJust)-import qualified Network.IRC.Fun.Messages.Internal.Tokens.Wildcards as T+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@@ -39,21 +42,21 @@ -- | 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+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 -> String -> String-serializeMaskPart (MaskChar '?') s = '\\' : '?' : s-serializeMaskPart (MaskChar '*') s = '\\' : '*' : s-serializeMaskPart (MaskChar c) s = c : s-serializeMaskPart (MaskWildOne) s = '?' : s-serializeMaskPart (MaskWildMany) s = '*' : s+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 -> String-serializeMask (Mask parts) = foldr serializeMaskPart "" parts+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
src/Network/IRC/Fun/Messages/Modes.hs view
@@ -29,10 +29,14 @@ 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')@@ -59,6 +63,7 @@ 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@@ -74,8 +79,8 @@ in (map umodeFromLetter remove', map umodeFromLetter add') -- the one from the MODE irc message-parseUserMode :: String -> Maybe ([UserMode], [UserMode])-parseUserMode = match umode+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...@@ -106,8 +111,12 @@ [ (CModeFreenodeQuiet Nothing, 'q', ModeTypeSetting) ] +lookupCLetter+ :: ChannelMode+ -> [(ChannelMode, Char, ChannelModeType)]+ -> Maybe Char lookupCLetter _ [] = Nothing-lookupCLetter q ((m, l, t):rest) =+lookupCLetter q ((m, l, _t):rest) = if q == m then Just l else lookupCLetter q rest@@ -124,8 +133,12 @@ (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, t):rest) = if c == l then Just m else lookupCMode c rest+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@@ -159,28 +172,28 @@ D -}-parseChannelModeParams :: [String]+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+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+ f t =+ case match section $ T.unpack t of Just sect -> Right sect- Nothing -> Left s+ 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) =+ _parts [] = Just []+ _parts (Left _ : _) = Nothing+ _parts (Right (sign, letters) : ss) = let (args, next) = break isRight ss- in case parts next of+ in case _parts next of Nothing -> Nothing Just pn -> Just $ (sign, letters, args) : pn -- Attach args to their modes by mode type
− src/Network/IRC/Fun/Messages/TypeAliases.hs
@@ -1,35 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}---- | 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
src/Network/IRC/Fun/Messages/Types.hs view
@@ -13,38 +13,14 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} --- | This module provides datatypes for modeling parts of IRC messages.+-- | 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- ( -- * Message Parts- Prefix (..)- , UserAddr (..)- , Target (..)- , Address (..)- , Host (..)- , Command (..)- -- * Mask- , MaskPart (..)- , Mask (..)- , TargetMask (..)- -- * Message- , GenericMessage (..)- , SpecificMessage (..)- , MessageTarget (..)- , Message (..)- -- * Modes- , UserMode (..)- , ChannelMode (..)- , ChannelModeType (..)- -- * Reply- , CommandResponseCode (..)+ ( CommandResponseCode (..) , ErrorReplyCode (..) , ReservedReplyCode (..) , ReservedErrorCode (..)- , GenericReply (..)- , Reply (..)- , SpecificReply (..)- , Privilege (..)- , ChannelPrivacy (..) ) where