(** 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 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 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" } |}]