lib/rfc7565.ml

   1 (*
   2  *    _  _   ____                         _
   3  *  _| || |_/ ___|  ___ _ __  _ __   ___ | |
   4  * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| |
   5  * |_      _|___) |  __/ |_) | |_) | (_) |_|
   6  *   |_||_| |____/ \___| .__/| .__/ \___/(_)
   7  *                     |_|   |_|
   8  *
   9  * Personal Social Web.
  10  *
  11  * Copyright (C) The #Seppo contributors. All rights reserved.
  12  *
  13  * This program is free software: you can redistribute it and/or modify
  14  * it under the terms of the GNU General Public License as published by
  15  * the Free Software Foundation, either version 3 of the License, or
  16  * (at your option) any later version.
  17  *
  18  * This program is distributed in the hope that it will be useful,
  19  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21  * GNU General Public License for more details.
  22  *
  23  * You should have received a copy of the GNU General Public License
  24  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25  *)
  26
  27 (* https://datatracker.ietf.org/doc/html/rfc7565 *)
  28 type t = T of Uri.t
  29
  30 let scheme = "acct"
  31
  32 let of_uri u =
  33   assert ("acct" |> String.equal scheme);
  34   match
  35     u |> Uri.scheme,
  36     u |> Uri.user,
  37     u |> Uri.host,
  38     u |> Uri.port,
  39     u |> Uri.path,
  40     u |> Uri.query,
  41     u |> Uri.fragment
  42   with
  43   | Some "acct",
  44     Some _,
  45     Some _,
  46     None,
  47     "",
  48     [],
  49     None
  50     -> Some (T u)
  51   | _
  52     -> None
  53
  54 let make ~local ~domain () =
  55   match Uri.make
  56           ~scheme
  57           ~userinfo:local
  58           ~host:domain
  59           ()
  60         |> of_uri with
  61   | None ->
  62     Printf.sprintf "%s @%s@%s" __LOC__ local domain
  63     |> failwith
  64   | Some u -> u
  65
  66 let rx_scheme = scheme ^ {|:\|@|}
  67 let rx_user = {|[^@: ]+|}
  68 let rx_host = {|[^ :/\?#]+|}
  69 let rx' = {|^\(|} ^ rx_scheme ^ {|\)?\(|} ^ rx_user ^ {|\)@\(|} ^ rx_host ^ {|\)$|}
  70 let rx = rx' |> Str.regexp
  71
  72 let of_string s =
  73   if not (Str.string_match rx s 0)
  74   then Error ("doesn't match /" ^ rx' ^ "/")
  75   else
  76     Ok (make
  77           ~local:(Str.matched_group 2 s)
  78           ~domain:(Str.matched_group 3 s)
  79           () )
  80
  81 let to_string ?(prefix = scheme ^ ":") (T u) =
  82   Printf.sprintf "%s%s@%s"
  83     prefix
  84     (u |> Uri.user |> Option.value ~default:"")
  85     (u |> Uri.host |> Option.value ~default:"")
  86
  87 let pp_hum ppf uri = Format.pp_print_string ppf (to_string ~prefix:"@" uri)