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