blob: 4e58c5b8f5edfaf68200d539c24fd5798fafc5e5 (
plain) (
blame)
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
|
(** An XMPP JID. If there is no localpart or resourcepart, they're [None]. *)
type t = {
localpart : string option;
domainpart : string;
resourcepart : string option;
}
exception InvalidUTF8
type uchars = (Uchar.t * int) list
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
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
|
