blob: b06a00c14aae71058a2d4df5d52a6679b89ee629 (
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
|
type t = {
localpart : string option;
domainpart : string;
resourcepart : string option;
}
exception InvalidUTF8
type uchars = Uchar.t 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 :: acc) (i + k)
in loop [] (String.length s)
let string_of_uchars (u : uchars) =
let buf = Buffer.create (4 * List.length u) in
List.iter (Buffer.add_utf_8_uchar buf) u;
Buffer.to_bytes buf |> String.of_bytes
let of_string (jid : string) : t =
let open Uchar in
let len = String.length jid in
let rec to_localpart i =
if i <= 0 then
None
else
let c = String.get_utf_8_uchar jid i in
if not (utf_decode_is_valid c)
then raise InvalidUTF8
else
let k = utf_decode_length c in
match utf_decode_uchar c |> to_char with
| '@' -> Some (i + 1)
| _ -> to_localpart (i - k)
and to_resourcepart i =
if i >= len then
None
else
let c = String.get_utf_8_uchar jid i in
if not (utf_decode_is_valid c)
then raise InvalidUTF8
else
let k = utf_decode_length c in
match utf_decode_uchar c |> to_char with
| '/' -> Some i
| _ -> to_resourcepart (i + k)
in let r = to_resourcepart 0 in
let rv = Option.value ~default:len r in
let l = to_localpart (rv-1) in
let lv = Option.value ~default:0 l in
{
localpart = Option.map (fun i -> String.sub jid 0 (i-1)) l;
resourcepart = Option.map (fun i -> String.sub jid (i+1) (len-i-1)) r;
domainpart = String.sub jid lv (rv-lv);
}
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
|
