~singpolyma/network-protocol-xmpp

61061478f5ec964dc8160d2317ee1bd6599f8d88 — John Millikin 12 years ago aa56e05
Started major refactoring effort, starting with proper stringprep support in JID.
4 files changed, 130 insertions(+), 267 deletions(-)

M Network/Protocol/XMPP/JID.hs
D Tests.hs
D Tests/Core.hs
M network-protocol-xmpp.cabal
M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +117 -108
@@ 1,111 1,120 @@
{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
   
   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Network.Protocol.XMPP.JID (
	 JID(..)
	,JIDNode
	,JIDDomain
	,JIDResource
-- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.JID
	( JID (..)
	, Node
	, Domain
	, Resource
	
	,jidNodeStr
	,jidDomainStr
	,jidResourceStr
	, strNode
	, strDomain
	, strResource
	
	,mkJIDNode
	,mkJIDDomain
	,mkJIDResource
	,mkJID
	
	,jidNode
	,jidDomain
	,jidResource
	
	,jidParse
	,jidFormat
	, parseJID
	, formatJID
	) where

data JID = JID (Maybe JIDNode) JIDDomain (Maybe JIDResource)
	deriving (Eq, Show)

newtype JIDNode = JIDNode String
	deriving (Eq, Show)
	
newtype JIDDomain = JIDDomain String
	deriving (Eq, Show)
	
newtype JIDResource = JIDResource String
	deriving (Eq, Show)

jidNodeStr :: JIDNode -> String
jidNodeStr (JIDNode s) = s

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

jidResourceStr :: JIDResource -> String
jidResourceStr (JIDResource s) = s

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

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

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

mkJID :: String -> String -> String -> Maybe JID
mkJID nodeStr domainStr resourceStr = let
	node = mkJIDNode nodeStr
	resource = mkJIDResource resourceStr
	in do
		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 mkJID nodeStr domainStr resourceStr

jidFormat :: JID -> String
jidFormat (JID node (JIDDomain domain) resource) = let
	nodeStr = maybe "" (\(JIDNode s) -> s ++ "@") node
	resourceStr = maybe "" (\(JIDResource s) -> "/" ++ s) resource
	in concat [nodeStr, domain, resourceStr]

split :: (Eq a) => [a] -> a -> ([a], [a])
split xs final = let
	(before, rawAfter) = span (/= final) xs
	after = safeTail rawAfter
	in (before, after)

safeTail :: [a] -> [a]
safeTail [] = []
safeTail (_:xs) = xs
import qualified Data.Text as T
import qualified Text.StringPrep as SP
import Text.NamePrep (namePrepProfile)
import Data.Ranges (single)

newtype Node = Node { strNode :: T.Text }
newtype Domain = Domain { strDomain :: T.Text }
newtype Resource = Resource { strResource :: T.Text }

instance Show Node where
	showsPrec d (Node x) = showParen (d > 10) $
		showString "Node " . shows x

instance Show Domain where
	showsPrec d (Domain x) = showParen (d > 10) $
		showString "Domain " . shows x

instance Show Resource where
	showsPrec d (Resource x) = showParen (d > 10) $
		showString "Resource " . shows x

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

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

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

data JID = JID
	{ jidNode :: Maybe Node
	, jidDomain :: Domain
	, jidResource :: Maybe Resource
	}
	deriving (Eq)

instance Show JID where
	showsPrec d jid =  showParen (d > 10) $
		showString "JID " . shows (formatJID jid)

parseJID :: T.Text -> Maybe JID
parseJID str = maybeJID where
	(node, postNode) = case T.spanBy (/= '@') str of
		(x, y) -> if T.null y
			then ("", x)
			else (x, T.drop 1 y)
	(domain, resource) = case T.spanBy (/= '/') postNode of
		(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)
	maybeJID = do
		SP.runStringPrep nodePrep node
		SP.runStringPrep domainPrep domain
		SP.runStringPrep resourcePrep resource
		Just $ JID mNode (Domain domain) mResource

formatJID :: JID -> T.Text
formatJID (JID node (Domain domain) resource) = formatted where
	formatted = T.concat [node', domain, resource']
	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

D Tests.hs => Tests.hs +0 -25
@@ 1,25 0,0 @@
{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
   
   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Main () where

import Test.HUnit
import Tests.Core (coreTests)

allTests = "allTests" ~: TestList [coreTests]

main = do
	runTestTT allTests

D Tests/Core.hs => Tests/Core.hs +0 -126
@@ 1,126 0,0 @@
{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
   
   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Tests.Core (coreTests) where

import Control.Monad (unless)
import Test.HUnit
import Network.Protocol.XMPP

coreTests = "coreTests" ~: TestList [jidTests]

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

jidTests = "jidTests" ~: TestList [
	 buildNodeTests
	,buildDomainTests
	,buildResourceTests
	,buildJIDTests
	,parseJIDTests
	,formatJIDTests
	,jidPartTests
	]

buildNodeTests = "buildNodeTests" ~: TestList [
	-- TODO: stringprep, validation
	 testStr "" Nothing
	,testStr "a" (Just "a")
	]
	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
	 testStr "" Nothing
	,testStr "a" (Just "a")
	]
	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
	 testStr "" Nothing
	,testStr "a" (Just "a")
	]
	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
	 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" (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)

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 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)

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

assertNotEqual :: (Eq a, Show a) => String -> a -> a -> Assertion
assertNotEqual preface unexpected actual =
	unless (actual /= unexpected) (assertFailure msg)
	where msg = (if null preface then "" else preface ++ "\n") ++
	            "got unexpected: " ++ show actual

(@/=?) :: (Eq a, Show a) => a -> a -> Assertion
unexpected @/=? actual = assertNotEqual "" unexpected actual

(@?/=) :: (Eq a, Show a) => a -> a -> Assertion
actual @?/= unexpected = assertNotEqual "" unexpected actual

(~/=?) :: (Eq a, Show a) => a -> a -> Test
unexpected ~/=? actual = TestCase (unexpected @/=? actual)

(~?/=) :: (Eq a, Show a) => a -> a -> Test
actual ~?/= unexpected = TestCase (actual @?/= unexpected)

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +13 -8
@@ 14,15 14,20 @@ bug-reports: mailto:jmillikin@gmail.com

source-repository head
  type: darcs
  location: http://patch-tag.com/r/jmillikin/network-protocol-xmpp/pullrepo
  location: http://ianen.org/haskell/xmpp/

library
  build-depends: base >=3 && < 5, hxt, libxml-sax >= 0.2, hsgnutls, gsasl, network, bytestring, SHA
  build-depends:
      base >=3 && < 5
    , text
    , stringprep
    , ranges

  exposed-modules:
    Network.Protocol.XMPP
    Network.Protocol.XMPP.Client
    -- Network.Protocol.XMPP
    -- Network.Protocol.XMPP.Client
    Network.Protocol.XMPP.JID
    Network.Protocol.XMPP.SASL
    Network.Protocol.XMPP.Stanzas
    Network.Protocol.XMPP.Stream
    Network.Protocol.XMPP.Util
    -- Network.Protocol.XMPP.SASL
    -- Network.Protocol.XMPP.Stanzas
    -- Network.Protocol.XMPP.Stream
    -- Network.Protocol.XMPP.Util