~singpolyma/network-protocol-xmpp

179ec1609d4e67eb10678e77aa8bd07b4406578c — John Millikin 14 years ago 922f1a4
Add functions for retrieving parts of a JID as strings.
2 files changed, 90 insertions(+), 64 deletions(-)

M Network/Protocol/XMPP/JID.hs
M Tests/Core.hs
M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +42 -28
@@ 20,13 20,18 @@ module Network.Protocol.XMPP.JID (
	,JIDDomain
	,JIDResource
	
	,jidNodeBuild
	,jidNodeValue
	,jidDomainBuild
	,jidDomainValue
	,jidResourceBuild
	,jidResourceValue
	,jidBuild
	,jidNodeStr
	,jidDomainStr
	,jidResourceStr
	
	,mkJIDNode
	,mkJIDDomain
	,mkJIDResource
	,mkJID
	
	,jidNode
	,jidDomain
	,jidResource
	
	,jidParse
	,jidFormat


@@ 44,41 49,50 @@ newtype JIDDomain = JIDDomain String
newtype JIDResource = JIDResource String
	deriving (Eq, Show)

jidNodeBuild :: String -> Maybe JIDNode
jidNodeBuild "" = Nothing
jidNodeBuild s = Just (JIDNode s) -- TODO: stringprep, validation
jidNodeStr :: JIDNode -> String
jidNodeStr (JIDNode s) = s

jidNodeValue :: JIDNode -> String
jidNodeValue (JIDNode s) = s
jidDomainStr :: JIDDomain -> String
jidDomainStr (JIDDomain s) = s

jidDomainBuild :: String -> Maybe JIDDomain
jidDomainBuild "" = Nothing
jidDomainBuild s = Just (JIDDomain s) -- TODO: stringprep, validation
jidResourceStr :: JIDResource -> String
jidResourceStr (JIDResource s) = s

jidDomainValue :: JIDDomain -> String
jidDomainValue (JIDDomain s) = s
mkJIDNode :: String -> Maybe JIDNode
mkJIDNode "" = Nothing
mkJIDNode s = Just (JIDNode s) -- TODO: stringprep, validation

jidResourceBuild :: String -> Maybe JIDResource
jidResourceBuild "" = Nothing
jidResourceBuild s = Just (JIDResource s) -- TODO: stringprep, validation
mkJIDDomain :: String -> Maybe JIDDomain
mkJIDDomain "" = Nothing
mkJIDDomain s = Just (JIDDomain s) -- TODO: stringprep, validation

jidResourceValue :: JIDResource -> String
jidResourceValue (JIDResource s) = s
mkJIDResource :: String -> Maybe JIDResource
mkJIDResource "" = Nothing
mkJIDResource s = Just (JIDResource s) -- TODO: stringprep, validation

jidBuild :: String -> String -> String -> Maybe JID
jidBuild nodeStr domainStr resourceStr = let
	node = jidNodeBuild nodeStr
	resource = jidResourceBuild resourceStr
mkJID :: String -> String -> String -> Maybe JID
mkJID nodeStr domainStr resourceStr = let
	node = mkJIDNode nodeStr
	resource = mkJIDResource resourceStr
	in do
		domain <- jidDomainBuild domainStr
		domain <- mkJIDDomain domainStr
		Just (JID node domain resource)

jidNode :: JID -> String
jidNode (JID x _ _) = maybe "" jidNodeStr x

jidDomain :: JID -> String
jidDomain (JID _ x _) = jidDomainStr x

jidResource :: JID -> String
jidResource (JID _ _ x) = maybe "" jidResourceStr x

-- TODO: validate input according to RFC 3920, section 3.1
jidParse :: String -> Maybe JID
jidParse s = let
	(nodeStr, postNode) = if '@' `elem` s then split s '@' else ("", s)
	(domainStr, resourceStr) = if '/' `elem` postNode then split postNode '/' else (postNode, "")
	in jidBuild nodeStr domainStr resourceStr
	in mkJID nodeStr domainStr resourceStr

jidFormat :: JID -> String
jidFormat (JID node (JIDDomain domain) resource) = let

M Tests/Core.hs => Tests/Core.hs +48 -36
@@ 30,68 30,80 @@ jidTests = "jidTests" ~: TestList [
	,buildResourceTests
	,buildJIDTests
	,parseJIDTests
	,showJIDTests
	,formatJIDTests
	,jidPartTests
	]

buildNodeTests = "buildNodeTests" ~: TestList [
	-- TODO: stringprep, validation
	 testValue "" Nothing
	,testValue "a" (Just "a")
	 testStr "" Nothing
	,testStr "a" (Just "a")
	]
	where testValue s expected = let
		maybeNode = jidNodeBuild s
		value = maybe Nothing (\x -> Just (jidNodeValue x)) maybeNode
	where testStr s expected = let
		maybeNode = mkJIDNode s
		value = maybe Nothing (\x -> Just (jidNodeStr x)) maybeNode
		in expected ~=? value

buildDomainTests = "buildDomainTests" ~: TestList [
	-- TODO: stringprep, validation
	 testValue "" Nothing
	,testValue "a" (Just "a")
	 testStr "" Nothing
	,testStr "a" (Just "a")
	]
	where testValue s expected = let
		maybeDomain = jidDomainBuild s
		value = maybe Nothing (\x -> Just (jidDomainValue x)) maybeDomain
	where testStr s expected = let
		maybeDomain = mkJIDDomain s
		value = maybe Nothing (\x -> Just (jidDomainStr x)) maybeDomain
		in expected ~=? value

buildResourceTests = "buildResourceTests" ~: TestList [
	-- TODO: stringprep, validation
	 testValue "" Nothing
	,testValue "a" (Just "a")
	 testStr "" Nothing
	,testStr "a" (Just "a")
	]
	where testValue s expected = let
		maybeResource = jidResourceBuild s
		value = maybe Nothing (\x -> Just (jidResourceValue x)) maybeResource
	where testStr s expected = let
		maybeResource = mkJIDResource s
		value = maybe Nothing (\x -> Just (jidResourceStr x)) maybeResource
		in expected ~=? value

buildJIDTests = "buildJIDTests" ~: TestList [
	-- TODO: stringprep, validation of segments
	 jidBuild ""  ""  ""  ~?=  Nothing
	,jidBuild "a" ""  ""  ~?=  Nothing
	,jidBuild ""  "b" ""  ~?/= Nothing
	,jidBuild ""  ""  "c" ~?=  Nothing
	,jidBuild "a" "b" ""  ~?/= Nothing
	,jidBuild "a" ""  "c" ~?=  Nothing
	,jidBuild ""  "b" "c" ~?/= Nothing
	,jidBuild "a" "b" "c" ~?/= Nothing
	 mkJID ""  ""  ""  ~?=  Nothing
	,mkJID "a" ""  ""  ~?=  Nothing
	,mkJID ""  "b" ""  ~?/= Nothing
	,mkJID ""  ""  "c" ~?=  Nothing
	,mkJID "a" "b" ""  ~?/= Nothing
	,mkJID "a" ""  "c" ~?=  Nothing
	,mkJID ""  "b" "c" ~?/= Nothing
	,mkJID "a" "b" "c" ~?/= Nothing
	]

parseJIDTests = "parseJIDTests" ~: TestList [
	 testJIDParse "b" (jidBuild "" "b" "")
	,testJIDParse "a@b" (jidBuild "a" "b" "")
	,testJIDParse "b/c" (jidBuild "" "b" "c")
	,testJIDParse "a@b/c" (jidBuild "a" "b" "c")
	 testJIDParse "b" (mkJID "" "b" "")
	,testJIDParse "a@b" (mkJID "a" "b" "")
	,testJIDParse "b/c" (mkJID "" "b" "c")
	,testJIDParse "a@b/c" (mkJID "a" "b" "c")
	]
	where testJIDParse s expected = expected ~=? (jidParse s)

showJIDTests = "showJIDTests" ~: TestList [
	 testJIDShow (jidBuild "" "b" "") "b"
	,testJIDShow (jidBuild "a" "b" "") "a@b"
	,testJIDShow (jidBuild "" "b" "c") "b/c"
	,testJIDShow (jidBuild "a" "b" "c") "a@b/c"
formatJIDTests = "formatJIDTests" ~: TestList [
	 testJIDFormat (mkJID  "" "b"  "") "b"
	,testJIDFormat (mkJID "a" "b"  "") "a@b"
	,testJIDFormat (mkJID  "" "b" "c") "b/c"
	,testJIDFormat (mkJID "a" "b" "c") "a@b/c"
	]
	where testJIDShow maybeJID expected = TestCase (case maybeJID of
		Nothing -> assertFailure "jidBuild returned Nothing"
		(Just jid) -> expected @=? (show jid))
	where testJIDFormat maybeJID expected = TestCase $ case maybeJID of
		Nothing -> assertFailure "mkJID returned Nothing"
		(Just jid) -> expected @=? (jidFormat jid)

jidPartTests = "jidPartTests" ~: TestList [
	 testJIDPart (mkJID  "" "b"  "") jidNode ""
	,testJIDPart (mkJID "a" "b"  "") jidNode "a"
	,testJIDPart (mkJID  "" "b"  "") jidDomain "b"
	,testJIDPart (mkJID  "" "b"  "") jidResource ""
	,testJIDPart (mkJID  "" "b" "c") jidResource "c"
	]
	where testJIDPart maybeJID f expected = TestCase $ case maybeJID of
		Nothing -> assertFailure "mkJID returned Nothing"
		(Just jid) -> expected @=? (f jid)

-------------------------------------------------------------------------------