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 cgi' = Cfg.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

module PubKeyPem = struct
  let of_pem s =
    match s
          |> Cstruct.of_string
          |> X509.Public_key.decode_pem with
    | Ok (`RSA _) as k -> k
    | Ok _             -> Error (`Msg "public key must be RSA")
    | e                -> e

  let check (`RSA k) =
    Logr.warn (fun m -> m "@TODO PubKeyPem.check." );
    Ok (`RSA k)

  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' (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
            |> Cstruct.to_bytes
            |> output_bytes 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' (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
                |> Cstruct.of_string
                |> X509.Private_key.decode_pem
              with
              | Ok (`RSA _ as key) ->
                key
                |> X509.Private_key.public
                |> X509.Public_key.encode_pem
                |> Cstruct.to_bytes
                |> output_bytes 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

  let private_of_pem fn_priv =
    fn_priv
    |> File.to_bytes
    |> Cstruct.of_bytes
    |> private_of_pem_data

  let sign pk (data : Cstruct.t) : (string * Cstruct.t) =
    (* 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
     *)
    let scheme = `RSA_PKCS1 in
    ("rsa-sha256",
     X509.Private_key.sign
       `SHA256
       ~scheme
       pk
       (`Message data)
     |> Result.get_ok)

  let verify ~uuid ?(key = Uri.empty) ~algo pubkey signature data =
    match algo with
    | "rsa-sha256" -> (
        let scheme = `RSA_PKCS1 in
        match X509.Public_key.verify
                `SHA256
                ~scheme
                ~signature
                pubkey
                (`Message data) with
        | Ok _ as o    ->
          Logr.debug (fun m -> m "%s.%s %s valid %a" "As2.PubKeyPem" "verify" algo Uri.pp key);
          o
        | Error  _ as e ->
          Logr.debug (fun m -> m "%s.%s %a %s invalid %a\nsig: %s\ndata: {|%s|}" "As2.PubKeyPem" "verify" Uuidm.pp uuid algo Uri.pp key "..." (data |> Cstruct.to_string));
          e)
    | a -> Error (`Msg a)

  (* not key related *)
  let digest_base64 s =
    Logr.debug (fun m -> m "%s.%s %s" "As2.PubKeyPem" "digest" "SHA-256");
    "SHA-256=" ^ (s
                  |> Cstruct.of_string
                  |> Mirage_crypto.Hash.SHA256.digest
                  |> Cstruct.to_string
                  |> Base64.encode_exn)

  let digest_base64' s =
    Some (digest_base64 s)
end

module Actor = struct
  let http_get ?(key : Http.t_sign_k option = None) 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.person
         |> Result.map_error mape
       | sta -> Format.asprintf "HTTP %s %a" (Cohttp.Code.string_of_status sta) 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 key_id sndr =
    Uri.with_fragment sndr (Some "main-key")

  let empty = ({
      id                         = Uri.empty;
      inbox                      = Uri.empty;
      outbox                     = Uri.empty;
      followers                  = None;
      following                  = None;
      attachment                 = [];
      discoverable               = false;
      generator                  = None;
      icon                       = None;
      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.person)

  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
    ({
      id                         = actor;
      inbox                      = Uri.make ~path:("../" ^ cgi' ^ "/" ^ apub ^ "inbox.jsa") () |> path;
      outbox                     = Uri.make ~path:"outbox/index.jsa" () |> path;
      followers                  = Some (Uri.make ~path:"notify/index.jsa" () |> path);
      following                  = Some (Uri.make ~path:"subscribed/index.jsa" () |> path);
      attachment                 = [];
      discoverable               = true;
      generator                  = Some {href=St.seppo_u; name=(Some St.seppo_c); name_map=[]; rel=None };
      icon                       = Some (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 |> 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.person)

  module Json = struct
    let decode j =
      j
      |> As2_vocab.Decode.person
      |> 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 context = Some l in
      prsn _pubdate (pem, (pro, (uid, base)))
      |> As2_vocab.Encode.person ~base ~context
      |> 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.person) =
    {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;
        Cfg.Profile.ban.target;
        Cfg.Profile.ava.target;
        PubKeyPem.target;
      ];
      fresh = Make.Outdated;
      command  = fun pre _ _ ->
        File.out_channel' (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 ~context ({ 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.person) : _ 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 context = context |> Option.value ~default:"und" in
      Logr.debug (fun m -> m "%s.%s %a %s" "As2.Person.RDF" "encode" Uri.pp base context);
      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, "Person"), [
          ((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"), context);
        ]), chi)

    (* Alternatively may want to take a Ap.Feder.t *)
    let encode ?(token = None) ?(notify = None) ?(subscribed = None) ?(blocked = None) ~base ~context 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_xml,"base"),base |> Uri.to_string);
        ]),
           sep 1 ::
           `El (((ns_rdf, "Description"), [
               ((Xmlm.ns_xmlns, "seppo"),  ns_seppo);
               ((ns_rdf, "about"), "");
             ]),
                sep 2 ::
                txt'   ns_seppo "token"      [] token     @
                noyes' ns_seppo "notify"     [] notify    @
                noyes' ns_seppo "subscribed" [] subscribed @
                noyes' ns_seppo "blocked"    [] blocked
             )
           :: sep 1
           :: encode' ~base ~context 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 ~context:(Some lang)
    |> Result.ok

  let target = prox

  let rule = {Person.rule
              with target;
                   command = fun pre _ _ ->
                     File.out_channel' (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

module Activity = struct
  type t = T of string

  let ty s = match s |> String.lowercase_ascii with
    | "like"    -> Ok (T "Like")
    | "dislike" -> Ok (T "Dislike")
    | _         -> Error ("Activity '" ^ s ^ "' not supported.")

  let make_like me _act _pubdate objec _remote_actor: As2_vocab.Types.like =
    {
      id       = Uri.empty;
      actor    = me;
      obj      = objec;
      published= None;
      (* to cc *)
    }

  let digest_base64 = PubKeyPem.digest_base64
  let digest_base64' = PubKeyPem.digest_base64'

  (** e.g. https://tube.network.europa.eu/w/aTx3DYwH1km2gTEn9gKpah
   *
   * $ curl -H 'accept: application/activity+json' 'https://tube.network.europa.eu/w/aTx3DYwH1km2gTEn9gKpah'
   * $ curl -H 'accept: application/activity+json' 'https://tube.network.europa.eu/accounts/edps'
  *)
  let like' pk (act_type : t) post_uri (me : As2_vocab.Types.person) : (As2_vocab.Types.uri,string) result Lwt.t  =
    let base = Uri.empty in
    let open Cohttp_lwt in
    (* we need the sender and recipient actor profiles *)
    (* https://github.com/roburio/http-lwt-client/blob/main/src/http_lwt_client.ml *)
    let post_attributed_to json =
      let extract3tries k0 k1 j =
        match Ezjsonm.find j [ k0 ] with
        | `String s -> Some s
        | `A (`String s :: _) -> Some s
        | `A ((`O _ as hd) :: _) -> (
            (* ignore 'type' *)
            match Ezjsonm.find hd [ k1 ] with
            | `String s -> Some s
            | _ -> None)
        | _ -> None
      in
      json
      |> extract3tries "attributedTo" "id"
      |> to_result (* TODO examine the http response code? *) "attribution not found"
      >>= fun v -> Ok (Uri.of_string v)
    in
    let%lwt p = Http.get_jsonv post_attributed_to post_uri in
    match p with
    | Error _ as e -> Lwt.return e
    | Ok (act_uri : Uri.t) ->
      let%lwt j = Http.get_jsonv Result.ok act_uri in
      match j >>= Person.Json.decode with
      | Error _ as e -> Lwt.return e
      | Ok pro ->
        let _ = Person.make "" in
        let date = Ptime_clock.now ()
        and sndr = me.id
        and key  = me.public_key.id
        and rcpt = pro.id
        and inbx = pro.inbox in
        let body = make_like sndr act_type date post_uri rcpt
                   |> As2_vocab.Encode.like ~base
                   |> Ezjsonm.value_to_string in
        let headers = Http.signed_headers (key,PubKeyPem.sign pk,date) (digest_base64' body) inbx in
        let headers = Http.H.add' headers Http.H.ct_json in
        let headers = Http.H.add' headers Http.H.acc_app_jlda in
        Logr.info (fun m -> m "-> http POST %a" Uri.pp inbx);
        let%lwt p = Http.post ~headers body inbx in
        match p with
        | Error _ as e -> Lwt.return e
        | Ok (_resp, body) ->
          let%lwt b = body |> Body.to_string in
          Logr.debug (fun m -> m "%s" b);
          Lwt.return (Ok post_uri)

  let like pk aty uri act =
    aty |> ty
    >>= fun v -> Ok (like' pk v uri act)
end

(*
 * https://www.w3.org/TR/activitystreams-core/
 * https://www.w3.org/TR/activitystreams-core/#media-type
 *)

let send ?(success = `OK) ~(key : Http.t_sign_k) (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")
      | _ ->
        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
     ) |> 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 rcv_reject
    ?(tnow = Ptime_clock.now ())
    ~uuid
    ~base
    (siac : As2_vocab.Types.person)
    _ =
  Logr.warn(fun m -> m "%s.%s %a %a" "Ap" "rcv_reject" Uri.pp siac.id Uuidm.pp uuid);
  let _ = tnow
  and _ = base
  and _ = siac
  in
  Lwt.return Http.s501

let snd_reject
    ~uuid
    ~base
    ~key
    me
    (siac : As2_vocab.Types.person)
    (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

module Followers = struct
  module State = struct
    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"

    type t' = t * Ptime.t * Uri.t * string option * Webfinger.Client.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.person) : t' =
      let us = match Uri.host siac.id, siac.preferred_username with
        | None,_
        | _,None             -> None
        | Some hos, Some usr -> Some Webfinger.Client.(Localpart usr, Domainpart hos) in
      (st,tnow,siac.inbox,siac.name,us,siac.icon)

    let decode = function
      | Csexp.(List [Atom "1"; Atom s; Atom t0; Atom inbox; Atom name; Atom rfc7033; Atom avatar]) ->
        Option.bind
          (s |> of_string)
          (fun s ->
             match t0 |> Ptime.of_rfc3339 with
             | Ok (t,_,_) ->
               let inbox = inbox |> Uri.of_string
               and rfc7033 = rfc7033 |> Webfinger.Client.from_string |> Result.to_option
               and avatar = avatar |> Uri.of_string in
               let r : t' = (s,t,inbox,Some name,rfc7033,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 u -> Some Webfinger.Client.(Localpart u, Domainpart (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,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 rfc7033 = Option.bind us
          (fun l -> Some (l |> Webfinger.Client.to_string))
                    |> Option.value ~default:"" in
      Csexp.(List [Atom "1"; Atom state; Atom t0; Atom inbox; Atom name; Atom rfc7033; Atom avatar])

    let to_yn ?(invert = false) (x,_,_,_,_,_ : t') : As2.No_p_yes.t option =
      match x,invert with
      | Pending ,_     -> Some As2.No_p_yes.Pending
      | Accepted,false
      | Blocked ,true  -> Some As2.No_p_yes.Yes
      | Blocked ,false
      | Accepted,true  -> Some As2.No_p_yes.No
  end


  let fold_left (fkt : 'a -> (Uri.t * State.t') -> 'a) =
    (* let _k2u f a (k,v) = f a (k |> Bytes.to_string |> Uri.of_string,v) in
       let _v2s f a (k,v) = f a (k,v |> Bytes.to_string |> Csexp.parse_string |> State.decode') in *)
    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 |> Mapcdb.fold_left

  let cdb = Mapcdb.Cdb "app/var/db/notify.cdb"

  let find_uri
      ?(cdb = cdb)
      u : State.t' option =
    let ke = u |> Uri.to_string in
    Option.bind
      (Mapcdb.find_string_opt ke cdb)
      (fun s -> s |> Csexp.parse_string |> State.decode')

  let notify ?(cdb = cdb) id =
    match find_uri ~cdb id with
    | Some s -> s |> State.to_yn
    | None   -> Some As2.No_p_yes.No

  module Atom = struct
    (* create all from oldest to newest and return newest file name. *)
    let of_cdb
        ?(cdb = cdb)
        ~title
        ~xsl
        ~rel
        ?(page_size = 50)
        dir =
      Logr.debug (fun m -> m "%s.%s" "Ap.Followers.Atom" "of_cdb");
      let flush _is_last (u,p,i) =
        let _ : (Uri.t * string option * Webfinger.Client.t option * Uri.t option) list = u in
        assert (0 <= p);
        assert (dir |> St.ends_with ~suffix:"/");
        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 (p + 1) in
        let add_next i l = match i with
          | 0 -> l
          | i -> sep 1 :: mk_rel Rfc4287.Link.next (i - 1) :: l in
        let id_s = Printf.sprintf "%i.xml" p in
        let s : _ Xmlm.frag =
          `El (((ns_a, "feed"), [ ((Xmlm.ns_xmlns, "xmlns"), ns_a) ]),
               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 i (href,title,us,_unused_icon) ->
                        let href = Uri.with_userinfo href None in
                        let rfc7033 = Option.bind us
                            (fun us -> Some (us |> Webfinger.Client.to_string)) in
                        sep 1
                        :: Rfc4287.Link.(make ~rel ~title ~rfc7033 href |> to_atom)
                        :: i)
                     [`Data "\n"]
                   |> add_next p )
              )
        in
        let mode = [Open_binary;Open_creat;Open_trunc;Open_wronly] in
        File.out_channel ~mode fn (Xml.to_chan ~xsl s);
        Ok fn in
      fold_left (fun (l,p,i) (href,((_,_,_inbox,title,us,icon) : State.t')) ->
          Logr.debug (fun m -> m "%s.%s %a" "Ap.Followers.Atom" "of_cdb.fo" Uri.pp href);
          let k = (href,title,us,icon) in
          let i = i + 1 in
          if i > page_size
          then
            (let _ = (l,p,i-1) |> flush false in
             (k :: [],p+1,1))
          else
            (k :: l,p,i))
        ([],0,0) cdb
      |> flush true

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

    let rule : Make.t = {
      target;
      prerequisites = PersonX.rule.target
                      :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
                      :: [];
      fresh         = Make.Outdated;
      command       = fun _pre _ _ _ ->
        of_cdb
          ~cdb
          ~title:"📣 Notify (Followers)"
          ~xsl:(Rfc4287.xsl "notify.xsl" target)
          ~rel:(Some Rfc4287.Link.notify)
          ~page_size:50
          dir
    }

    let make = Make.make [rule]
  end

  module Json = struct
    let to_page ~finish (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 (i - 1))
        else None in
      let prev = if not finish
        then Some (p (i + 1))
        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;
      }

    let to_page_json ~base _prefix ~finish (i : int) (ids : Uri.t list) =
      to_page ~finish 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 ~base ~oc prefix ~finish (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 ~finish pa in
      let mode = [Open_binary;Open_creat;Open_trunc;Open_wronly] in
      File.out_channel ~mode (prefix ^ (fn pa)) (fun ch -> Ezjsonm.value_to_channel ~minify:false ch js);
      (if finish
       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)

    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 ~finish:false (tot,pa,lst,i);
        (tot+1,pa+1,id :: [],0)
      ) else
        (tot+1,pa,id :: lst,i+1)

    (**
     * dehydrate the cdb (e.g. followers list) into the current directory
     *
     * uses fold2pages & flush_page
    *)
    let coll_of_cdb ~base ~oc ?(pagesize = 100) 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,v) ->
          match a with
          | Ok ctx ->
            (match v with
             | (State.Pending,_,_,_,_,_)
             | (State.Blocked,_,_,_,_,_) ->
               Logr.debug (fun m -> m "%s.%s ignored %a" "Ap.Followers" "cdb2coll.fold_left" Uri.pp k);
               Ok ctx (* just go on *)
             | (State.Accepted,_,_,_,_,_) ->
               k
               |> fold2pages pagesize (flush_page ~base ~oc prefix) ctx
               |> Result.ok )
          | e ->
            Logr.err (fun m -> m "%s %s.%s foohoo" E.e1008 "Ap.Followers" "cdb2coll");
            e) (Ok (0,0,[],0)) cdb in
      flush_page ~base prefix ~oc ~finish:true res;
      Ok (prefix ^ "index.jsa")

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

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

  (* notify the followers (uri) and do the local effect *)
  let snd_accept
      ?(tnow = Ptime_clock.now ())
      ~uuid
      ~base
      ~key
      ?(cdb = cdb)
      me
      (siac : As2_vocab.Types.person)
      (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 ke = fo.actor |> Uri.to_string in
    let side_ok _ =
      let v = State.(of_actor tnow Accepted siac |> encode) |> Csexp.to_string in
      let _ = Mapcdb.update_string ke v cdb in
      let _ = Make.make [Json.rule] Json.target in
      let _ = Atom.(make target) in
      () in
    match Option.bind
            (Mapcdb.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;
        } : As2_vocab.Types.follow As2_vocab.Types.accept)
                |> As2_vocab.Encode.(accept (follow ~context:None ~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;
        } : As2_vocab.Types.follow As2_vocab.Types.accept)
                 |> As2_vocab.Encode.(accept (follow ~context:None ~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 ())
      ~uuid
      ~base
      ~key
      me
      (siac : As2_vocab.Types.person)
      (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);
    Logr.warn(fun m -> m "%s.%s TODO persist local effects" "Ap.Followers" "undo follow");
    assert (not (me |> Uri.equal ufo.actor));
    let ke = ufo.actor |> Uri.to_string in
    let side_ok _ =
      let _ = Mapcdb.remove_string ke cdb in
      let _ = Make.make [Json.rule] Json.target in
      let _ = Atom.(make target) in
      () in
    assert (ufo.actor |> Uri.equal ufo.obj.actor );
    let msg = ({
        id        = ufo.id;
        actor     = me;
        obj       = ufo;
        published = Some tnow;
      } : As2_vocab.Types.follow As2_vocab.Types.undo As2_vocab.Types.accept)
              |> As2_vocab.Encode.(accept (undo ~context:None ~base (follow ~context:None ~base))) ~base in
    send ~key side_ok siac.inbox msg
end

module Following = struct
  let n = "subscribed"
  let cdb = Mapcdb.Cdb ("app/var/db/" ^ n ^ ".cdb")
  let dir = apub ^ n ^ "/"

  let subscribed ?(cdb = cdb) id =
    match Followers.find_uri ~cdb id with
    | Some s -> s |> Followers.State.to_yn
    | None   -> Some As2.No_p_yes.No

  let blocked ?(cdb = cdb) id =
    match Followers.find_uri ~cdb id with
    | Some s -> s |> Followers.State.to_yn ~invert:true
    | None   -> Some As2.No_p_yes.No

  module Atom = struct
    let target = dir ^ "index.xml"

    let rule : Make.t = {
      target;
      prerequisites = PersonX.rule.target
                      :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
                      :: [];
      fresh         = Make.Outdated;
      command       = fun _pre _ _ _ ->
        Followers.Atom.of_cdb
          ~cdb
          ~title:"👂 Subscribed (Following)"
          ~xsl:(Rfc4287.xsl "subscribed.xsl" target)
          ~rel:(Some Rfc4287.Link.subscribed)
          ~page_size:50 dir
    }
  end

  module Json = struct
    let target = dir ^ "index.jsa"

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

  let follow ~me ~inbox reac : As2_vocab.Activitypub.Types.follow =
    assert (not (me |> Uri.equal reac));
    {
      id      = Uri.with_fragment reac (Some "subscribe");
      actor   = me;
      cc      = [];
      object_ = reac;
      state   = None;
      to_     = [inbox];
    }

  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 = cdb)
      ~uuid
      ~base
      me
      (siac : As2_vocab.Types.person)
      (fo : As2_vocab.Types.follow)  =
    Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Following" "accept" Uuidm.pp uuid Uri.pp fo.object_);
    assert (not (me |> Uri.equal siac.id)) ;
    assert (me |> Uri.equal fo.actor) ;
    assert (not (fo.actor |> Uri.equal fo.object_));
    assert (siac.id |> Uri.equal fo.object_) ;
    Logr.warn (fun m -> m "%s.%s TODO only take those that I expect" "Ap.Following" "accept");
    let _ = base in
    let ke = siac.id |> Uri.to_string in
    let v = Followers.State.(of_actor tnow Accepted siac |> encode) |> Csexp.to_string in
    let _ = Mapcdb.update_string ke v subscribed in
    let _ = Json.(Make.make [rule] target) in
    let _ = Atom.(Make.make [rule] target) in
    Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "created")
    |> Lwt.return
end

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

  let followers actor =
    Uri.make ~path:"notify/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" "As2.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
      ({ty; name; href} : As2_vocab.Types.tag) :: 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 Rfc4287.Rfc3066 lang = e.lang  in *)
    let tags = e.categories |> List.fold_left tag [] in
    let summary,content = match e.title,e.content with
      | "","" -> None,"." (* empty is forbidden *)
      | t,""  -> None,t
      | t,c   -> Some t,c in
    let url = e.links |> List.fold_left (
        (* sift those without a rel *)
        fun i (l : Rfc4287.Link.t) ->
          match l.rel with
          | None   -> l.href :: i
          | Some _ -> i) [] in
    assert (not (content |> String.equal ""));
    {
      id;
      actor;
      attachment=[];
      cc;
      content;
      content_map=[];
      in_reply_to=[];
      media_type=(Some Http.Mime.text_plain);
      published;
      sensitive=false;
      source=None;
      summary;
      summary_map=[];
      tags;
      to_;
      url;
    }

  let txt2html s =
    (* care about :
     * - newlines
     * - urls
     * - tags
     * - mentions
    *)
    s

  (* Mastodon uses the summary as content warning. That's not what the summary intends.
     formerly know as pleistocenify *)
  let diluviate (n : As2_vocab.Types.note) =
    let c = match n.summary with
      | None   -> ""
      | Some t -> (t |> txt2html) ^ "<br/>\n" in
    let c = 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) c in
    let c = if c |> String.equal ""
      then c
      else (* add an emoty line *) c ^ "<br/>\n" in
    let c = c ^ (n.content |> txt2html) in
    {n with
     summary = None;
     content = c;
     url = [n.id] }

  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.actor;
        published      = obj.published;
        to_            = obj.to_;
        cc             = obj.cc;
        direct_message = false;
        obj            = obj;
      }

    let to_json ~base n =
      n
      |> of_rfc4287
      |> diluviate
      (* let c = {c with to_ = [id]} in *)
      |> make
      |> As2_vocab.Encode.(create ~base ~context:As2_vocab.Constants.ActivityStreams.und
                             (note ~base))
  end

  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.actor;
        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 (idx + 1)
    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/"

  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);
    let fn = a.obj.id
             |> uhash
             |> Printf.sprintf "note-%s.json" in
    let tmp = Some (dir ^ "tmp/" ^ fn) in
    File.out_channel ~tmp (dir ^ "new/" ^ fn)
      (fun oc ->
         a
         |> As2_vocab.Encode.(create ~context:None ~base (note ~context:None ~base))
         |> 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.update) =
    let _ = tnow in
    Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Note" "do_cache" Uri.pp a.id);
    let fn = a.obj.id
             |> uhash
             |> Printf.sprintf "note-%s.json" in
    let tmp = Some (dir ^ "tmp/" ^ fn) in
    File.out_channel ~tmp (dir ^ "new/" ^ fn)
      (fun oc ->
         a
         |> As2_vocab.Encode.(update ~context:None ~base (note ~context:None ~base))
         |> Ezjsonm.value_to_channel oc)

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

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