~singpolyma/network-protocol-xmpp

ref: be8bfc68f7cf15775b19f5cae7ab4dda5a13e04b network-protocol-xmpp/Network/Protocol/XMPP/JID.hs -rw-r--r-- 3.3 KiB
be8bfc68 — John Millikin Support text-0.11 13 years ago
                                                                                
3b50a3b3 John Millikin
61061478 John Millikin
be8bfc68 John Millikin
61061478 John Millikin
57a89320 John Millikin
179ec160 John Millikin
61061478 John Millikin
490bb5f4 John Millikin
61061478 John Millikin
e17933b3 John Millikin
99f5f447 John Millikin
3666904f John Millikin
490bb5f4 John Millikin
61061478 John Millikin
3666904f John Millikin
61061478 John Millikin
3666904f John Millikin
61061478 John Millikin
3666904f John Millikin
61061478 John Millikin
490bb5f4 John Millikin
61061478 John Millikin
be8bfc68 John Millikin
61061478 John Millikin
be8bfc68 John Millikin
61061478 John Millikin
8150ebe0 John Millikin
3666904f John Millikin
61061478 John Millikin
3666904f John Millikin
490bb5f4 John Millikin
61061478 John Millikin
be8bfc68 John Millikin
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
-- Copyright (C) 2010 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 #-}
{-# LANGUAGE CPP #-}
module Network.Protocol.XMPP.JID
	( JID (..)
	, Node (..)
	, Domain (..)
	, Resource (..)
	
	, parseJID
	, parseJID_
	, formatJID
	) where
import qualified Data.Text.Lazy as T
import qualified Data.Text.IDN.StringPrep as SP
import Data.String (IsString, fromString)

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 strNode

instance Eq Domain where
	(==) = equaling strDomain

instance Eq Resource where
	(==) = equaling 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)

instance IsString JID where
	fromString = parseJID_ . fromString

parseJID :: T.Text -> Maybe JID
parseJID str = maybeJID where
	(node, postNode) = case textSpanBy (/= '@') str of
		(x, y) -> if T.null y
			then ("", x)
			else (x, T.drop 1 y)
	(domain, resource) = case textSpanBy (/= '/') postNode of
		(x, y) -> if T.null y
			then (x, "")
			else (x, T.drop 1 y)
	nullable x f = if T.null x then Just Nothing else fmap Just $ f x
	maybeJID = do
		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
	Just jid -> jid
	Nothing -> error "Malformed JID"

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

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

-- multi-version 'text' compatibility
textSpanBy :: (Char -> Bool) -> T.Text -> (T.Text, T.Text)
#if MIN_VERSION_text(0,11,0)
textSpanBy = T.span
#else
textSpanBy = T.spanBy
#endif