blob: d2c73619ccacdd1b49546aabd4cd50fb47b3515d (
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
|
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
let%expect_test {|"At" sign in resourcepart|} =
"juliet@example.com/foo@bar" |> of_string |> show |> print_string
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
let%expect_test {|Another bare JID|} =
"fussball@example.com" |> of_string |> show |> print_string
let%expect_test {|The third character is LATIN SMALL LETTER SHARP S (U+00DF)|} =
"fußball@example.com" |> of_string |> show |> print_string
let%expect_test {|A localpart of GREEK SMALL LETTER PI (U+03C0)|} =
"π@example.com" |> of_string |> show |> print_string
let%expect_test {|A localpart of GREEK CAPITAL LETTER SIGMA (U+03A3)|} =
"Σ@example.com/foo" |> of_string |> show |> print_string
let%expect_test {|A localpart of GREEK SMALL LETTER SIGMA (U+03C3)|} =
"σ@example.com/foo" |> of_string |> show |> print_string
let%expect_test {|A localpart of GREEK SMALL LETTER FINAL SIGMA (U+03C2)|} =
"ς@example.com/foo" |> of_string |> show |> print_string
let%expect_test {|A resourcepart of the Unicode character BLACK CHESS KING (U+265A)|} =
"king@example.com/♚" |> of_string |> show |> print_string
let%expect_test {|A domainpart|} =
"example.com" |> of_string |> show |> print_string
let%expect_test {|A domainpart and resourcepart|} =
"example.com/foobar" |> of_string |> show |> print_string
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
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
|
