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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
(** An XMPP JID. If there is no localpart or resourcepart, they're [None]. *)
type t = {
localpart : string option;
domainpart : string;
resourcepart : string option;
}
(** Valid JID are all UTF8 code points, so an invalid JID will raise [InvalidUTF8]. *)
exception InvalidUTF8
(** A list of UTF8 code points, associated with their respective position. *)
type uchars = (Uchar.t * int) list
(** [uchars_of_string s] is an [uchars] of the UTF8 characters of the string [s].
If an invalid UTF8 character, the functions raises an [InvalidUTF8] exception. *)
let uchars_of_string s : uchars =
let open Uchar in
let len = String.length s in
let rec loop acc i =
if i >= len then
List.rev acc
else
let c = String.get_utf_8_uchar s i in
if not (utf_decode_is_valid c)
then raise InvalidUTF8
else
let k = utf_decode_length c in
let u = utf_decode_uchar c in
loop ((u, i) :: acc) (i + k)
in loop [] 0
(** Convert a [string] to a [Jid.t].
This function traverses the JID until an '/' char (or the end of the string) occurs.
Anything before is the "bare" JID, and anything eventually after is the resource.
Then, the function goes backward until an '@' char (or the start of the string)
occurs.
Anything after is the domain, and anything eventually before is the localpart
(username). *)
let of_string (jid : string) : t =
let open List in
let open String in
let u_jid = uchars_of_string jid in
let u_barejid, domain_end =
find_mapi (fun u_i (c, i) ->
if c = Uchar.of_char '/'
then Some (u_i, i)
else None) u_jid
|> Option.fold ~none:(u_jid, None) ~some:(fun (u_i, i) -> take u_i u_jid, Some i)
in
let domain_begin =
rev u_barejid
|> find_map (fun (c, i) ->
if c = Uchar.of_char '@'
then Some (i+1)
else None)
in
let open Option in {
localpart = map (fun i -> sub jid 0 (i - 1)) domain_begin;
domainpart =
begin
let b = (value ~default:0 domain_begin) in
sub jid b ((value ~default:(length jid) domain_end) - b)
end;
resourcepart = map (fun i -> sub jid (i + 1) (length jid - i - 1)) domain_end;
}
let show ({ localpart; domainpart; resourcepart } : t) =
let show_opt = Option.fold ~none:"None" ~some:(Format.sprintf {|Some "%s"|})
in Printf.sprintf
{|{ localpart = %s;
domainpart = "%s";
resourcepart = %s }|}
(show_opt localpart) domainpart (show_opt resourcepart)
(* RFC7622 3.5 examples *)
let%expect_test {|A "bare JID"|} =
"juliet@example.com" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "juliet";
domainpart = "example.com";
resourcepart = None } |}]
let%expect_test {|A "full JID"|} =
"juliet@example.com/foo" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "juliet";
domainpart = "example.com";
resourcepart = Some "foo" } |}]
let%expect_test {|Single space in resourcepart|} =
"juliet@example.com/foo bar" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "juliet";
domainpart = "example.com";
resourcepart = Some "foo bar" } |}]
let%expect_test {|"At" sign in resourcepart|} =
"juliet@example.com/foo@bar" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "juliet";
domainpart = "example.com";
resourcepart = Some "foo@bar" } |}]
let%expect_test {|Single space in localpart, as optionally escaped using the XMPP JID Escaping extension|} =
"foo\\20bar@example.com" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "foo\20bar";
domainpart = "example.com";
resourcepart = None } |}]
let%expect_test {|Another bare JID|} =
"fussball@example.com" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "fussball";
domainpart = "example.com";
resourcepart = None } |}]
let%expect_test {|The third character is LATIN SMALL LETTER SHARP S (U+00DF)|} =
"fußball@example.com" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "fußball";
domainpart = "example.com";
resourcepart = None } |}]
let%expect_test {|A localpart of GREEK SMALL LETTER PI (U+03C0)|} =
"π@example.com" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "π";
domainpart = "example.com";
resourcepart = None } |}]
let%expect_test {|A localpart of GREEK CAPITAL LETTER SIGMA (U+03A3)|} =
"Σ@example.com/foo" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "Σ";
domainpart = "example.com";
resourcepart = Some "foo" } |}]
let%expect_test {|A localpart of GREEK SMALL LETTER SIGMA (U+03C3)|} =
"σ@example.com/foo" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "σ";
domainpart = "example.com";
resourcepart = Some "foo" } |}]
let%expect_test {|A localpart of GREEK SMALL LETTER FINAL SIGMA (U+03C2)|} =
"ς@example.com/foo" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "ς";
domainpart = "example.com";
resourcepart = Some "foo" } |}]
let%expect_test {|A resourcepart of the Unicode character BLACK CHESS KING (U+265A)|} =
"king@example.com/♚" |> of_string |> show |> print_string;
[%expect {|
{ localpart = Some "king";
domainpart = "example.com";
resourcepart = Some "♚" } |}]
let%expect_test {|A domainpart|} =
"example.com" |> of_string |> show |> print_string;
[%expect {|
{ localpart = None;
domainpart = "example.com";
resourcepart = None } |}]
let%expect_test {|A domainpart and resourcepart|} =
"example.com/foobar" |> of_string |> show |> print_string;
[%expect {|
{ localpart = None;
domainpart = "example.com";
resourcepart = Some "foobar" } |}]
let%expect_test {|A domainpart followed by a resourcepart that contains an "at" sign|} =
"a.example.com/b@example.net" |> of_string |> show |> print_string;
[%expect {|
{ localpart = None;
domainpart = "a.example.com";
resourcepart = Some "b@example.net" } |}]
let to_string ({ localpart; domainpart; resourcepart } : t) =
let local = Option.fold ~none:"" ~some:(fun l -> l ^ "@") localpart
and resource = Option.fold ~none:"" ~some:(fun r -> "/" ^ r) resourcepart
in local ^ domainpart ^ resource
|
