diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -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) diff --git a/NEWS.md b/NEWS.md new file mode 100644 --- /dev/null +++ b/NEWS.md @@ -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) diff --git a/irc-fun-messages.cabal b/irc-fun-messages.cabal --- a/irc-fun-messages.cabal +++ b/irc-fun-messages.cabal @@ -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 diff --git a/src/Network/IRC/Fun/Messages/Internal/Parse.hs b/src/Network/IRC/Fun/Messages/Internal/Parse.hs --- a/src/Network/IRC/Fun/Messages/Internal/Parse.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Parse.hs @@ -13,6 +13,8 @@ - . -} +{-# 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 diff --git a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs --- a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs @@ -13,6 +13,8 @@ - . -} +{-# 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 diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-messages. - - - Written in 2015 by fr33domlover . + - Written in 2015 by fr33domlover . - - ♡ 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 :") diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs @@ -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' diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs @@ -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 diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs @@ -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) diff --git a/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs b/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs --- a/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs @@ -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 diff --git a/src/Network/IRC/Fun/Messages/Internal/Types.hs b/src/Network/IRC/Fun/Messages/Internal/Types.hs --- a/src/Network/IRC/Fun/Messages/Internal/Types.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Types.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-messages. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 " 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 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) diff --git a/src/Network/IRC/Fun/Messages/Internal/Util.hs b/src/Network/IRC/Fun/Messages/Internal/Util.hs --- a/src/Network/IRC/Fun/Messages/Internal/Util.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Util.hs @@ -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) diff --git a/src/Network/IRC/Fun/Messages/Mask.hs b/src/Network/IRC/Fun/Messages/Mask.hs --- a/src/Network/IRC/Fun/Messages/Mask.hs +++ b/src/Network/IRC/Fun/Messages/Mask.hs @@ -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 diff --git a/src/Network/IRC/Fun/Messages/Modes.hs b/src/Network/IRC/Fun/Messages/Modes.hs --- a/src/Network/IRC/Fun/Messages/Modes.hs +++ b/src/Network/IRC/Fun/Messages/Modes.hs @@ -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 diff --git a/src/Network/IRC/Fun/Messages/TypeAliases.hs b/src/Network/IRC/Fun/Messages/TypeAliases.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Messages/TypeAliases.hs +++ /dev/null @@ -1,35 +0,0 @@ -{- This file is part of irc-fun-messages. - - - - Written in 2015 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - --- | This module 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 --- a/src/Network/IRC/Fun/Messages/Types.hs +++ b/src/Network/IRC/Fun/Messages/Types.hs @@ -13,38 +13,14 @@ - . -} --- | 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