seppo/lib/webfinger.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

let to_result none = Option.to_result ~none
let ( >>= ) = Result.bind
let ( let* ) = Result.bind
let chain a b =
  let f a = Ok (a, b) in
  Result.bind a f
let writev oc j =
  Ezjsonm.value_to_channel ~minify:false oc j;
  Ok ""

(* https://datatracker.ietf.org/doc/html/rfc7565 *)
let scheme = "acct"
let rx = {|^\(\(|} ^ scheme ^ {|:\)\|@\)?\([^@: ]+\)@\([^ ]+\)|} |> Str.regexp

type rfc7565 = Rfc7565 of Uri.t

let of_string s =
  let u = if Str.string_match rx s 0
    then
      let userinfo = s |> Str.matched_group 3
      and host     = s |> Str.matched_group 4
      in Uri.make ~scheme ~userinfo ~host ()
    else s |> Uri.of_string in
  Rfc7565 u

let to_string (Rfc7565 u) =
  assert (scheme = "acct");
  let s = u |> Uri.to_string in
  match s |> St.after ~prefix:"acct://" with
  | Some s -> "acct:" ^ s
  | None   -> s

let dir = ".well-known/webfinger"

let well_known_uri (Rfc7565 u' as u) =
  let path = "/" ^ dir in
  let u = u |> to_string in
  let* host = u' |> Uri.host |> Option.to_result ~none:("host mandatory: " ^ u) in
  Ok (Uri.make
        ~scheme:"https"
        ~host
        ~path
        ~query:["resource", [u]]
        ())

let apa = "activitypub/actor.jsa" (* redeclare Ap.proj to avoid dependency cycle *)

(* https://tools.ietf.org/html/rfc7033
*)
module Client = struct
  type l = Localpart of string
  type h = Domainpart of string
  type t = (l * h)

  let rfc7565_to_string = to_string
  let rfc7565_of_string = of_string

  let[@deprecated] from_uri (Rfc7565 u) : (t, string) result =
    match (u |> Uri.scheme), (u |> Uri.user), (u |> Uri.host), (u |> Uri.port), (u |> Uri.path), (u |> Uri.query), (u |> Uri.fragment) with
    | Some "acct", Some usr, Some hos, None, "", [], None ->
      Ok (Localpart usr, Domainpart hos)
    | _ ->
      Error ("uri must be user and host, e.g. acct://alice@example.com but was\n" ^ (u |> Uri.to_string))

  let[@deprecated] from_string s : (t, string) result =
    s
    |> rfc7565_of_string
    |> from_uri

  let[@deprecated] to_rfc7565 (Localpart userinfo, Domainpart host) =
    Rfc7565 (Uri.make ~scheme ~userinfo ~host ())

  let[@deprecated] to_string me =
    me |> to_rfc7565 |> rfc7565_to_string

  let to_short h =
    let Rfc7565 u = h |> to_rfc7565 in
    let s = u |> Uri.to_string in
    let l = s |> String.length in
    String.sub s 7 (l-7)

  let http_get
      ?(key : Http.t_sign_k option = None)
      (w : Uri.t) =
    let mape (_ : Ezjsonm.value Decoders__Error.t) =
      Logr.err (fun m -> m "%s: webfinger decode failed %a" E.e1027
                   Uri.pp w);
      E.e1027 ^ ": webfinger decode failed" in
    let deco j = j
                 |> As2_vocab.Decode.Webfinger.query_result
                 |> Result.map_error mape in
    let headers = [Http.H.acc_app_jrd] |> Cohttp.Header.of_list in
    let%lwt p = w |> Http.get_jsonv ~key ~headers Result.ok in
    p
    >>= deco
    |> Lwt.return
end

let make (Auth.Uid uid, base) : As2_vocab.Types.Webfinger.query_result =
  let host    = base |> Uri.host |> Option.value ~default:"-" in
  let subject = Printf.sprintf "%s:%s@%s" scheme uid host in
  let tmpl    = Format.asprintf "%aseppo.cgi/activitypub/actor.xml?id={uri}" Uri.pp base in
  let open As2_vocab.Types.Webfinger in
  let path    = apa in
  let links   = [
    Self             (`ActivityJsonLd, Uri.make ~path ());
    ProfilePage      (`Html, Uri.make ~path:"." ());
    Alternate        (`Atom, Rfc4287.defa);
    OStatusSubscribe tmpl;
  ] in
  {subject;aliases=[];links}

let jsonm (uid, base) : (Ezjsonm.value,'a) result =
  (uid, base)
  |> make
  |> As2_vocab.Encode.Webfinger.query_result ~base
  |> Result.ok

let target = dir ^ "/index.jrd"
let rule : Make.t =
  { target;
    prerequisites  = [ apa ];
    fresh = Make.Outdated;
    command = fun _ _ru _all ->
      File.out_channel' (fun oc ->
          Cfg.Base.(fn |> from_file)
          >>= chain Auth.(fn |> uid_from_file)
          >>= jsonm
          >>= writev oc)
  }
let rulez = rule :: [] (* :: Ap.Person.rulez *)

module Server = struct
  (* Create a local .well-known/webfinger and link here from the global one (in webroot). *)
  let target = dir ^ "/.htaccess"
  let rule : Make.t = {
    target;
    prerequisites  = [ rule.target ];
    fresh = Make.Outdated;
    command = fun _pre _ _ ->
      File.out_channel' (fun oc ->
          let* (Auth.Uid uid),_ = Auth.(from_file fn) in
          let* base = Cfg.Base.(from_file fn) in
          let pat = base |> Uri.path in
          Printf.fprintf oc "# https://%s/S1002\n\
                             # automatically linked or manually appended to <webroot>/%s\n\
                             # created by ../../seppo.cgi\n\
                             RewriteEngine On\n\
                             RewriteCond %%{QUERY_STRING} (?i)^(.+?&)?resource=%s:%s@.+$\n\
                             RewriteRule ^$ %s%s/index.jrd [qsdiscard,last,redirect=seeother]\n"
            St.seppo_s target scheme (uid |> Str.quote) pat dir;
          if not (pat |> String.equal "/")
          then (
            assert (pat |> St.starts_with ~prefix:"/");
            assert (pat |> St.ends_with ~suffix:"/");
            assert (target |> St.updir |> String.equal "../../");
            let prefi = pat |> St.updir in
            let dst = prefi ^ target in
            let _ = dst |> Filename.dirname |> File.mkdir_p File.pDir in
            if Unix.(try S_LNK == (lstat dst).st_kind
                     with | _ -> false)
            then (
              Logr.debug (fun m -> m "%s.%s remove symlink %s" "Webfinger.Server" "rule" dst);
              try Unix.unlink dst
              with | e -> Logr.debug (fun m -> m "%s.%s counldn't remove %s: %s" "Make" "make" dst (Printexc.to_string e)) )
            else
              Logr.warn (fun m -> m "%s.%s %s %s isn't a symlink, so I don't interfere with it. Do that manually." "Webfinger.Server" "rule" E.e1031 dst);
            let src = "../.." ^ pat ^ target in
            Logr.debug (fun m -> m "%s.%s ln -s %s %s" "Webfinger.Server" "rule" src dst);
            try Unix.symlink src dst
            with | e -> Logr.err (fun m -> m "%s.%s 3 %s" "Make" "make" (Printexc.to_string e))
          );
          Ok "")
  }

  let make = Make.make [rule]
end