From 113ca4034fca122d0a0a9b48dec77cb9913ff1a3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 19:28:01 +0200 Subject: [PATCH] work in JID.hs --- src/Network/XMPP/JID.hs | 232 ++++++++++++++++------------------------ 1 file changed, 93 insertions(+), 139 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 2076f94..5b6f1fd 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -15,183 +15,137 @@ -- -- 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 Control.Applicative ((<$>),(<|>)) +import Control.Monad(guard) -import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, - c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Text.NamePrep (namePrepProfile) +import qualified Data.Attoparsec.Text as AP +import Data.Text (Text) +import qualified Data.Text as Text -import Network.URI (isIPv4address, isIPv6address) - -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Text as DT (pack, unpack) +-- import Network.URI (isIPv4address, isIPv6address) +import Network.XMPP.Types +import qualified Text.NamePrep as SP +import qualified Text.StringPrep as SP -- | -- Converts a string to a JID. - fromString :: String -> Maybe JID - -fromString s = fromStrings localpart domainpart resourcepart +fromString s = fromStrings l d r where - Right (localpart, domainpart, resourcepart) = - parse jidParts "" (DBC.pack s) - + Right (l, d, r) = + AP.parseOnly jidParts (Text.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 +fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID +fromStrings l d r = do + localPart <- case l of + Nothing -> return Nothing + Just l'-> do + l'' <- SP.runStringPrep nodeprepProfile l' + guard $ validPartLength l'' + return $ Just l'' + domainPart <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart + resourcePart <- case r of + Nothing -> return Nothing + Just r' -> do + r'' <- SP.runStringPrep resourceprepProfile r' + guard $ validPartLength r'' + return $ Just r'' + return $ JID localPart domainPart resourcePart 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 + validDomainPart _s = True -- TODO + -- isIPv4address s || isIPv6address s || validHostname s + validPartLength :: Text -> Bool + validPartLength p = Text.length p > 0 && Text.length p < 1024 -- Validates a host name - validHostname :: String -> Bool - validHostname _ = True -- TODO - + -- validHostname :: Text -> 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 :: AP.Parser (Maybe Text, Text, Maybe Text) 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 } - + a <- firstPartP + b <- Just <$> domainPartP <|> (return Nothing) + c <- Just <$> resourcePartP <|> (return Nothing) + case (a,b,c) of + -- Whether or not we have a resource part, if there is no "@" + -- x is the domain + (x, Nothing, z) -> return (Nothing, x, z) + -- When we do have an "@", x is the localpart + (x, Just y, z) -> return (Just x, y, z) + where + firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + resourcePartP = do + _ <- AP.char '/' + AP.takeText + + +nodeprepProfile :: SP.StringPrepProfile +nodeprepProfile = SP.Profile + { SP.maps = [SP.b1, SP.b2] + , SP.shouldNormalize = True + , SP.prohibited = [SP.a1 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + ] + , SP.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 :: [Char] 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 } +resourceprepProfile :: SP.StringPrepProfile +resourceprepProfile = SP.Profile + { SP.maps = [SP.b1] + , SP.shouldNormalize = True + , SP.prohibited = [ SP.a1 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + , SP.c12 + , SP.c21 + , SP.c22 + ] + , SP.shouldCheckBidi = True + }