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 ""

let dir = ".well-known/webfinger"

let well_known_uri (Rfc7565.T u' as u) =
  let host = u' |> Uri.host in
  assert (host |> Option.is_some);
  let host = host |> Option.get in
  let path = "/" ^ dir in
  Uri.make
    ~scheme:"https"
    ~host
    ~path
    ~query:["resource", [u |> Rfc7565.to_string]]
    ()

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

(* https://tools.ietf.org/html/rfc7033
*)
module Client = struct
  let http_get
      ?(key = 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" Rfc7565.scheme uid host in
  let tmpl    = Format.asprintf "%a%s/%s?id={uri}" Uri.pp base Cfg.seppo_cgi "activitypub/actor.xml" 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_replace (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_replace (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 ../../%s\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 Cfg.seppo_cgi Rfc7565.scheme (uid |> Str.quote) pat dir;
          if not (pat |> String.equal "/")
          then (
            assert (pat |> St.is_prefix ~affix:"/");
            assert (pat |> St.is_suffix ~affix:"/");
            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 couldn't remove %s: %a" "Make" "make" dst St.pp_exc 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 %a" "Make" "make" St.pp_exc e)
          );
          Ok "")
  }

  let make = Make.make [rule]
end