~singpolyma/network-protocol-xmpp

3666904f3afa8d139f8fd85f7ff65c3b999563ce — John Millikin 12 years ago 21fada2
Use GNU IDN instead of 'text-icu' for Stringprep support.
2 files changed, 16 insertions(+), 37 deletions(-)

M Network/Protocol/XMPP/JID.hs
M network-protocol-xmpp.cabal
M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +15 -35
@@ 25,9 25,7 @@ module Network.Protocol.XMPP.JID
	, formatJID
	) where
import qualified Data.Text as T
import qualified Text.StringPrep as SP
import Text.NamePrep (namePrepProfile)
import Data.Ranges (single)
import qualified Data.Text.IDN.StringPrep as SP
import Data.String (IsString, fromString)

newtype Node = Node { strNode :: T.Text }


@@ 47,13 45,13 @@ instance Show Resource where
		showString "Resource " . shows x

instance Eq Node where
	(==) = equaling (SP.runStringPrep nodePrep . strNode)
	(==) = equaling strNode

instance Eq Domain where
	(==) = equaling (SP.runStringPrep domainPrep . strDomain)
	(==) = equaling strDomain

instance Eq Resource where
	(==) = equaling (SP.runStringPrep resourcePrep . strResource)
	(==) = equaling strResource

data JID = JID
	{ jidNode :: Maybe Node


@@ 79,13 77,18 @@ parseJID str = maybeJID where
		(x, y) -> if T.null y
			then (x, "")
			else (x, T.drop 1 y)
	mNode = if T.null node then Nothing else Just (Node node)
	mResource = if T.null resource then Nothing else Just (Resource resource)
	nullable x f = if T.null x then Just Nothing else fmap Just $ f x
	maybeJID = do
		SP.runStringPrep nodePrep node
		SP.runStringPrep domainPrep domain
		SP.runStringPrep resourcePrep resource
		Just $ JID mNode (Domain domain) mResource
		preppedNode <- nullable node $ stringprepM SP.profileNodeprep
		preppedDomain <- stringprepM SP.profileNameprep domain
		preppedResource <- nullable resource $ stringprepM SP.profileResourceprep
		return $ JID
			(fmap Node preppedNode)
			(Domain preppedDomain)
			(fmap Resource preppedResource)
	stringprepM p x = case SP.stringprep p SP.defaultFlags x of
		Left _ -> Nothing
		Right y -> Just y

parseJID_ :: T.Text -> JID
parseJID_ text = case parseJID text of


@@ 98,29 101,6 @@ formatJID (JID node (Domain domain) resource) = formatted where
	node' = maybe "" (\(Node x) -> T.append x "@") node
	resource' = maybe "" (\(Resource x) -> T.append "/" x) resource

nodePrep :: SP.StringPrepProfile
nodePrep = SP.Profile
	{ SP.maps = [SP.b1, SP.b2]
	, SP.shouldNormalize = True
	, SP.prohibited = [ SP.c11, SP.c12, SP.c21, SP.c22
	                  , SP.c3, SP.c4, SP.c5, SP.c6, SP.c7, SP.c8, SP.c9
	                  , map single "\"&'/:<>@"
	                  ]
	, SP.shouldCheckBidi = True
	}

domainPrep :: SP.StringPrepProfile
domainPrep = namePrepProfile False

resourcePrep :: SP.StringPrepProfile
resourcePrep = SP.Profile
	{ SP.maps = [SP.b1]
	, SP.shouldNormalize = True
	, SP.prohibited = [ SP.c12, SP.c21, SP.c22
	                  , SP.c3, SP.c4, SP.c5, SP.c6, SP.c7, SP.c8, SP.c9]
	, SP.shouldCheckBidi = True
	}

-- Similar to 'comparing'
equaling :: Eq a => (b -> a) -> b -> b -> Bool
equaling f x y = f x == f y

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +1 -2
@@ 22,8 22,7 @@ library
  build-depends:
      base >=3 && < 5
    , text >= 0.7 && < 0.8
    , stringprep >= 0.1.2 && < 0.2
    , ranges >= 0.2.2 && < 0.3
    , gnuidn >= 0.1 && < 0.2
    , hxt >= 8.5 && < 8.6
    , gnutls >= 0.1 && < 0.3
    , bytestring >= 0.9 && < 0.10