From 000ab2da34535bcf4dd722c3aaad884b1e4ecff7 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 18 Apr 2012 01:02:13 +0200 Subject: [PATCH 1/2] renamed Address to JID; reformatted module --- src/Network/XMPP/Address.hs | 189 ---------------------------------- src/Network/XMPP/JID.hs | 197 ++++++++++++++++++++++++++++++++++++ 2 files changed, 197 insertions(+), 189 deletions(-) delete mode 100644 src/Network/XMPP/Address.hs create mode 100644 src/Network/XMPP/JID.hs diff --git a/src/Network/XMPP/Address.hs b/src/Network/XMPP/Address.hs deleted file mode 100644 index 1657171..0000000 --- a/src/Network/XMPP/Address.hs +++ /dev/null @@ -1,189 +0,0 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - --- TODO: When no longer using stringprep, do appropriate testing. (Including --- testing addresses like a@b/c@d/e, a/b@c, a@/b, a/@b...) - --- TODO: Unicode 3.2 should be used. - - --- This module deals with XMPP addresses (also known as JIDs and JabberIDs). For --- more information on XMPP addresses, see RFC 6122: XMPP: Address Format. --- --- This module does not internationalize hostnames. - - -module Network.XMPP.Address (fromString, fromStrings, isBare, isFull) where - -import Network.XMPP.Types - -import Data.Maybe (fromJust, isJust) -import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse) -import Text.Parsec.ByteString (GenParser) - -import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, - c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Text.NamePrep (namePrepProfile) - -import Network.URI (isIPv4address, isIPv6address) - -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Text as DT (pack, unpack) - - --- | --- Converts a string to an XMPP address. - -fromString :: String -> Maybe Address - -fromString s = fromStrings localpart domainpart resourcepart - where - Right (localpart, domainpart, resourcepart) = - parse addressParts "" (DBC.pack s) - - --- | --- Converts localpart, domainpart, and resourcepart strings to an XMPP address. - --- Runs the appropriate stringprep profiles and validates the parts. - -fromStrings :: Maybe String -> String -> Maybe String -> Maybe Address - -fromStrings l s r - | domainpart == Nothing = Nothing - | otherwise = if validateNonDomainpart localpart && - isJust domainpart' && - validateNonDomainpart resourcepart - then Just (Address localpart (fromJust domainpart') resourcepart) - else Nothing - where - - -- Applies the nodeprep profile on the localpart string, if any. - localpart :: Maybe String - localpart = case l of - Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of - Just l'' -> Just $ DT.unpack l'' - Nothing -> Nothing - Nothing -> Nothing - - -- Applies the nameprep profile on the domainpart string. - -- TODO: Allow unassigned? - domainpart :: Maybe String - domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of - Just s' -> Just $ DT.unpack s' - Nothing -> Nothing - - -- Applies the resourceprep profile on the resourcepart string, if any. - resourcepart :: Maybe String - resourcepart = case r of - Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of - Just r'' -> Just $ DT.unpack r'' - Nothing -> Nothing - Nothing -> Nothing - - -- Returns the domainpart if it was a valid IP or if the toASCII - -- function was successful, or Nothing otherwise. - domainpart' :: Maybe String - domainpart' | isIPv4address s || isIPv6address s = Just s - | validHostname s = Just s - | otherwise = Nothing - - -- Validates that non-domainpart strings have an appropriate length. - validateNonDomainpart :: Maybe String -> Bool - validateNonDomainpart Nothing = True - validateNonDomainpart (Just l) = validPartLength l - where - validPartLength :: String -> Bool - validPartLength p = length p > 0 && length p < 1024 - - -- Validates a host name - validHostname :: String -> Bool - validHostname _ = True -- TODO - - --- | Returns True if the address is `bare', and False otherwise. - -isBare :: Address -> Bool - -isBare j | resourcepart j == Nothing = True - | otherwise = False - - --- | Returns True if the address is `full', and False otherwise. - -isFull :: Address -> Bool - -isFull jid = not $ isBare jid - - --- Parses an address string and returns its three parts. It performs no --- validation or transformations. We are using Parsec to parse the address. --- There is no input for which 'addressParts' fails. - -addressParts :: GenParser Char st (Maybe String, String, Maybe String) - -addressParts = do - - -- Read until we reach an '@', a '/', or EOF. - a <- many $ noneOf ['@', '/'] - - -- Case 1: We found an '@', and thus the localpart. At least the domainpart - -- is remaining. Read the '@' and until a '/' or EOF. - do - char '@' - b <- many $ noneOf ['/'] - - -- Case 1A: We found a '/' and thus have all the address parts. Read the - -- '/' and until EOF. - do - char '/' -- Resourcepart remaining - c <- many $ anyToken -- Parse resourcepart - eof - return (Just a, b, Just c) - - -- Case 1B: We have reached EOF; the address is in the form - -- localpart@domainpart. - <|> do - eof - return (Just a, b, Nothing) - - -- Case 2: We found a '/'; the address is in the form - -- domainpart/resourcepart. - <|> do - char '/' - b <- many $ anyToken - eof - return (Nothing, a, Just b) - - -- Case 3: We have reached EOF; we have an address consisting of only a - -- domainpart. - <|> do - eof - return (Nothing, a, Nothing) - - -nodeprepProfile :: StringPrepProfile - -nodeprepProfile = Profile { maps = [b1, b2] - , shouldNormalize = True - , prohibited = [a1] ++ [c11, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] - , shouldCheckBidi = True } - - --- These needs to be checked for after normalization. We could also look up the --- Unicode mappings and include a list of characters in the prohibited field --- above. Let's defer that until we know that we are going to use stringprep. - -nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', - '\x3C', '\x3E', '\x40'] - - - -resourceprepProfile :: StringPrepProfile - -resourceprepProfile = Profile { maps = [b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] - , shouldCheckBidi = True } diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs new file mode 100644 index 0000000..2076f94 --- /dev/null +++ b/src/Network/XMPP/JID.hs @@ -0,0 +1,197 @@ +-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the +-- Pontarius distribution for more details. + +{-# OPTIONS_HADDOCK hide #-} + +-- TODO: When no longer using stringprep, do appropriate testing. +-- (Including testing addresses like a@b/c@d/e, a/b@c, a@/b, a/@b...) +-- Will we not be using stringprep? + +-- TODO: Unicode 3.2 should be used. + + +-- This module deals with XMPP addresses, also known as JIDs. For more +-- information on JIDs, see RFC 6122: XMPP: Address Format. +-- +-- This module does not internationalize hostnames. + + +module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where + +import Network.XMPP.Types + +import Data.Maybe (fromJust, isJust) +import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse) +import Text.Parsec.ByteString (GenParser) + +import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, + c3, c4, c5, c6, c7, c8, c9, runStringPrep) +import Text.NamePrep (namePrepProfile) + +import Network.URI (isIPv4address, isIPv6address) + +import qualified Data.ByteString.Char8 as DBC (pack) +import qualified Data.Text as DT (pack, unpack) + + +-- | +-- Converts a string to a JID. + +fromString :: String -> Maybe JID + +fromString s = fromStrings localpart domainpart resourcepart + where + Right (localpart, domainpart, resourcepart) = + parse jidParts "" (DBC.pack s) + + +-- | +-- Converts localpart, domainpart, and resourcepart strings to a JID. + +-- Runs the appropriate stringprep profiles and validates the parts. + +fromStrings :: Maybe String -> String -> Maybe String -> Maybe JID + +fromStrings l s r + | domainpart == Nothing = Nothing + | otherwise = if validateNonDomainpart localpart && + isJust domainpart' && + validateNonDomainpart resourcepart + then Just (JID localpart (fromJust domainpart') resourcepart) + else Nothing + where + + -- Applies the nodeprep profile on the localpart string, if any. + localpart :: Maybe String + localpart = case l of + Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of + Just l'' -> Just $ DT.unpack l'' + Nothing -> Nothing + Nothing -> Nothing + + -- Applies the nameprep profile on the domainpart string. + -- TODO: Allow unassigned? + domainpart :: Maybe String + domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of + Just s' -> Just $ DT.unpack s' + Nothing -> Nothing + + -- Applies the resourceprep profile on the resourcepart string, if + -- any. + resourcepart :: Maybe String + resourcepart = case r of + Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of + Just r'' -> Just $ DT.unpack r'' + Nothing -> Nothing + Nothing -> Nothing + + -- Returns the domainpart if it was a valid IP or if the toASCII + -- function was successful, or Nothing otherwise. + domainpart' :: Maybe String + domainpart' | isIPv4address s || isIPv6address s = Just s + | validHostname s = Just s + | otherwise = Nothing + + -- Validates that non-domainpart strings have an appropriate + -- length. + validateNonDomainpart :: Maybe String -> Bool + validateNonDomainpart Nothing = True + validateNonDomainpart (Just l) = validPartLength l + where + validPartLength :: String -> Bool + validPartLength p = length p > 0 && length p < 1024 + + -- Validates a host name + validHostname :: String -> Bool + validHostname _ = True -- TODO + + +-- | Returns True if the JID is `bare', and False otherwise. + +isBare :: JID -> Bool + +isBare j | resourcepart j == Nothing = True + | otherwise = False + + +-- | Returns True if the JID is `full', and False otherwise. + +isFull :: JID -> Bool + +isFull jid = not $ isBare jid + + +-- Parses an JID string and returns its three parts. It performs no +-- validation or transformations. We are using Parsec to parse the +-- JIDs. There is no input for which 'jidParts' fails. + +jidParts :: GenParser Char st (Maybe String, String, Maybe String) + +jidParts = do + + -- Read until we reach an '@', a '/', or EOF. + a <- many $ noneOf ['@', '/'] + + -- Case 1: We found an '@', and thus the localpart. At least the + -- domainpart is remaining. Read the '@' and until a '/' or EOF. + do + char '@' + b <- many $ noneOf ['/'] + + -- Case 1A: We found a '/' and thus have all the JID parts. Read + -- the '/' and until EOF. + do + char '/' -- Resourcepart remaining + c <- many $ anyToken -- Parse resourcepart + eof + return (Just a, b, Just c) + + -- Case 1B: We have reached EOF; the JID is in the form + -- localpart@domainpart. + <|> do + eof + return (Just a, b, Nothing) + + -- Case 2: We found a '/'; the JID is in the form + -- domainpart/resourcepart. + <|> do + char '/' + b <- many $ anyToken + eof + return (Nothing, a, Just b) + + -- Case 3: We have reached EOF; we have an JID consisting of only + -- a domainpart. + <|> do + eof + return (Nothing, a, Nothing) + + +nodeprepProfile :: StringPrepProfile + +nodeprepProfile = Profile { maps = [b1, b2] + , shouldNormalize = True + , prohibited = [a1] ++ [c11, c12, c21, c22, + c3, c4, c5, c6, c7, + c8, c9] + , shouldCheckBidi = True } + + +-- These needs to be checked for after normalization. We could also +-- look up the Unicode mappings and include a list of characters in +-- the prohibited field above. Let's defer that until we know that we +-- are going to use stringprep. + +nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', + '\x3A', '\x3C', '\x3E', '\x40'] + + + +resourceprepProfile :: StringPrepProfile + +resourceprepProfile = Profile { maps = [b1] + , shouldNormalize = True + , prohibited = [a1] ++ [c12, c21, c22, + c3, c4, c5, c6, + c7, c8, c9] + , shouldCheckBidi = True } From 0cfad3e2ea3415aefd3e4cb468f40a2208bf6d80 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 18 Apr 2012 01:05:44 +0200 Subject: [PATCH 2/2] some comments --- src/Network/XMPP/Bind.hs | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 4ea7b3f..0666f38 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- TODO: Allow the client to retry the bind with another resource + module Network.XMPP.Bind where import Data.Text as Text @@ -11,24 +13,36 @@ import Network.XMPP.Types import Network.XMPP.Pickle import Network.XMPP.Concurrent + +-- A `bind' element. + bindP :: PU [Node] b -> PU [Node] b bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c + +-- If the (optional resource) parameter is a `Just' value, a +-- `resource' child element will be added to the `bind' element. + bindBody :: Maybe Text -> Element bindBody rsrc = (pickleElem (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) rsrc ) + +-- Extracts the character data in the `jid' element. + jidP :: PU [Node] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) + +-- Sends a (synchronous) IQ set request for a (`Just') given or +-- server-generated resource and extract the JID from the non-error +-- response. + xmppThreadedBind :: Maybe Text -> XMPPThread Text xmppThreadedBind rsrc = do answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling let (JID _n _d (Just r)) = unpickleElem jidP b - return r - - - + return r \ No newline at end of file