~singpolyma/network-protocol-xmpp

ref: 6304bac23fa472e34a44f9ee8b807ed769c94487 network-protocol-xmpp/lib/Network/Protocol/XMPP/JID.hs -rw-r--r-- 3.4 KiB
6304bac2 — John Millikin Clean up Cabal file. 10 years ago
                                                                                
6ac34f1c John Millikin
61061478 John Millikin
57a89320 John Millikin
179ec160 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
61061478 John Millikin
1eb63b40 John Millikin
be8bfc68 John Millikin
1eb63b40 John Millikin
61061478 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
490bb5f4 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
119
120
{-# LANGUAGE OverloadedStrings #-}
{-# 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 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 ("", x)
			else (x, Data.Text.drop 1 y)
	(domain, resource) = case textSpanBy (/= '/') postNode of
		(x, y) -> if Data.Text.null y
			then (x, "")
			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_ text = case parseJID text of
	Just jid -> jid
	Nothing -> error "Malformed JID"

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