seppo/lib/ap.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Ap.
 *
 * 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 seppo_cgi' = Cfg.seppo_cgi
let apub = "activitypub/"
let proj = apub ^ "actor.jsa" (* the public actor profile *)
let prox = apub ^ "actor.xml" (* the public actor profile *)
let content_length_max = 10 * 1024

let ( let* ) = Result.bind
let ( >>= )  = Result.bind
let to_result none = Option.to_result ~none
let chain a b =
  let f a = Ok (a, b) in
  Result.bind a f

let write oc (j : Ezjsonm.t) =
  Ezjsonm.to_channel ~minify:false oc j;
  Ok ""

let writev oc (j : Ezjsonm.value) =
  Ezjsonm.value_to_channel ~minify:false oc j;
  Ok ""

let json_from_file fn =
  let ic = open_in_gen  [ Open_rdonly; Open_binary ] 0 fn in
  let j = Ezjsonm.value_from_channel ic in
  close_in ic;
  Ok j

(** X509.Public_key from PEM. *)
module PubKeyPem = struct
  let of_pem s =
    s
    |> X509.Public_key.decode_pem

  let target = apub ^ "id_rsa.pub.pem"
  let pk_pem = "app/etc/id_rsa.priv.pem"

  let pk_rule : Make.t = {
    target         = pk_pem;
    prerequisites  = [];
    fresh          = Make.Missing;
    command        = fun _ _ _ ->
      File.out_channel_replace (fun oc ->
          Logr.debug (fun m -> m "create private key pem.");
          (* https://discuss.ocaml.org/t/tls-signature-with-opam-tls/9399/3?u=mro
           * $ openssl genrsa -out app/etc/id_rsa.priv.pem 2048
          *)
          try
            `RSA
            |> X509.Private_key.generate ~bits:2048
            |> X509.Private_key.encode_pem
            |> output_string oc;
            Ok ""
          with _ ->
            Logr.err (fun m -> m "%s couldn't create pk" E.e1010);
            Error "couldn't create pk")
  }

  let rule : Make.t = {
    target;
    prerequisites = [ pk_pem ];
    fresh         = Make.Outdated;
    command       = fun _pre _ r ->
      File.out_channel_replace (fun oc ->
          Logr.debug (fun m -> m "create public key pem." );
          match r.prerequisites with
          | [ fn_priv ] -> (
              assert (fn_priv = pk_pem);
              match
                fn_priv
                |> File.to_string
                |> X509.Private_key.decode_pem
              with
              | Ok (`RSA _ as key) ->
                key
                |> X509.Private_key.public
                |> X509.Public_key.encode_pem
                |> output_string oc;
                Ok ""
              | Ok _ ->
                Logr.err (fun m -> m "%s %s" E.e1032 "wrong key flavour, must be RSA.");
                Error "wrong key flavour, must be RSA."
              | Error (`Msg mm) ->
                Logr.err (fun m -> m "%s %s" E.e1033 mm);
                Error mm
            )
          | l ->
            Error
              (Printf.sprintf
                 "rule must have exactly one dependency, not %d"
                 (List.length l)))
  }

  let rulez = pk_rule :: rule :: []

  let make pre =
    Make.make ~pre rulez target

  let private_of_pem_data pem_data =
    match pem_data
          |> X509.Private_key.decode_pem with
    | Ok (`RSA _ as pk) -> Ok pk
    | Ok _              -> Error "key must be RSA"
    | Error (`Msg e)    -> Error e

  (** load a private key pem from a file *)
  let private_of_pem fn =
    fn
    |> File.to_string
    |> private_of_pem_data

  (** RSA SHA256 sign data with pk.

      returns

      algorithm,signature

       with algorithm currently being fixed to rsa-sha256.
       See https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
  *)
  let sign pk (data : string) : (string * string) =
    (* Logr.debug (fun m -> m "PubKeyPem.sign"); *)
    (*
     * https://discuss.ocaml.org/t/tls-signature-with-opam-tls/9399/9?u=mro
     * https://mirleft.github.io/ocaml-x509/doc/x509/X509/Private_key/#cryptographic-sign-operation
     *)
    (Http.Signature.RSA_SHA256.name, Http.Signature.RSA_SHA256.sign pk (`Message data)
                                     |> Result.get_ok)

  (** https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
  *)
  let verify ~algo ~inbox ~key ~signature data =
    let data = `Message data
    and _ = inbox in
    match algo with
    | "hs2019" -> (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38 *)
      (match Http.Signature.HS2019.verify
               ~signature
               key
               data with
      | Error (`Msg "bad signature") ->
        (* gotosocial and unnamed other AP implementations seem to use `SHA256 and `RSA_PKCS1
           while
           https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
           and
           https://datatracker.ietf.org/doc/id/draft-richanna-http-message-signatures-00.html#name-hs2019
           as I understand them recommend `SHA512 and `RSA_PSS. *)
        (match Http.Signature.RSA_SHA256.verify
                 ~signature
                 key
                 data with
        | Ok _ as o ->
          Logr.info (fun m -> m "%s.%s another dadaist http signature" "Ap.PubKeyPem" "verify");
          o
        | x -> x)
      | x -> x)
    | "rsa-sha256" ->
      Http.Signature.RSA_SHA256.verify
        ~signature
        key
        data
    | a ->
      Error (`Msg (Printf.sprintf "unknown algorithm: '%s'" a))

  (** not key related *)
  let digest_base64 s =
    Logr.debug (fun m -> m "%s.%s %s" "Ap.PubKeyPem" "digest" "SHA-256");
    "SHA-256=" ^ Digestif.SHA256.(s
                                  |> digest_string
                                  |> to_raw_string
                                  |> Base64.encode_exn )

  let digest_base64' s =
    Some (digest_base64 s)
end

module Actor = struct
  let http_get ?(key = None) u =
    Logr.debug (fun m -> m "%s.%s %a" "Ap.Actor" "http_get" Uri.pp u);
    let%lwt p = u |> Http.get_jsonv ~key Result.ok in
    (match p with
     | Error _ as e -> e
     | Ok (r,j) ->
       match r.status with
       | #Cohttp.Code.success_status ->
         let mape (e : Ezjsonm.value Decoders__Error.t) =
           let s = e |> Decoders_ezjsonm.Decode.string_of_error in
           Logr.err (fun m -> m "%s %s.%s failed to decode actor %a:\n%s" E.e1002 "Ap.Actor" "http_get" Uri.pp u s);
           s in
         j
         |> As2_vocab.Decode.actor
         |> Result.map_error mape
       | _sta -> Format.asprintf "HTTP %a %a" Http.pp_status r.status Uri.pp u
                 |> Result.error)
    |> Lwt.return
end

let sep n = `Data ("\n" ^ String.make (n*2) ' ')

(** A person actor object. https://www.w3.org/TR/activitypub/#actor-objects *)
module Person = struct

  let generate_key_id actor_id = Uri.with_fragment actor_id (Some "main-key")

  let my_key_id ~base = Uri.make ~path:proj ()
                        |> Http.reso ~base
                        |> generate_key_id

  let empty = ({
      typ                        = "Person";
      id                         = Uri.empty;
      inbox                      = Uri.empty;
      outbox                     = Uri.empty;
      followers                  = None;
      following                  = None;
      attachment                 = [];
      discoverable               = false;
      generator                  = None;
      icon                       = [];
      image                      = None;
      manually_approves_followers= true;
      name                       = None;
      name_map                   = [];
      preferred_username         = None;
      preferred_username_map     = [];
      public_key                 = {
        id    = Uri.empty;
        owner = None;
        pem   = "";
        signatureAlgorithm = None;
      };
      published                  = None;
      summary                    = None;
      summary_map                = [];
      url                        = [];
    } : As2_vocab.Types.actor)

  let prsn _pubdate (pem, ((pro : Cfg.Profile.t), (Auth.Uid uid, _base))) =
    let Rfc4287.Rfc4646 la = pro.language in
    let actor = Uri.make ~path:proj () in
    let path u = u |> Http.reso ~base:actor in
    ({
      typ                        = "Person";
      id                         = actor;
      inbox                      = Uri.make ~path:("../" ^ seppo_cgi' ^ "/" ^ apub ^ "inbox.jsa") () |> path;
      outbox                     = Uri.make ~path:"outbox/index.jsa" () |> path;
      followers                  = Some (Uri.make ~path:"subscribers/index.jsa" () |> path);
      following                  = Some (Uri.make ~path:"subscribed_to/index.jsa" () |> path);
      attachment                 = [];
      discoverable               = true;
      generator                  = Some {href=St.seppo_u; name=(Some St.seppo_c); name_map=[]; rel=None };
      icon                       = [ (Uri.make ~path:"../me-avatar.jpg" () |> path) ];
      image                      = Some (Uri.make ~path:"../me-banner.jpg" () |> path);
      manually_approves_followers= false;
      name                       = Some pro.title;
      name_map                   = [];
      preferred_username         = Some uid;
      preferred_username_map     = [];
      public_key                 = {
        id    = actor |> generate_key_id;
        owner = Some actor; (* add this deprecated property to make mastodon happy *)
        pem;
        signatureAlgorithm = Some "https://www.w3.org/2001/04/xmldsig-more#rsa-sha256"; (* from hubzilla, e.g. https://im.allmendenetz.de/channel/minetest *)
      };
      published                  = None;
      summary                    = Some pro.bio;
      summary_map                = [(la,pro.bio)];
      url                        = [ Uri.make ~path:"../" () |> path ];
    } : As2_vocab.Types.actor)

  module Json = struct
    let decode j =
      j
      |> As2_vocab.Decode.actor
      |> Result.map_error (fun _ -> "@TODO aua json")

    let encode _pubdate (pem, ((pro : Cfg.Profile.t), (uid, base))) =
      let Rfc4287.Rfc4646 l = pro.language in
      let lang = Some l in
      prsn _pubdate (pem, (pro, (uid, base)))
      |> As2_vocab.Encode.actor ~base ~lang
      |> Result.ok
  end

  let x2txt v =
    Markup.(v
            |> string
            |> parse_html
            |> signals
            (* |> filter_map (function
                 | `Text _ as t -> Some t
                 | `Start_element ((_,"p"), _)  -> Some (`Text ["\n<p>&#0x10;\n"])
                 | `Start_element ((_,"br"), _) -> Some (`Text ["\n<br>\n"])
                 | _ -> None)
               |> write_html
            *)
            |> text
            |> to_string)

  let x2txt' v =
    Option.bind v (fun x -> Some (x |> x2txt))

  let flatten (p : As2_vocab.Types.actor) =
    {p with
     summary = x2txt' p.summary;
     attachment = List.fold_left (fun init (e : As2_vocab.Types.property_value) ->
         ({e with value = x2txt e.value}) :: init) [] p.attachment}

  let target = proj

  let rule : Make.t =
    {
      target;
      prerequisites  = [
        Auth.fn;
        Cfg.Base.fn;
        Cfg.Profile.fn;
        PubKeyPem.target;
      ];
      fresh = Make.Outdated;
      command  = fun pre _ _ ->
        File.out_channel_replace (fun oc ->
            let now = Ptime_clock.now () in
            Cfg.Base.(fn |> from_file)
            >>= chain Auth.(fn |> uid_from_file)
            >>= chain Cfg.Profile.(fn |> from_file)
            >>= chain (PubKeyPem.make pre >>= File.cat)
            >>= Json.encode now
            >>= writev oc)
    }

  let rulez = rule :: PubKeyPem.rulez

  let make pre = Make.make ~pre rulez target

  let from_file fn =
    fn
    |> json_from_file
    >>= Json.decode

  module Rdf = struct
    let encode' ~base ~lang ({ typ; id; name; name_map; url; inbox; outbox;
                               preferred_username; preferred_username_map; summary; summary_map;
                               manually_approves_followers;
                               discoverable; generator; followers; following;
                               public_key; published; attachment; icon; image}: As2_vocab.Types.actor) : _ Xmlm.frag =
      let ns_as     = As2_vocab.Constants.ActivityStreams.ns_as ^ "#"
      and ns_ldp    = "http://www.w3.org/ns/ldp#"
      and ns_rdf    = "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
      and ns_schema = "http://schema.org#"
      (* and ns_sec    = As2_vocab.Constants.ActivityStreams.ns_sec ^ "#" *)
      and ns_toot   = "http://joinmastodon.org/ns#"
      and ns_xsd    = "http://www.w3.org/2001/XMLSchema#" in
      let txt ?(lang = None) ?(datatype = None) ns tn (s : string) =
        let att = [] in
        let att = match lang with
          | Some v -> ((Xmlm.ns_xml, "lang"), v) :: att
          | None   -> att in
        let att = match datatype with
          | Some v -> ((ns_rdf, "datatype"), v) :: att
          | None   -> att in
        `El (((ns, tn), att), [`Data s]) in
      let uri   ns tn u       = `El (((ns, tn), [ ((ns_rdf, "resource"), u |> Http.reso ~base |> Uri.to_string) ]), []) in
      let txt'  ns tn none s' = s' |> Option.fold ~none ~some:(fun n -> txt ns tn n :: sep 2 :: none) in
      let link_tbd ns tn none s' = s' |> Option.fold ~none ~some:(fun (_ : As2_vocab.Types.link) ->
          `El (((ns, tn), []), [ (* @TODO *) ])
          :: sep 2 :: none) in
      let bool' ns tn none s' = s' |> Option.fold ~none ~some:(fun n -> txt ~datatype:(Some (ns_xsd ^ "boolean")) ns tn (if n then "true" else "false") :: sep 2 :: none) in
      let rfc3339' ns tn none s'=s'|> Option.fold ~none ~some:(fun n -> txt ~datatype:(Some (ns_xsd ^ "dateTime")) ns tn (n |> Ptime.to_rfc3339) :: sep 2 :: none) in
      let uri'  ns tn none s' = s' |> Option.fold ~none ~some:(fun n -> uri ns tn n :: sep 2 :: none) in
      let img'  _n tn none (u' : Uri.t option) = u' |> Option.fold ~none ~some:(fun u ->
          `El (((ns_as, tn), []),
               sep 3
               :: `El (((ns_as, "Image"), []),
                       sep 4
                       :: uri ns_as "url" u
                       :: [])
               :: []) :: sep 2 :: none
        ) in
      let img'' _n tn none (u' : Uri.t list) = img' _n tn none (List.nth_opt u' 0) in
      let lang = lang |> Option.value ~default:"und" in
      Logr.debug (fun m -> m "%s.%s %a %s" "Ap.Person.RDF" "encode" Uri.pp base lang);
      let _ = public_key in
      let f_map name init (lang,value) = txt ~lang:(Some lang) ns_as name value :: sep 3 :: init in
      let f_uri name init value = uri ns_as name value :: sep 2 :: init in
      let f_att init ({name; name_map; value; value_map} : As2_vocab.Types.property_value) =
        let _ = name_map and _ = value_map in (* TODO *)
        let sub = sep 4
                  :: txt ns_as     "name"  name
                  :: sep 4
                  :: txt ns_schema "value" value
                  :: [] in
        let sub = name_map |> List.fold_left (f_map "name") sub in
        let sub = value_map |> List.fold_left (f_map "value") sub in
        `El (((ns_as, "attachment"), []),
             sep 3
             :: `El (((ns_schema, "PropertyValue"), []), sub)
             :: []) :: sep 2 :: init in
      let chi = [] in
      let chi = Some outbox                      |> uri'     ns_as   "outbox"                    chi in
      let chi = Some inbox                       |> uri'     ns_ldp  "inbox"                     chi in
      let chi = followers                        |> uri'     ns_as   "followers"                 chi in
      let chi = following                        |> uri'     ns_as   "following"                 chi in
      let chi = attachment                       |> List.fold_left f_att                         chi in
      let chi = image                            |> img'     ns_as   "image"                     chi in
      let chi = icon                             |> img''    ns_as   "icon"                      chi in
      let chi = summary                          |> txt'     ns_as   "summary"                   chi in
      let chi = summary_map                      |> List.fold_left (f_map "summary")             chi in
      let chi = url                              |> List.fold_left (f_uri "url")                 chi in
      let chi = name                             |> txt'     ns_as   "name"                      chi in
      let chi = name_map                         |> List.fold_left (f_map "name")                chi in
      let chi = generator                        |> link_tbd ns_as   "generator"                 chi in
      let chi = Some discoverable                |> bool'    ns_toot "discoverable"              chi in
      let chi = Some manually_approves_followers |> bool'    ns_as   "manuallyApprovesFollowers" chi in
      let chi = published                        |> rfc3339' ns_as   "published"                 chi in
      let chi = preferred_username               |> txt'     ns_as   "preferredUsername"         chi in
      let chi = preferred_username_map           |> List.fold_left (f_map "preferredUsername")   chi in
      let chi = Some id                          |> uri'     ns_as   "id"                        chi in
      let chi = sep 2 :: chi in
      `El (((ns_as, typ), [
          ((Xmlm.ns_xmlns, "as"),     ns_as);
          ((Xmlm.ns_xmlns, "ldp"),    ns_ldp);
          ((Xmlm.ns_xmlns, "schema"), ns_schema);
          (* ((Xmlm.ns_xmlns, "sec"),    ns_sec); *)
          ((Xmlm.ns_xmlns, "toot"),   ns_toot);
          (* needs to be inline vebose ((Xmlm.ns_xmlns, "xsd"),    ns_xsd); *)
          ((ns_rdf, "about"), "");
          ((Xmlm.ns_xml, "lang"), lang);
        ]), chi)

    (* Alternatively may want to take a Ap.Feder.t *)
    let encode ?(token = None) ?(is_in_subscribers = None) ?(am_subscribed_to = None) ?(blocked = None) ~base ~lang pe : _ Xmlm.frag =
      let open Xml in
      let txt ?(datatype = None) ns tn (s : string) =
        `El (((ns, tn), match datatype with
          | Some ty -> [((ns_rdf, "datatype"), ty)]
          | None    -> []), [`Data s]) in
      let txt' ns tn none s'   = s' |> Option.fold ~none ~some:(fun n -> txt ns tn n :: sep 2 :: none) in
      let noyes' ns tn none s' = s' |> Option.fold ~none ~some:(fun n -> txt ns tn (n |> As2.No_p_yes.to_string) :: sep 2 :: none) in
      `El (((ns_rdf, "RDF"), [
          ((Xmlm.ns_xmlns, "rdf"), ns_rdf);
          ((Xmlm.ns_xmlns, "seppo"),  ns_seppo);
          ((Xmlm.ns_xml,"base"),base |> Uri.to_string);
        ]),
           sep 1 ::
           `El (((ns_rdf, "Description"), [ (ns_rdf, "about"), "" ]),
                sep 2 ::
                txt'   ns_seppo "token"            [] token     @
                noyes' ns_seppo "is_subscriber"    [] is_in_subscribers    @
                noyes' ns_seppo "am_subscribed_to" [] am_subscribed_to @
                noyes' ns_seppo "is_blocked"       [] blocked
               )
           :: sep 1
           :: encode' ~base ~lang pe
           :: [])
  end
end

(* Xml subset of the profle page. *)
module PersonX = struct
  let xml_ pubdate (pem, (pro, (uid, base))) =
    let Rfc4287.Rfc4646 lang = (pro : Cfg.Profile.t).language in
    Person.prsn pubdate (pem, (pro, (uid, base)))
    |> Person.Rdf.encode ~base ~lang:(Some lang)
    |> Result.ok

  let target = prox

  let rule = {Person.rule
              with target;
                   command = fun pre _ _ ->
                     File.out_channel_replace (fun oc ->
                         let now = Ptime_clock.now () in
                         let writex oc x =
                           let xsl = Some "../themes/current/actor.xsl" in
                           Xml.to_chan ~xsl x oc;
                           Ok "" in
                         Cfg.Base.(fn |> from_file)
                         >>= chain Auth.(fn |> uid_from_file)
                         >>= chain Cfg.Profile.(fn |> from_file)
                         >>= chain (PubKeyPem.make pre >>= File.cat)
                         >>= xml_ now
                         >>= writex oc) }

  let rulez = rule :: PubKeyPem.rulez

  let make pre = Make.make ~pre rulez target
end

(**
 * https://www.w3.org/TR/activitystreams-core/
 * https://www.w3.org/TR/activitystreams-core/#media-type
*)
let send ?(success = `OK) ~key (f_ok : Cohttp.Response.t * string -> unit) to_ msg =
  let body = msg |> Ezjsonm.value_to_string in
  let signed_headers body = PubKeyPem.(Http.signed_headers key (digest_base64' body) to_) in
  let headers = signed_headers body in
  let headers = Http.H.add' headers Http.H.ct_jlda in
  let headers = Http.H.add' headers Http.H.acc_app_jlda in
  (* TODO queue it and re-try in case of failure *)
  let%lwt r   = Http.post ~headers body to_ in
  (match r with
   | Ok (res,body') ->
     let%lwt body' = body' |> Cohttp_lwt.Body.to_string in
     (match res.status with
      | #Cohttp.Code.success_status ->
        Logr.debug (fun m -> m "%s.%s %a\n%a\n\n%s" "Ap" "send" Uri.pp to_ Cohttp.Response.pp_hum res body');
        f_ok (res, body');
        Ok (success, [Http.H.ct_plain], Cgi.Response.body "ok")
      | sta ->
        Logr.warn (fun m -> m "%s.%s %a\n%a\n\n%s" "Ap" "send" Uri.pp to_ Cohttp.Response.pp_hum res body');
        Http.s502 ~body:(sta |> Cohttp.Code.string_of_status |> Cgi.Response.body ~ee:E.e1039) ()
     ) |> Lwt.return
   | Error e ->
     Logr.warn (fun m -> m "%s.%s <- %s %a\n%s" "Ap" "send" "post" Uri.pp to_ e);
     Http.s500 |> Lwt.return)

let snd_reject
    ~uuid
    ~base
    ~key
    me
    (siac : As2_vocab.Types.actor)
    (j : Ezjsonm.value) =
  Logr.warn(fun m -> m "%s.%s %a %a" "Ap" "snd_reject" Uuidm.pp uuid Uri.pp siac.inbox);
  assert (not (me |> Uri.equal siac.id));
  let reject me id =
    `O [("@context", `String As2_vocab.Constants.ActivityStreams.ns_as);
        ("type",     `String "Reject");
        ("actor",    `String (me |> Http.reso ~base |> Uri.to_string));
        ("object",   `String (id |> Uri.to_string))]
  in
  let id = match j with
    | `O (_ :: ("id", `String id) :: _) -> id |> Uri.of_string
    | _                                 -> Uri.empty in
  id
  |> reject me
  |> send ~success:`Unprocessable_entity ~key
    (fun _ -> Logr.info (fun m -> m "%s.%s Reject %a due to fallthrough to %a" "Ap" "snd_reject" Uri.pp id Uri.pp siac.inbox))
    siac.inbox

(** re-used for following as well (there using block, too) *)
module Followers = struct
  (** follower tri-state *)
  module State = struct
    (** Tri-state *)
    type t =
      | Pending
      | Accepted
      | Blocked

    let of_string = function
      | "pending"  -> Some Pending
      | "accepted" -> Some Accepted
      | "blocked"  -> Some Blocked
      | _ -> None
    let to_string = function
      | Pending  -> "pending"
      | Accepted -> "accepted"
      | Blocked  -> "blocked"
    let predicate ?(invert = false) (s : t) =
      let r = match s with
        | Pending
        | Accepted -> true
        | Blocked  -> false in
      if invert
      then not r
      else r

    (** Rich follower state info:

        state, timestamp, actor id, name, rfc7565, inbox
    *)
    type t' = t * Ptime.t * Uri.t * string option * Rfc7565.t option * Uri.t option

    let ibox (_,_,ibox,_,_,_ : t') : Uri.t = ibox
    (** input to fold_left *)
    let ibox' f a (k,v) = f a (k,v |> ibox)

    let of_actor tnow st (siac : As2_vocab.Types.actor) : t' =
      let us = match Uri.host siac.id, siac.preferred_username with
        | None,_
        | _,None             -> None
        | Some domain, Some local -> Some Rfc7565.(make ~local ~domain ()) in
      (st,tnow,siac.inbox,siac.name,us,List.nth_opt siac.icon 0)

    let decode = function
      | Csexp.(List [Atom "1"; Atom s; Atom t0; Atom inbox; Atom name; Atom rfc7565; Atom avatar]) ->
        Option.bind
          (s |> of_string)
          (fun s ->
             match t0 |> Ptime.of_rfc3339 with
             | Ok (t,_,_) ->
               let inbox = inbox |> Uri.of_string
               and rfc7565 = rfc7565 |> Rfc7565.of_string |> Result.to_option
               and avatar = avatar |> Uri.of_string in
               let r : t' = (s,t,inbox,Some name,rfc7565,Some avatar) in
               Some r
             | _ -> None )

      (* legacy: *)
      (* assume the preferred_username is @ attached to the inbox *)
      | Csexp.(List [Atom s; Atom t0; Atom inbox]) ->
        Option.bind
          (s |> of_string)
          (fun s ->
             match t0 |> Ptime.of_rfc3339 with
             | Ok (t,_,_) ->
               let inbox = inbox |> Uri.of_string in
               let us = Option.bind
                   (inbox |> Uri.user)
                   (fun local -> Some Rfc7565.(make ~local ~domain:(inbox |> Uri.host_with_default ~default:"-") ())) in
               let r : t' = (s,t,Uri.with_userinfo inbox None,inbox |> Uri.user,us,None) in
               Some r
             | _ -> None)
      | _ -> None
    let decode' = function
      | Ok s -> s |> decode
      | _ -> None
    let encode ((state,t,inbox,name,(us : Rfc7565.t option) ,avatar) : t') =
      (* attach the preferred_username to the inbox *)
      let state  = state |> to_string in
      let t0     = t     |> Ptime.to_rfc3339 in
      let inbox  = inbox |> Uri.to_string in
      let name   = name  |> Option.value ~default:"" in
      let avatar = avatar
                   |> Option.value ~default:Uri.empty
                   |> Uri.to_string in
      let rfc7565 = Option.bind us
          (fun l -> Some (l |> Rfc7565.to_string))
                    |> Option.value ~default:"" in
      Csexp.(List [Atom "1"; Atom state; Atom t0; Atom inbox; Atom name; Atom rfc7565; Atom avatar])

    let is_accepted = function
      | None                      -> As2.No_p_yes.No
      | Some (Accepted,_,_,_,_,_) -> As2.No_p_yes.Yes
      | Some (Blocked ,_,_,_,_,_) -> As2.No_p_yes.No
      | Some (Pending ,_,_,_,_,_) -> As2.No_p_yes.Pending

    let is_blocked  = function
      | None                      -> As2.No_p_yes.No
      | Some (Accepted,_,_,_,_,_) -> As2.No_p_yes.No
      | Some (Blocked ,_,_,_,_,_) -> As2.No_p_yes.Yes
      | Some (Pending ,_,_,_,_,_) -> As2.No_p_yes.No
  end

  let fold_left (fkt : 'a -> (Uri.t * State.t') -> 'a) =
    let kv f a (k,v) = f a
        (k |> Bytes.to_string |> Uri.of_string
        ,v |> Bytes.to_string |> Csexp.parse_string |> State.decode') in
    let opt f a = function
      | (k,None)   -> Logr.warn (fun m -> m "%s.%s ignored actor %a" "Ap.Followers" "fold_left" Uri.pp k);
        a
      | (k,Some v) -> f a (k,v) in
    (* caveat, this folding really looks reverse: *)
    fkt |> opt |> kv |> Mcdb.fold_left

  let cdb = Mcdb.Cdb "app/var/db/subscribers.cdb"

  let find
      ?(cdb = cdb)
      id : State.t' option =
    assert (id |> Uri.user |> Option.is_none);
    let ke = id |> Uri.to_string in
    Option.bind
      (Mcdb.find_string_opt ke cdb)
      (fun s -> s |> Csexp.parse_string |> State.decode')

  let update ?(cdb = cdb) id v =
    assert (id |> Uri.user |> Option.is_none);
    Mcdb.update_string (id |> Uri.to_string) (v |> State.encode |> Csexp.to_string) cdb

  (** remove from cdb *)
  let remove ?(cdb = cdb) id =
    assert (id |> Uri.user |> Option.is_none);
    Mcdb.remove_string (id |> Uri.to_string) cdb

  let is_in_subscribers ?(cdb = cdb) id =
    assert (id |> Uri.user |> Option.is_none);
    id
    |> find ~cdb
    |> State.is_accepted

  (** https://www.rfc-editor.org/rfc/rfc4287#section-4.1.1 *)
  module Atom = struct
    (** create all from oldest to newest and return newest file name. *)
    let of_cdb
        ?(cdb = cdb)
        ?(predicate = State.predicate ~invert:false)
        ~base
        ~title
        ~xsl
        ~rel
        ?(page_size = 50)
        dir =
      Logr.debug (fun m -> m "%s.%s %s" "Ap.Followers.Atom" "of_cdb" dir);
      let predicate (s,_,_,_,_,_ : State.t') = s |> predicate in
      (** write one page of a paged xml feed *)
      let flush_page_xml ~is_last (u,p,i) =
        let _ = is_last
        and _ : (Uri.t * State.t') list = u in
        assert (0 <= p);
        assert (dir |> St.is_suffix ~affix:"/");
        let fn = Printf.sprintf "%s%d.xml" dir p in
        Logr.debug (fun m -> m "%s.%s %s" "Ap.Followers.Atom" "of_cdb.flush" dir);
        assert (u |> List.length = i);

        let open Xml in
        let mk_rel rel i =
          let path,title = match rel with
            | Rfc4287.Link.(Rel (Single "first")) ->
              assert (i == -1);
              ".",Some "last"
            | _ ->
              assert (i >= 0);
              Printf.sprintf "%d.xml" i,
              Some (Printf.sprintf "%i" (i+1))
          and rel = Some rel in
          Rfc4287.Link.(Uri.make ~path () |> make ~rel ~title |> to_atom)
        in
        let self  = mk_rel Rfc4287.Link.self p in
        let first = mk_rel Rfc4287.Link.first (-1) in
        let last  = mk_rel Rfc4287.Link.last 0 in
        let prev  = mk_rel Rfc4287.Link.prev (succ p) in
        let add_next i l = match i with
          | 0 -> l
          | i -> sep 1 :: mk_rel Rfc4287.Link.next (pred i) :: l in
        let id_s = Printf.sprintf "%i.xml" p in
        let xml : _ Xmlm.frag =
          `El (((ns_a, "feed"), [
              ((Xmlm.ns_xmlns, "xmlns"), ns_a);
              ((Xmlm.ns_xml, "base"), base |> Uri.to_string);
            ]),
               sep 1
               :: `El (((ns_a,"title"), []), [`Data title]) :: sep 1
               :: `El (((ns_a,"id"), []), [`Data id_s ])
               :: sep 1 :: self
               :: sep 1 :: first
               :: sep 1 :: last
               :: sep 1 :: prev
               :: (u
                   |> List.rev
                   |> List.fold_left
                     (fun init (href,(_,_,_,title,us,_unused_icon)) ->
                        let href = Uri.with_userinfo href None in
                        let rfc7565 = Option.bind us
                            (fun us -> Some (us |> Rfc7565.to_string)) in
                        sep 1
                        :: Rfc4287.Link.(make ~rel ~title ~rfc7565 href |> to_atom)
                        :: init)
                     [`Data "\n"]
                   |> add_next p) )
        in
        fn |> File.out_channel_replace (Xml.to_chan ~xsl xml);
        Ok fn in
      (** fold a filtered list cdb into paged xml files *)
      fold_left (fun (l,p,i as init) (href,st as k) ->
          if st |> predicate
          then (
            Logr.debug (fun m -> m "%s.%s %a" "Ap.Followers.Atom" "of_cdb.fold_left" Uri.pp href);
            let i = succ i in
            if i > page_size
            then
              let _ = (l,p,i-1) |> flush_page_xml ~is_last:false in
              k :: [],p+1,1
            else
              k :: l,p,i)
          else
            init)
        ([],0,0) cdb
      |> flush_page_xml ~is_last:true

    let dir = apub ^ "subscribers/"
    let target = dir ^ "index.xml"

    let rule : Make.t = {
      target;
      prerequisites = PersonX.rule.target
                      :: (cdb |> (fun (Mcdb.Cdb v) -> v))
                      :: [];
      fresh         = Make.Outdated;
      command       = fun _pre _ _ _ ->
        let* base = Cfg.Base.(from_file fn) in
        of_cdb
          ~cdb
          ~base
          ~title:"📣 Subscribers"
          ~xsl:(Rfc4287.xsl "subscribers.xsl" target)
          ~rel:(Some Rfc4287.Link.subscribers)
          ~page_size:50
          dir
    }

    let make = Make.make [rule]
  end

  (** https://www.w3.org/TR/activitypub/#followers *)
  module Json = struct
    let to_page ~is_last (i : int) (fs : Uri.t list) : Uri.t As2_vocab.Types.collection_page =
      let p i =
        let path = i |> Printf.sprintf "%d.jsa" in
        Uri.make ~path () in
      let self = p i in
      let next = if i > 0
        then Some (p (pred i))
        else None in
      let prev = if not is_last
        then Some (p (succ i))
        else None in
      {
        id         = self;
        current    = Some self;
        first      = None;
        is_ordered = true;
        items      = fs;
        last       = Some (p 0);
        next;
        part_of    = Some (Uri.make ~path:"index.jsa" ());
        prev;
        total_items= None;
      }

    (** write one page of an https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollection *)
    let to_page_json ~base _prefix ~is_last (i : int) (ids : Uri.t list) =
      to_page ~is_last i ids
      |> As2_vocab.Encode.(collection_page ~base (uri ~base))

    (** dehydrate into https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollection
        and https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollectionpage
        dst afterwards contains an
        index.jsa
        index-0.jsa
        ...
        index-n.jsa
    *)
    let flush_page_json ~base ~oc prefix ~is_last (tot,pa,lst,_) =
      let fn j = j |> Printf.sprintf "%d.jsa" in
      Logr.debug (fun m -> m "%s.%s lst#%d" "Ap.Followers" "flush_page" (lst |> List.length));
      let js = lst |> List.rev |> to_page_json ~base prefix ~is_last pa in
      (prefix ^ (fn pa)) |> File.out_channel_replace (fun ch -> Ezjsonm.value_to_channel ~minify:false ch js);
      (if is_last
       then
         let p i =
           let path = fn i in
           Uri.make ~path () in
         let c : Uri.t As2_vocab.Types.collection =
           { id          = Uri.make ~path:"index.jsa" ();
             current     = None;
             first       = Some (p pa);
             is_ordered  = true;
             items       = Some [];
             last        = Some (p 0);
             total_items = Some tot;
           } in
         c
         |> As2_vocab.Encode.(collection ~base (uri ~base))
         |> Ezjsonm.value_to_channel ~minify:false oc)

    (** paging logic *)
    let fold2pages pagesize flush_page (tot,pa,lst,i) id =
      Logr.debug (fun m -> m "%s.%s %a" "Ap.Followers" "fold2pages" Uri.pp id );
      if i >= pagesize
      then (
        flush_page ~is_last:false (tot,pa,lst,i);
        (tot |> succ,pa |> succ,id :: [],0)
      ) else
        (tot |> succ,pa,id :: lst,i |> succ)

    (** dehydrate the cdb (e.g. followers list) into the current directory

        uses fold2pages & flush_page_json
    *)
    let coll_of_cdb
        ~base
        ~oc
        ?(pagesize = 100)
        ?(predicate = State.predicate ~invert:false)
        prefix cdb =
      assert (0 < pagesize && pagesize < 10_001);
      (* Logr.debug (fun m -> m "%s.%s %d %a" "Ap.Followers" "cdb2coll" pagesize Uri.pp base ); *)
      let base = Http.reso ~base (Uri.make ~path:prefix ()) in
      let* res = fold_left (fun a (k,(s,_,_,_,_,_)) ->
          match a with
          | Error _ as e ->
            Logr.err (fun m -> m "%s %s.%s foohoo" E.e1008 "Ap.Followers" "coll_of_cdb");
            e
          | Ok ctx ->
            Ok (if s |> predicate
                then k |> fold2pages pagesize (flush_page_json ~base ~oc prefix) ctx
                else (
                  Logr.debug (fun m -> m "%s.%s ignored %a" "Ap.Followers" "coll_of_cdb.fold_left" Uri.pp k);
                  ctx) (* just go on *) )
        ) (Ok (0,0,[],0)) cdb in
      flush_page_json ~base prefix ~oc ~is_last:true res;
      Ok (prefix ^ "index.jsa")

    let dir = apub ^ "subscribers/"
    let target = dir ^ "index.jsa"

    let rule = {Atom.rule
                with
                 target;
                 prerequisites = Person.rule.target
                                 :: (cdb |> (fun (Mcdb.Cdb v) -> v))
                                 :: [];
                 command = fun _pre _ _ ->
                   File.out_channel_replace (fun oc ->
                       let* base = Cfg.Base.(from_file fn) in
                       coll_of_cdb ~base ~oc dir cdb)
               }
    let make = Make.make [rule]
  end

  let span_follow = 92 * 24 * 60 * 60 |> Ptime.Span.of_int_s

  (* notify the follower (uri) and do the local effect *)
  let snd_accept
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~base
      ~key
      ?(cdb = cdb)
      me
      (siac : As2_vocab.Types.actor)
      (fo : As2_vocab.Types.follow) =
    Logr.warn(fun m -> m "%s.%s %a %a" "Ap.Followers" "snd_accept" Uri.pp fo.actor Uuidm.pp uuid);
    assert (not (me |> Uri.equal fo.actor));
    let end_time = Ptime.(span_follow |> add_span tnow) in
    assert (fo.actor  |> Uri.user |> Option.is_none);
    let side_ok _ =
      let _ = State.of_actor tnow Accepted siac
              |> update ~cdb fo.actor
      in
      let _ = Make.make [Json.rule] Json.target in
      let _ = Atom.(make target) in
      () in
    match Option.bind
            (let ke = fo.actor |> Uri.to_string in
             Mcdb.find_string_opt ke cdb)
            (fun s -> s |> Csexp.parse_string |> State.decode') with
    | None ->
      (* Immediately accept *)
      let msg = ({
          id        = fo.id;
          actor     = me;
          obj       = fo;
          published = Some tnow;
          end_time;
        } : As2_vocab.Types.follow As2_vocab.Types.accept)
                |> As2_vocab.Encode.(accept (follow ~base)) ~base in
      send ~key side_ok siac.inbox msg
    | Some (Accepted,tnow,_,_,_,_)
    | Some (Pending,tnow,_,_,_,_) ->
      let msg =  ({
          id        = fo.id;
          actor     = me;
          obj       = fo;
          published = Some tnow;
          end_time;
        } : As2_vocab.Types.follow As2_vocab.Types.accept)
                 |> As2_vocab.Encode.(accept (follow ~base)) ~base in
      send ~key side_ok siac.inbox msg
    | Some (Blocked,_,_tnow,_,_,_) -> Lwt.return (Http.s403 ())

  (* do the local effect *)
  let snd_accept_undo
      ?(tnow = Ptime_clock.now ())
      ?(cdb = cdb)
      ~uuid
      ~base
      ~key
      me
      (siac : As2_vocab.Types.actor)
      (ufo : As2_vocab.Types.follow As2_vocab.Types.undo) =
    Logr.warn(fun m -> m "%s.%s %a %a" "Ap.Follower" "snd_accept_undo" Uri.pp ufo.obj.actor Uuidm.pp uuid);
    assert (not (me |> Uri.equal ufo.actor));
    assert (ufo.actor |> Uri.equal ufo.obj.actor );
    assert (ufo.actor |> Uri.equal siac.id);
    let _ = remove ~cdb ufo.actor in
    let _ = Json.(make target) in
    let _ = Atom.(make target) in
    let side_ok _ = () (* noop *) in
    ({
      id        = ufo.id;
      actor     = me;
      obj       = ufo;
      published = Some tnow;
      end_time  = None;
    } : As2_vocab.Types.follow As2_vocab.Types.undo As2_vocab.Types.accept)
    |> As2_vocab.Encode.(accept ~base (undo ~base (follow ~base)))
    |> send ~key side_ok siac.inbox
end

(** Logic for https://www.w3.org/TR/activitypub/#following *)
module Following = struct
  let n = "subscribed_to"
  let cdb = Mcdb.Cdb ("app/var/db/" ^ n ^ ".cdb")

  let find ?(cdb = cdb) = Followers.find ~cdb
  let remove ?(cdb = cdb) = Followers.remove ~cdb
  let update ?(cdb = cdb) = Followers.update ~cdb

  (** lists whom I subscribed to *)
  module Subscribed_to = struct
    let dir = apub ^ n ^ "/"

    (** Mostly delegates to Followers.Atom.of_cdb  *)
    module Atom = struct
      let target = dir ^ "index.xml"

      let rule : Make.t = {
        target;
        prerequisites = PersonX.rule.target
                        :: (cdb |> (fun (Mcdb.Cdb v) -> v))
                        :: [];
        fresh         = Make.Outdated;
        command       = fun _pre _ _ _ ->
          let* base = Cfg.Base.(from_file fn) in
          Followers.Atom.of_cdb
            ~cdb
            ~base
            ~title:"👂 Subscribed to"
            ~xsl:(Rfc4287.xsl "subscribed_to.xsl" target)
            ~rel:(Some Rfc4287.Link.subscribed_to)
            ~page_size:50 dir
      }
    end

    (** Mostly delegates to Followers.Json.coll_of_cdb *)
    module Json = struct
      let target = dir ^ "index.jsa"

      let rule : Make.t = {
        target;
        prerequisites = Person.rule.target
                        :: (cdb |> (fun (Mcdb.Cdb v) -> v))
                        :: [];
        fresh         = Make.Outdated;
        command       = fun _pre _ _ ->
          File.out_channel_replace (fun oc ->
              let* base = Cfg.Base.(from_file fn) in
              Followers.Json.coll_of_cdb ~base ~oc dir cdb)
      }
    end
  end

  let am_subscribed_to ?(cdb = cdb) id =
    assert (id |> Uri.user |> Option.is_none);
    id
    |> find ~cdb
    |> Followers.State.is_accepted

  (** lists whom I block *)
  module Blocked = struct
    let dir = apub ^ "blocked" ^ "/"

    (** Mostly delegates to Followers.Atom.of_cdb  *)
    module Atom = struct
      let target = dir ^ "index.xml"

      let rule : Make.t = {
        target;
        prerequisites = PersonX.rule.target
                        :: (cdb |> (fun (Mcdb.Cdb v) -> v))
                        :: [];
        fresh         = Make.Outdated;
        command       = fun _pre _ _ _ ->
          let* base = Cfg.Base.(from_file fn) in
          Followers.Atom.of_cdb
            ~cdb
            ~predicate:Followers.State.(predicate ~invert:true)
            ~base
            ~title:"🤐 Blocked"
            ~xsl:(Rfc4287.xsl "blocked.xsl" target)
            ~rel:(Some Rfc4287.Link.blocked)
            ~page_size:50 dir
      }
    end

    (** Mostly delegates to Followers.Json.coll_of_cdb *)
    module Json = struct
      let target = dir ^ "index.jsa"

      let rule : Make.t = {
        target;
        prerequisites = Person.rule.target
                        :: (cdb |> (fun (Mcdb.Cdb v) -> v))
                        :: [];
        fresh         = Make.Outdated;
        command       = fun _pre _ _ ->
          File.out_channel_replace (fun oc ->
              let* base = Cfg.Base.(from_file fn) in
              Followers.Json.coll_of_cdb
                ~predicate:Followers.State.(predicate ~invert:true)
                ~base ~oc dir cdb)
      }
    end
  end

  let is_blocked ?(cdb = cdb) id =
    assert (id |> Uri.user |> Option.is_none);
    id
    |> find ~cdb
    |> Followers.State.is_blocked

  let make ?(tnow = Ptime_clock.now ())  ~me ~inbox reac : As2_vocab.Activitypub.Types.follow =
    assert (not (me |> Uri.equal reac));
    let _ = inbox
    and end_time = Ptime.(Followers.span_follow |> add_span tnow) in
    {
      id       = Uri.with_fragment me (Some "subscribe");
      actor    = me;
      cc       = [];
      end_time;
      object_  = reac;
      state    = None;
      to_      = [];
    }

  let undo ~me (o : As2_vocab.Types.follow) : As2_vocab.Types.follow As2_vocab.Types.undo =
    assert (not (me |> Uri.equal o.object_));
    assert (me |> Uri.equal o.actor );
    {
      id       = Uri.with_fragment o.id (Some "subscribe#undo");
      actor    = me;
      obj      = o;
      published= None;
    }

  let rcv_accept
      ?(tnow = Ptime_clock.now ())
      ?(subscribed_to = cdb)
      ~uuid
      ~base
      me
      (siac : As2_vocab.Types.actor)
      (fo : As2_vocab.Types.follow) =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Following" "rcv_accept" Uuidm.pp uuid Uri.pp fo.object_);
    assert (siac.id |> Uri.equal fo.object_);
    assert (not (me |> Uri.equal siac.id));
    (* assert (me |> Uri.equal fo.actor);
       assert (not (fo.actor |> Uri.equal fo.object_)); *)
    Logr.warn (fun m -> m "%s.%s TODO only take those that I expect" "Ap.Following" "accept");
    let _ = fo.end_time in
    let _ = base in
    let _ = Followers.State.(of_actor tnow Accepted siac)
            |> update ~cdb:subscribed_to siac.id in
    let _ = Subscribed_to.Json.(Make.make [rule] target) in
    let _ = Subscribed_to.Atom.(Make.make [rule] target) in
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "created")
    |> Lwt.return
end

let rcv_reject
    ?(tnow = Ptime_clock.now ())
    ~uuid
    ~base
    (siac : As2_vocab.Types.actor)
    o =
  Logr.debug (fun m -> m "%s.%s %a %a" "Ap" "rcv_reject" Uri.pp siac.id Uuidm.pp uuid);
  let _ = tnow
  and _ = base
  in
  (match o with
   | `Follow (fo : As2_vocab.Types.follow) ->
     Logr.info (fun m -> m "%s.%s Follow request rejected by %a" "Ap" "rcv_reject" Uri.pp fo.object_);
     let _ = Following.remove fo.object_ in
     let _ = Following.Subscribed_to.Json.(Make.make [rule] target) in
     let _ = Following.Subscribed_to.Atom.(Make.make [rule] target) in
     (* @TODO: add a notification to the timeline? *)
     Ok (`OK, [Http.H.ct_plain], Cgi.Response.body "ok")
   | _ ->
     Logr.err (fun m -> m "%s.%s TODO" "Ap" "rcv_reject");
     Http.s501)
  |> Lwt.return

module Note = struct
  let empty = ({
      id          = Uri.empty;
      agent       = None;
      attachment  = [];
      attributed_to = Uri.empty;
      cc          = [];
      content_map = [];
      in_reply_to = [];
      reaction_inbox = None;
      media_type  = (Some Http.Mime.text_html); (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
      published   = None;
      sensitive   = false;
      source      = None;
      summary_map = [];
      tags        = [];
      to_         = [];
      url         = [];
    } : As2_vocab.Types.note)

  let actor_from_author _author =
    Uri.make ~path:proj ()

  let followers actor =
    Uri.make ~path:"subscribers/index.jsa" () |> Http.reso ~base:actor

  let of_rfc4287
      ?(to_ = [As2_vocab.Constants.ActivityStreams.public])
      (e : Rfc4287.Entry.t)
    : As2_vocab.Types.note =
    Logr.debug (fun m -> m "%s.%s %a" "Ap.Note" "of_rfc4287" Uri.pp e.id);
    let tag init (lbl,term,base) =
      let ty = `Hashtag in
      let open Rfc4287.Category in
      let Label (Single name) = lbl
      and Term (Single term) = term in
      let path = term ^ "/" in
      let href = Uri.make ~path () |> Http.reso ~base  in
      let ta : As2_vocab.Types.tag = {ty; name; href} in
      ta :: init
    in
    let id = e.id in
    let actor = actor_from_author e.author in
    let cc = [actor |> followers] in
    let Rfc3339.T published = e.published in
    let published = match published |> Ptime.of_rfc3339 with
      | Ok (t,_,_) -> Some t
      | _ -> None  in
    let tags = e.categories |> List.fold_left tag [] in
    let Rfc4287.Rfc4646 lang = e.lang in
    let summary_map = [lang,e.title] in
    let content_map = [lang,e.content] in
    let url = e.links |> List.fold_left (
        (* sift, use those without a rel *)
        fun i (l : Rfc4287.Link.t) ->
          match l.rel with
          | None   -> l.href :: i
          | Some _ -> i) [] in
    {empty with
     id;
     content_map;
     attributed_to = actor;
     cc;
     media_type = Some Http.Mime.text_plain;
     published;
     summary_map;
     tags;
     to_;
     url;
    }

  let to_rfc4287 ~tz ~now (n : As2_vocab.Types.note) : Rfc4287.Entry.t =
    let _ = tz
    and _ = now in
    Logr.debug (fun m -> m "%s.%s %a" "Ap.Note" "to_rfc4287" Uri.pp n.id);
    let published = n.published |> Option.value ~default:now |> Rfc3339.of_ptime ~tz
    and author    = {Rfc4287.Person.empty with
                     name = (match n.attributed_to |> Uri.user with
                         | None   -> n.attributed_to |> Uri.to_string
                         | Some u -> u );
                     uri = Some n.attributed_to} in
    let a (s,_,_) = s in
    let (lang,cont) = n.content_map |> List.hd in
    let sum = try let _,s = n.summary_map |> List.hd in
        Some s
      with Failure _ -> None in
    let links = match n.reaction_inbox with
      | None -> []
      | Some ib -> [Rfc4287.Link.(make ~rel:(Some inbox) ib )]
    in
    {Rfc4287.Entry.empty with
     id           = n.id;
     author;
     lang         = Rfc4287.Rfc4646 lang;
     title        = sum |> Option.value ~default:"" |> Html.to_plain |> a;
     content      = cont |> Html.to_plain |> a;
     published;
     links;
     updated      = published;
     in_reply_to  = n.in_reply_to |> List.map Rfc4287.Inreplyto.make;
    }

  (** Not implemented yet *)
  let plain_to_html s : string =
    (* care about :
     * - newlines
     * - urls
     * - tags
     * - mentions
    *)
    s

  let html_to_plain _s =
    failwith "not implemented yet."

  let sensitive_marker = "⚠️"

  (** Turn text/plain to text/html, add set id as self url

      Mastodon interprets summary as content warning indicator. . *)
  let diluviate (n : As2_vocab.Types.note) =
    let sensitive,summary_map = n.summary_map |> List.fold_left (fun (sen,suma) (l,txt) ->
        let sen = sen || (txt |> Astring.String.is_prefix ~affix:sensitive_marker) in
        let html = txt |> plain_to_html in
        sen,(l,html) :: suma)
        (n.sensitive,[]) in
    (* add all urls before the content (in each language) *)
    let ur = n.url |> List.fold_left (fun i u ->
        let s = u |> Uri.to_string in
        Printf.sprintf "%s<a href='%s'>%s</a><br/>\n" i s s) "" in
    let content_map = n.content_map |> List.fold_left (fun init (l,co) ->
        (* if not warning, fetch summary of content language *)
        let su = match sensitive with
          | true -> ""
          | false -> match summary_map |> List.assoc_opt l with
            | None -> ""
            | Some su -> su ^ "<br/>\n" in
        let txt = su
                  ^ ur
                  ^ (if su |> String.equal "" && ur |> String.equal ""
                     then ""
                     else "<br/>\n")
                  ^ (co |> plain_to_html) in
        (l,txt) :: init) []
    in
    {n with
     content_map;
     sensitive;
     summary_map = if sensitive then summary_map else [];
     url = [n.id] }

  (** https://www.w3.org/TR/activitypub/#create-activity-outbox *)
  module Create = struct
    let make (obj : As2_vocab.Types.note) : As2_vocab.Types.note As2_vocab.Types.create =
      let frag = match obj.id |> Uri.fragment with
        | None -> Some "Create"
        | Some f -> Some (f ^ "/Create") in
      {
        id             = frag |> Uri.with_fragment obj.id;
        actor          = obj.attributed_to;
        published      = obj.published;
        to_            = obj.to_;
        cc             = obj.cc;
        direct_message = false;
        obj            = obj; (* {obj with to_ = []; cc = []}; *)
      }

    (** turn an Atom entry into an ActivityPub (Mastodon) Create Note activity. *)
    let to_json ~base n =
      let lang = As2_vocab.Constants.ActivityStreams.und in
      n
      |> of_rfc4287
      |> diluviate
      |> make
      |> As2_vocab.Encode.(create ~base ~lang (note ~base))
  end

  (** Rather use a tombstone? https://www.w3.org/TR/activitypub/#delete-activity-outbox *)
  module Delete = struct
    let make (obj : As2_vocab.Types.note) : As2_vocab.Types.note As2_vocab.Types.delete =
      let frag = match obj.id |> Uri.fragment with
        | None -> Some "Delete"
        | Some f -> Some (f ^ "/Delete") in
      {
        id             = frag |> Uri.with_fragment obj.id;
        actor          = obj.attributed_to;
        published      = obj.published; (* rather use tnow *)
        obj            = obj;
      }

    let to_json ~base n =
      n
      |> of_rfc4287
      |> make
      |> As2_vocab.Encode.(delete ~base (note ~base))
  end

  let _5381_63 = 5381 |> Optint.Int63.of_int

  (* http://cr.yp.to/cdb/cdb.txt *)
  let hash63_gen len f_get : Optint.Int63.t =
    let mask     = Optint.Int63.max_int
    and ( +. )   = Optint.Int63.add
    and ( << )   = Optint.Int63.shift_left
    and ( ^ )    = Optint.Int63.logxor
    and ( land ) = Optint.Int63.logand in
    let rec fkt (idx : int) (h : Optint.Int63.t) =
      if idx = len
      then h
      else
        let c = idx |> f_get |> Char.code |> Optint.Int63.of_int in
        (((h << 5) +. h) ^ c) land mask
        |> fkt (succ idx)
    in
    fkt 0 _5381_63

  let hash63_str dat : Optint.Int63.t =
    hash63_gen (String.length dat) (String.get dat)

  let uhash ?(off = 0) ?(buf = Bytes.make (Optint.Int63.encoded_size) (Char.chr 0)) u =
    u
    |> Uri.to_string
    |> hash63_str
    |> Optint.Int63.encode buf ~off;
    buf
    |> Bytes.to_string
    |> Base64.encode_string ~pad:false ~alphabet:Base64.uri_safe_alphabet

  let ibc_dir = "app/var/cache/inbox/"

  (** not just Note *)
  let to_file ~msg_id ~prefix ~dir json =
    let fn = msg_id
             |> uhash
             |> Printf.sprintf "%s%s.json" prefix in
    let tmp = dir ^ "tmp/" ^ fn in
    (dir ^ "new/" ^ fn) |> File.out_channel_create ~tmp
      (fun oc ->
         json
         |> Ezjsonm.value_to_channel oc)

  let do_cache
      ?(tnow = Ptime_clock.now ())
      ?(dir = ibc_dir)
      ~(base : Uri.t)
      (a : As2_vocab.Types.note As2_vocab.Types.create) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Note" "do_cache" Uri.pp a.id);
    assert (a.actor |> Uri.user |> Option.is_some);
    assert (a.obj.attributed_to |> Uri.user |> Option.is_some);
    a
    |> As2_vocab.Encode.(create ~base (note ~base))
    |> to_file ~msg_id:a.id ~prefix:"note-" ~dir

  let do_cache'
      ?(tnow = Ptime_clock.now ())
      ?(dir = ibc_dir)
      ~(base : Uri.t)
      (a : As2_vocab.Types.note As2_vocab.Types.update) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Note" "do_cache'" Uri.pp a.id);
    assert (a.actor |> Uri.user |> Option.is_some);
    assert (a.obj.attributed_to |> Uri.user |> Option.is_some);
    a
    |> As2_vocab.Encode.(update ~base (note ~base))
    |> to_file ~msg_id:a.id ~prefix:"note-" ~dir

  let rcv_create
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~(base : Uri.t)
      (siac : As2_vocab.Types.actor)
      (a : As2_vocab.Types.note As2_vocab.Types.create) : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Note" "rcv_create" Uri.pp a.obj.attributed_to Uuidm.pp uuid);
    assert (a.actor |> Uri.equal siac.id);
    assert (a.actor |> Uri.equal a.obj.attributed_to);
    let actor = siac.preferred_username |> Uri.with_userinfo a.actor in
    let attributed_to = siac.preferred_username |> Uri.with_userinfo a.obj.attributed_to in
    let a = {a with actor} in
    let a = {a with obj = {a.obj with attributed_to}} in
    let _ = do_cache ~tnow ~base a in
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "create")
    |> Lwt.return

  let rcv_update
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~(base : Uri.t)
      (siac : As2_vocab.Types.actor)
      (a : As2_vocab.Types.note As2_vocab.Types.update) : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Note" "rcv_update" Uri.pp a.obj.attributed_to Uuidm.pp uuid);
    assert (a.actor |> Uri.equal siac.id);
    assert (a.actor |> Uri.equal a.obj.attributed_to);
    let actor = siac.preferred_username |> Uri.with_userinfo a.actor in
    let attributed_to = siac.preferred_username |> Uri.with_userinfo a.obj.attributed_to in
    let a = {a with actor} in
    let a = {a with obj = {a.obj with attributed_to}} in
    let _ = do_cache' ~tnow ~base a in
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "update")
    |> Lwt.return

end

module Like = struct
  let do_cache
      ?(tnow = Ptime_clock.now ())
      ?(dir = Note.ibc_dir)
      ~(base : Uri.t)
      (a : As2_vocab.Types.like) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Like" "do_cache" Uri.pp a.id);
    assert (a.actor |> Uri.user |> Option.is_some);
    a
    |> As2_vocab.Encode.like ~base
    |> Note.to_file ~msg_id:a.id ~prefix:"like-" ~dir

  let do_cache'
      ?(tnow = Ptime_clock.now ())
      ?(dir = Note.ibc_dir)
      ~(base : Uri.t)
      (a : As2_vocab.Types.like As2_vocab.Types.undo) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Like" "do_cache'" Uri.pp a.id);
    assert (a.actor |> Uri.user |> Option.is_some);
    a
    |> As2_vocab.Encode.(undo ~base (like ~base))
    |> Note.to_file ~msg_id:a.id ~prefix:"like-" ~dir

  let rcv_like
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~(base : Uri.t)
      (siac : As2_vocab.Types.actor)
      (a : As2_vocab.Types.like) : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Like" "rcv_like" Uri.pp a.actor Uuidm.pp uuid);
    assert (a.actor |> Uri.equal siac.id);
    let actor = Uri.with_userinfo a.actor siac.preferred_username in
    let a = {a with actor} in
    let _ = do_cache ~tnow ~base a in
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "like")
    |> Lwt.return

  let rcv_like_undo
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~(base : Uri.t)
      (siac : As2_vocab.Types.actor)
      (a : As2_vocab.Types.like As2_vocab.Types.undo) : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Like" "rcv_like_undo" Uri.pp a.actor Uuidm.pp uuid);
    assert (a.actor |> Uri.equal siac.id);
    let actor = Uri.with_userinfo a.actor siac.preferred_username in
    let a = {a with actor} in
    let _ = do_cache' ~tnow ~base a in
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "like")
    |> Lwt.return
end

module Announce = struct
  let do_cache
      ?(tnow = Ptime_clock.now ())
      ?(dir = Note.ibc_dir)
      ~base
      (a : As2_vocab.Types.announce) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Announce" "do_cache" Uri.pp a.id);
    assert (a.actor |> Uri.user |> Option.is_some);
    a
    |> As2_vocab.Encode.announce ~base
    |> Note.to_file ~msg_id:a.id ~prefix:"anno-" ~dir

  let do_cache'
      ?(tnow = Ptime_clock.now ())
      ?(dir = Note.ibc_dir)
      ~base
      (a : As2_vocab.Types.announce As2_vocab.Types.undo) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Announce" "do_cache'" Uri.pp a.id);
    assert (a.actor |> Uri.user |> Option.is_some);
    a
    |> As2_vocab.Encode.(undo ~base (announce ~base))
    |> Note.to_file ~msg_id:a.id ~prefix:"anno-" ~dir

  let rcv_announce
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~base
      (siac : As2_vocab.Types.actor)
      (a : As2_vocab.Types.announce) : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Announce" "rcv_announce" Uri.pp a.actor Uuidm.pp uuid);
    assert (a.actor |> Uri.equal siac.id);
    let actor = Uri.with_userinfo a.actor siac.preferred_username in
    {a with actor} |> do_cache ~tnow ~base;
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "announce")
    |> Lwt.return

  let rcv_announce_undo
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~(base : Uri.t)
      (siac : As2_vocab.Types.actor)
      (a : As2_vocab.Types.announce As2_vocab.Types.undo) : Cgi.Response.t' Lwt.t =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Announce" "rcv_announce_undo" Uri.pp a.actor Uuidm.pp uuid);
    assert (a.actor |> Uri.equal siac.id);
    let actor = Uri.with_userinfo a.actor siac.preferred_username in
    {a with actor} |> do_cache' ~tnow ~base;
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "announce")
    |> Lwt.return
end