~singpolyma/network-protocol-xmpp

ref: 3f30f380adb4c6eedf3c919590359c9746f5d8b3 network-protocol-xmpp/lib/Network/Protocol/XMPP/JID.hs -rw-r--r-- 3.4 KiB
3f30f380Stephen Paul Weber Call TLS.getBytes again on EAGAIN 2 years ago
                                                                                
6ac34f1c John Millikin
61061478 John Millikin
57a89320 John Millikin
61061478 John Millikin
490bb5f4 John Millikin
61061478 John Millikin
e17933b3 John Millikin
6ac34f1c John Millikin
1eb63b40 John Millikin
3666904f John Millikin
6ac34f1c John Millikin
61061478 John Millikin
77d1fb37 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
77d1fb37 John Millikin
61061478 John Millikin
be8bfc68 John Millikin
1eb63b40 John Millikin
1eb63b40 John Millikin
be8bfc68 John Millikin
1eb63b40 John Millikin
1eb63b40 John Millikin
f804d361 John Millikin
61061478 John Millikin
f804d361 John Millikin
77d1fb37 John Millikin
f804d361 John Millikin
3666904f John Millikin
1eb63b40 John Millikin
3666904f John Millikin
1eb63b40 John Millikin
490bb5f4 John Millikin
77d1fb37 John Millikin
61061478 John Millikin
77d1fb37 John Millikin
61061478 John Millikin
1eb63b40 John Millikin
61061478 John Millikin
be8bfc68 John Millikin
77d1fb37 John Millikin
be8bfc68 John Millikin
1eb63b40 John Millikin
be8bfc68 John Millikin
1eb63b40 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
116
117
118
{-# LANGUAGE CPP #-}

-- Copyright (C) 2010-2011 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 (..)
	, Node (..)
	, Domain (..)
	, Resource (..)

	, parseJID
	, parseJID_
	, formatJID
	) where

import           Data.Maybe (fromMaybe)
import qualified Data.Text
import           Data.Text (Text)
import qualified Data.Text.IDN.StringPrep as SP
import           Data.String (IsString, fromString)

newtype Node = Node { strNode :: Text }
newtype Domain = Domain { strDomain :: Text }
newtype Resource = Resource { strResource :: 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 :: Text -> Maybe JID
parseJID str = maybeJID where
	(node, postNode) = case textSpanBy (/= '@') str of
		(x, y) -> if Data.Text.null y
			then (Data.Text.empty, x)
			else (x, Data.Text.drop 1 y)
	(domain, resource) = case textSpanBy (/= '/') postNode of
		(x, y) -> if Data.Text.null y
			then (x, Data.Text.empty)
			else (x, Data.Text.drop 1 y)
	nullable x f = if Data.Text.null x
		then Just Nothing
		else fmap Just (f x)
	maybeJID = do
		preppedNode <- nullable node (stringprepM SP.xmppNode)
		preppedDomain <- stringprepM SP.nameprep domain
		preppedResource <- nullable resource (stringprepM SP.xmppResource)
		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_ :: Text -> JID
parseJID_ = fromMaybe (error "Malformed JID") . parseJID

formatJID :: JID -> Text
formatJID (JID node (Domain domain) resource) = formatted where
	formatted = Data.Text.concat [node', domain, resource']
	node' = maybe Data.Text.empty (\(Node x) -> Data.Text.snoc x '@') node
	resource' = maybe Data.Text.empty (\(Resource x) -> Data.Text.cons '/' 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) -> Text -> (Text, Text)
#if MIN_VERSION_text(0,11,0)
textSpanBy = Data.Text.span
#else
textSpanBy = Data.Text.spanBy
#endif