lib/ap.ml

   1 (*
   2  *    _  _   ____                         _
   3  *  _| || |_/ ___|  ___ _ __  _ __   ___ | |
   4  * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| |
   5  * |_      _|___) |  __/ |_) | |_) | (_) |_|
   6  *   |_||_| |____/ \___| .__/| .__/ \___/(_)
   7  *                     |_|   |_|
   8  *
   9  * Personal Social Ap.
  10  *
  11  * Copyright (C) The #Seppo contributors. All rights reserved.
  12  *
  13  * This program is free software: you can redistribute it and/or modify
  14  * it under the terms of the GNU General Public License as published by
  15  * the Free Software Foundation, either version 3 of the License, or
  16  * (at your option) any later version.
  17  *
  18  * This program is distributed in the hope that it will be useful,
  19  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21  * GNU General Public License for more details.
  22  *
  23  * You should have received a copy of the GNU General Public License
  24  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25  *)
  26
  27 let seppo_cgi' = Cfg.seppo_cgi
  28 let apub = "activitypub/"
  29 let proj = apub ^ "actor.jsa" (* the public actor profile *)
  30 let prox = apub ^ "actor.xml" (* the public actor profile *)
  31 let content_length_max = 10 * 1024
  32
  33 let ( let* ) = Result.bind
  34 let ( >>= )  = Result.bind
  35 let to_result none = Option.to_result ~none
  36 let chain a b =
  37   let f a = Ok (a, b) in
  38   Result.bind a f
  39
  40 let write oc (j : Ezjsonm.t) =
  41   Ezjsonm.to_channel ~minify:false oc j;
  42   Ok ""
  43
  44 let writev oc (j : Ezjsonm.value) =
  45   Ezjsonm.value_to_channel ~minify:false oc j;
  46   Ok ""
  47
  48 let json_from_file fn =
  49   let ic = open_in_gen  [ Open_rdonly; Open_binary ] 0 fn in
  50   let j = Ezjsonm.value_from_channel ic in
  51   close_in ic;
  52   Ok j
  53
  54 (** X509.Public_key from PEM. *)
  55 module PubKeyPem = struct
  56   let of_pem s =
  57     s
  58     |> Cstruct.of_string
  59     |> X509.Public_key.decode_pem
  60
  61   let target = apub ^ "id_rsa.pub.pem"
  62   let pk_pem = "app/etc/id_rsa.priv.pem"
  63
  64   let pk_rule : Make.t = {
  65     target         = pk_pem;
  66     prerequisites  = [];
  67     fresh          = Make.Missing;
  68     command        = fun _ _ _ ->
  69       File.out_channel_replace (fun oc ->
  70           Logr.debug (fun m -> m "create private key pem.");
  71           (* https://discuss.ocaml.org/t/tls-signature-with-opam-tls/9399/3?u=mro
  72            * $ openssl genrsa -out app/etc/id_rsa.priv.pem 2048
  73           *)
  74           try
  75             `RSA
  76             |> X509.Private_key.generate ~bits:2048
  77             |> X509.Private_key.encode_pem
  78             |> Cstruct.to_bytes
  79             |> output_bytes oc;
  80             Ok ""
  81           with _ ->
  82             Logr.err (fun m -> m "%s couldn't create pk" E.e1010);
  83             Error "couldn't create pk")
  84   }
  85
  86   let rule : Make.t = {
  87     target;
  88     prerequisites = [ pk_pem ];
  89     fresh         = Make.Outdated;
  90     command       = fun _pre _ r ->
  91       File.out_channel_replace (fun oc ->
  92           Logr.debug (fun m -> m "create public key pem." );
  93           match r.prerequisites with
  94           | [ fn_priv ] -> (
  95               assert (fn_priv = pk_pem);
  96               match
  97                 fn_priv
  98                 |> File.to_string
  99                 |> Cstruct.of_string
 100                 |> X509.Private_key.decode_pem
 101               with
 102               | Ok (`RSA _ as key) ->
 103                 key
 104                 |> X509.Private_key.public
 105                 |> X509.Public_key.encode_pem
 106                 |> Cstruct.to_bytes
 107                 |> output_bytes oc;
 108                 Ok ""
 109               | Ok _ ->
 110                 Logr.err (fun m -> m "%s %s" E.e1032 "wrong key flavour, must be RSA.");
 111                 Error "wrong key flavour, must be RSA."
 112               | Error (`Msg mm) ->
 113                 Logr.err (fun m -> m "%s %s" E.e1033 mm);
 114                 Error mm
 115             )
 116           | l ->
 117             Error
 118               (Printf.sprintf
 119                  "rule must have exactly one dependency, not %d"
 120                  (List.length l)))
 121   }
 122
 123   let rulez = pk_rule :: rule :: []
 124
 125   let make pre =
 126     Make.make ~pre rulez target
 127
 128   let private_of_pem_data pem_data =
 129     match pem_data
 130           |> X509.Private_key.decode_pem with
 131     | Ok ((`RSA _) as pk) -> Ok pk
 132     | Ok _                -> Error "key must be RSA"
 133     | Error (`Msg e)      -> Error e
 134
 135   (** load a private key pem from a file *)
 136   let private_of_pem fn =
 137     fn
 138     |> File.to_bytes
 139     |> Cstruct.of_bytes
 140     |> private_of_pem_data
 141
 142   (** RSA SHA256 sign data with pk.
 143
 144       returns
 145
 146       algorithm,signature
 147
 148        with algorithm currently being fixed to rsa-sha256.
 149        See https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
 150   *)
 151   let sign pk (data : Cstruct.t) : (string * Cstruct.t) =
 152     (* Logr.debug (fun m -> m "PubKeyPem.sign"); *)
 153     (*
 154      * https://discuss.ocaml.org/t/tls-signature-with-opam-tls/9399/9?u=mro
 155      * https://mirleft.github.io/ocaml-x509/doc/x509/X509/Private_key/#cryptographic-sign-operation
 156      *)
 157     (Http.Signature.RSA_SHA256.name, Http.Signature.RSA_SHA256.sign pk (`Message data)
 158                                      |> Result.get_ok)
 159
 160   (** https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
 161   *)
 162   let verify ~algo ~inbox ~key ~signature data =
 163     let data = `Message data
 164     and _ = inbox in
 165     match algo with
 166     | "hs2019" -> (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38 *)
 167       (match Http.Signature.HS2019.verify
 168                ~signature
 169                key
 170                data with
 171       | Error (`Msg "bad signature") ->
 172         (* gotosocial and unnamed other AP implementations seem to use `SHA256 and `RSA_PKCS1
 173            while
 174            https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#autoid-38
 175            and
 176            https://datatracker.ietf.org/doc/id/draft-richanna-http-message-signatures-00.html#name-hs2019
 177            as I understand them recommend `SHA512 and `RSA_PSS. *)
 178         (match Http.Signature.RSA_SHA256.verify
 179                  ~signature
 180                  key
 181                  data with
 182         | Ok _ as o ->
 183           Logr.info (fun m -> m "%s.%s another dadaist http signature" "Ap.PubKeyPem" "verify");
 184           o
 185         | x -> x)
 186       | x -> x)
 187     | "rsa-sha256" ->
 188       Http.Signature.RSA_SHA256.verify
 189         ~signature
 190         key
 191         data
 192     | a ->
 193       Error (`Msg (Printf.sprintf "unknown algorithm: '%s'" a))
 194
 195   (** not key related *)
 196   let digest_base64 s =
 197     Logr.debug (fun m -> m "%s.%s %s" "Ap.PubKeyPem" "digest" "SHA-256");
 198     "SHA-256=" ^ (s
 199                   |> Cstruct.of_string
 200                   |> Mirage_crypto.Hash.SHA256.digest
 201                   |> Cstruct.to_string
 202                   |> Base64.encode_exn)
 203
 204   let digest_base64' s =
 205     Some (digest_base64 s)
 206 end
 207
 208 module Actor = struct
 209   let http_get ?(key = None) u =
 210     Logr.debug (fun m -> m "%s.%s %a" "Ap.Actor" "http_get" Uri.pp u);
 211     let%lwt p = u |> Http.get_jsonv ~key Result.ok in
 212     (match p with
 213      | Error _ as e -> e
 214      | Ok (r,j) ->
 215        match r.status with
 216        | #Cohttp.Code.success_status ->
 217          let mape (e : Ezjsonm.value Decoders__Error.t) =
 218            let s = e |> Decoders_ezjsonm.Decode.string_of_error in
 219            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);
 220            s in
 221          j
 222          |> As2_vocab.Decode.person
 223          |> Result.map_error mape
 224        | _sta -> Format.asprintf "HTTP %a %a" Http.pp_status r.status Uri.pp u
 225                  |> Result.error)
 226     |> Lwt.return
 227 end
 228
 229 let sep n = `Data ("\n" ^ String.make (n*2) ' ')
 230
 231 (** A person actor object. https://www.w3.org/TR/activitypub/#actor-objects *)
 232 module Person = struct
 233
 234   (** generate my key-id from my actor id. *)
 235   let my_key_id me =
 236     Uri.with_fragment me (Some "main-key")
 237
 238   let empty = ({
 239       id                         = Uri.empty;
 240       inbox                      = Uri.empty;
 241       outbox                     = Uri.empty;
 242       followers                  = None;
 243       following                  = None;
 244       attachment                 = [];
 245       discoverable               = false;
 246       generator                  = None;
 247       icon                       = [];
 248       image                      = None;
 249       manually_approves_followers= true;
 250       name                       = None;
 251       name_map                   = [];
 252       preferred_username         = None;
 253       preferred_username_map     = [];
 254       public_key                 = {
 255         id    = Uri.empty;
 256         owner = None;
 257         pem   = "";
 258         signatureAlgorithm = None;
 259       };
 260       published                  = None;
 261       summary                    = None;
 262       summary_map                = [];
 263       url                        = [];
 264     } : As2_vocab.Types.person)
 265
 266   let prsn _pubdate (pem, ((pro : Cfg.Profile.t), (Auth.Uid uid, _base))) =
 267     let Rfc4287.Rfc4646 la = pro.language in
 268     let actor = Uri.make ~path:proj () in
 269     let path u = u |> Http.reso ~base:actor in
 270     ({
 271       id                         = actor;
 272       inbox                      = Uri.make ~path:("../" ^ seppo_cgi' ^ "/" ^ apub ^ "inbox.jsa") () |> path;
 273       outbox                     = Uri.make ~path:"outbox/index.jsa" () |> path;
 274       followers                  = Some (Uri.make ~path:"subscribers/index.jsa" () |> path);
 275       following                  = Some (Uri.make ~path:"subscribed_to/index.jsa" () |> path);
 276       attachment                 = [];
 277       discoverable               = true;
 278       generator                  = Some {href=St.seppo_u; name=(Some St.seppo_c); name_map=[]; rel=None };
 279       icon                       = [ (Uri.make ~path:"../me-avatar.jpg" () |> path) ];
 280       image                      = Some (Uri.make ~path:"../me-banner.jpg" () |> path);
 281       manually_approves_followers= false;
 282       name                       = Some pro.title;
 283       name_map                   = [];
 284       preferred_username         = Some uid;
 285       preferred_username_map     = [];
 286       public_key                 = {
 287         id    = actor |> my_key_id;
 288         owner = Some actor; (* add this deprecated property to make mastodon happy *)
 289         pem;
 290         signatureAlgorithm = Some "https://www.w3.org/2001/04/xmldsig-more#rsa-sha256"; (* from hubzilla, e.g. https://im.allmendenetz.de/channel/minetest *)
 291       };
 292       published                  = None;
 293       summary                    = Some pro.bio;
 294       summary_map                = [(la,pro.bio)];
 295       url                        = [ Uri.make ~path:"../" () |> path ];
 296     } : As2_vocab.Types.person)
 297
 298   module Json = struct
 299     let decode j =
 300       j
 301       |> As2_vocab.Decode.person
 302       |> Result.map_error (fun _ -> "@TODO aua json")
 303
 304     let encode _pubdate (pem, ((pro : Cfg.Profile.t), (uid, base))) =
 305       let Rfc4287.Rfc4646 l = pro.language in
 306       let lang = Some l in
 307       prsn _pubdate (pem, (pro, (uid, base)))
 308       |> As2_vocab.Encode.person ~base ~lang
 309       |> Result.ok
 310   end
 311
 312   let x2txt v =
 313     Markup.(v
 314             |> string
 315             |> parse_html
 316             |> signals
 317             (* |> filter_map (function
 318                  | `Text _ as t -> Some t
 319                  | `Start_element ((_,"p"), _)  -> Some (`Text ["\n<p>&#0x10;\n"])
 320                  | `Start_element ((_,"br"), _) -> Some (`Text ["\n<br>\n"])
 321                  | _ -> None)
 322                |> write_html
 323             *)
 324             |> text
 325             |> to_string)
 326
 327   let x2txt' v =
 328     Option.bind v (fun x -> Some (x |> x2txt))
 329
 330   let flatten (p : As2_vocab.Types.person) =
 331     {p with
 332      summary = x2txt' p.summary;
 333      attachment = List.fold_left (fun init (e : As2_vocab.Types.property_value) ->
 334          ({e with value = x2txt e.value}) :: init) [] p.attachment}
 335
 336   let target = proj
 337
 338   let rule : Make.t =
 339     {
 340       target;
 341       prerequisites  = [
 342         Auth.fn;
 343         Cfg.Base.fn;
 344         Cfg.Profile.fn;
 345         PubKeyPem.target;
 346       ];
 347       fresh = Make.Outdated;
 348       command  = fun pre _ _ ->
 349         File.out_channel_replace (fun oc ->
 350             let now = Ptime_clock.now () in
 351             Cfg.Base.(fn |> from_file)
 352             >>= chain Auth.(fn |> uid_from_file)
 353             >>= chain Cfg.Profile.(fn |> from_file)
 354             >>= chain (PubKeyPem.make pre >>= File.cat)
 355             >>= Json.encode now
 356             >>= writev oc)
 357     }
 358
 359   let rulez = rule :: PubKeyPem.rulez
 360
 361   let make pre = Make.make ~pre rulez target
 362
 363   let from_file fn =
 364     fn
 365     |> json_from_file
 366     >>= Json.decode
 367
 368   module Rdf = struct
 369     let encode' ~base ~lang ({ id; name; name_map; url; inbox; outbox;
 370                                preferred_username; preferred_username_map; summary; summary_map;
 371                                manually_approves_followers;
 372                                discoverable; generator; followers; following;
 373                                public_key; published; attachment; icon; image}: As2_vocab.Types.person) : _ Xmlm.frag =
 374       let ns_as     = As2_vocab.Constants.ActivityStreams.ns_as ^ "#"
 375       and ns_ldp    = "http://www.w3.org/ns/ldp#"
 376       and ns_rdf    = "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
 377       and ns_schema = "http://schema.org#"
 378       (* and ns_sec    = As2_vocab.Constants.ActivityStreams.ns_sec ^ "#" *)
 379       and ns_toot   = "http://joinmastodon.org/ns#"
 380       and ns_xsd    = "http://www.w3.org/2001/XMLSchema#" in
 381       let txt ?(lang = None) ?(datatype = None) ns tn (s : string) =
 382         let att = [] in
 383         let att = match lang with
 384           | Some v -> ((Xmlm.ns_xml, "lang"), v) :: att
 385           | None   -> att in
 386         let att = match datatype with
 387           | Some v -> ((ns_rdf, "datatype"), v) :: att
 388           | None   -> att in
 389         `El (((ns, tn), att), [`Data s]) in
 390       let uri   ns tn u       = `El (((ns, tn), [ ((ns_rdf, "resource"), u |> Http.reso ~base |> Uri.to_string) ]), []) in
 391       let txt'  ns tn none s' = s' |> Option.fold ~none ~some:(fun n -> txt ns tn n :: sep 2 :: none) in
 392       let link_tbd ns tn none s' = s' |> Option.fold ~none ~some:(fun (_ : As2_vocab.Types.link) ->
 393           `El (((ns, tn), []), [ (* @TODO *) ])
 394           :: sep 2 :: none) in
 395       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
 396       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
 397       let uri'  ns tn none s' = s' |> Option.fold ~none ~some:(fun n -> uri ns tn n :: sep 2 :: none) in
 398       let img'  _n tn none (u' : Uri.t option) = u' |> Option.fold ~none ~some:(fun u ->
 399           `El (((ns_as, tn), []),
 400                sep 3
 401                :: `El (((ns_as, "Image"), []),
 402                        sep 4
 403                        :: uri ns_as "url" u
 404                        :: [])
 405                :: []) :: sep 2 :: none
 406         ) in
 407       let img'' _n tn none (u' : Uri.t list) = img' _n tn none (List.nth_opt u' 0) in
 408       let lang = lang |> Option.value ~default:"und" in
 409       Logr.debug (fun m -> m "%s.%s %a %s" "Ap.Person.RDF" "encode" Uri.pp base lang);
 410       let _ = public_key in
 411       let f_map name init (lang,value) = txt ~lang:(Some lang) ns_as name value :: sep 3 :: init in
 412       let f_uri name init value = uri ns_as name value :: sep 2 :: init in
 413       let f_att init ({name; name_map; value; value_map} : As2_vocab.Types.property_value) =
 414         let _ = name_map and _ = value_map in (* TODO *)
 415         let sub = sep 4
 416                   :: txt ns_as     "name"  name
 417                   :: sep 4
 418                   :: txt ns_schema "value" value
 419                   :: [] in
 420         let sub = name_map |> List.fold_left (f_map "name") sub in
 421         let sub = value_map |> List.fold_left (f_map "value") sub in
 422         `El (((ns_as, "attachment"), []),
 423              sep 3
 424              :: `El (((ns_schema, "PropertyValue"), []), sub)
 425              :: []) :: sep 2 :: init in
 426       let chi = [] in
 427       let chi = Some outbox                      |> uri'     ns_as   "outbox"                    chi in
 428       let chi = Some inbox                       |> uri'     ns_ldp  "inbox"                     chi in
 429       let chi = followers                        |> uri'     ns_as   "followers"                 chi in
 430       let chi = following                        |> uri'     ns_as   "following"                 chi in
 431       let chi = attachment                       |> List.fold_left f_att                         chi in
 432       let chi = image                            |> img'     ns_as   "image"                     chi in
 433       let chi = icon                             |> img''    ns_as   "icon"                      chi in
 434       let chi = summary                          |> txt'     ns_as   "summary"                   chi in
 435       let chi = summary_map                      |> List.fold_left (f_map "summary")             chi in
 436       let chi = url                              |> List.fold_left (f_uri "url")                 chi in
 437       let chi = name                             |> txt'     ns_as   "name"                      chi in
 438       let chi = name_map                         |> List.fold_left (f_map "name")                chi in
 439       let chi = generator                        |> link_tbd ns_as   "generator"                 chi in
 440       let chi = Some discoverable                |> bool'    ns_toot "discoverable"              chi in
 441       let chi = Some manually_approves_followers |> bool'    ns_as   "manuallyApprovesFollowers" chi in
 442       let chi = published                        |> rfc3339' ns_as   "published"                 chi in
 443       let chi = preferred_username               |> txt'     ns_as   "preferredUsername"         chi in
 444       let chi = preferred_username_map           |> List.fold_left (f_map "preferredUsername")   chi in
 445       let chi = Some id                          |> uri'     ns_as   "id"                        chi in
 446       let chi = sep 2 :: chi in
 447       `El (((ns_as, "Person"), [
 448           ((Xmlm.ns_xmlns, "as"),     ns_as);
 449           ((Xmlm.ns_xmlns, "ldp"),    ns_ldp);
 450           ((Xmlm.ns_xmlns, "schema"), ns_schema);
 451           (* ((Xmlm.ns_xmlns, "sec"),    ns_sec); *)
 452           ((Xmlm.ns_xmlns, "toot"),   ns_toot);
 453           (* needs to be inline vebose ((Xmlm.ns_xmlns, "xsd"),    ns_xsd); *)
 454           ((ns_rdf, "about"), "");
 455           ((Xmlm.ns_xml, "lang"), lang);
 456         ]), chi)
 457
 458     (* Alternatively may want to take a Ap.Feder.t *)
 459     let encode ?(token = None) ?(is_in_subscribers = None) ?(am_subscribed_to = None) ?(blocked = None) ~base ~lang pe : _ Xmlm.frag =
 460       let open Xml in
 461       let txt ?(datatype = None) ns tn (s : string) =
 462         `El (((ns, tn), match datatype with
 463           | Some ty -> [((ns_rdf, "datatype"), ty)]
 464           | None    -> []), [`Data s]) in
 465       let txt' ns tn none s'   = s' |> Option.fold ~none ~some:(fun n -> txt ns tn n :: sep 2 :: none) in
 466       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
 467       `El (((ns_rdf, "RDF"), [
 468           ((Xmlm.ns_xmlns, "rdf"), ns_rdf);
 469           ((Xmlm.ns_xmlns, "seppo"),  ns_seppo);
 470           ((Xmlm.ns_xml,"base"),base |> Uri.to_string);
 471         ]),
 472            sep 1 ::
 473            `El (((ns_rdf, "Description"), [ (ns_rdf, "about"), "" ]),
 474                 sep 2 ::
 475                 txt'   ns_seppo "token"            [] token     @
 476                 noyes' ns_seppo "is_subscriber"    [] is_in_subscribers    @
 477                 noyes' ns_seppo "am_subscribed_to" [] am_subscribed_to @
 478                 noyes' ns_seppo "is_blocked"       [] blocked
 479                )
 480            :: sep 1
 481            :: encode' ~base ~lang pe
 482            :: [])
 483   end
 484 end
 485
 486 (* Xml subset of the profle page. *)
 487 module PersonX = struct
 488   let xml_ pubdate (pem, (pro, (uid, base))) =
 489     let Rfc4287.Rfc4646 lang = (pro : Cfg.Profile.t).language in
 490     Person.prsn pubdate (pem, (pro, (uid, base)))
 491     |> Person.Rdf.encode ~base ~lang:(Some lang)
 492     |> Result.ok
 493
 494   let target = prox
 495
 496   let rule = {Person.rule
 497               with target;
 498                    command = fun pre _ _ ->
 499                      File.out_channel_replace (fun oc ->
 500                          let now = Ptime_clock.now () in
 501                          let writex oc x =
 502                            let xsl = Some "../themes/current/actor.xsl" in
 503                            Xml.to_chan ~xsl x oc;
 504                            Ok "" in
 505                          Cfg.Base.(fn |> from_file)
 506                          >>= chain Auth.(fn |> uid_from_file)
 507                          >>= chain Cfg.Profile.(fn |> from_file)
 508                          >>= chain (PubKeyPem.make pre >>= File.cat)
 509                          >>= xml_ now
 510                          >>= writex oc) }
 511
 512   let rulez = rule :: PubKeyPem.rulez
 513
 514   let make pre = Make.make ~pre rulez target
 515 end
 516
 517 (**
 518  * https://www.w3.org/TR/activitystreams-core/
 519  * https://www.w3.org/TR/activitystreams-core/#media-type
 520 *)
 521 let send ?(success = `OK) ~key (f_ok : Cohttp.Response.t * string -> unit) to_ msg =
 522   let body = msg |> Ezjsonm.value_to_string in
 523   let signed_headers body = PubKeyPem.(Http.signed_headers key (digest_base64' body) to_) in
 524   let headers = signed_headers body in
 525   let headers = Http.H.add' headers Http.H.ct_jlda in
 526   let headers = Http.H.add' headers Http.H.acc_app_jlda in
 527   (* TODO queue it and re-try in case of failure *)
 528   let%lwt r   = Http.post ~headers body to_ in
 529   (match r with
 530    | Ok (res,body') ->
 531      let%lwt body' = body' |> Cohttp_lwt.Body.to_string in
 532      (match res.status with
 533       | #Cohttp.Code.success_status ->
 534         Logr.debug (fun m -> m "%s.%s %a\n%a\n\n%s" "Ap" "send" Uri.pp to_ Cohttp.Response.pp_hum res body');
 535         f_ok (res, body');
 536         Ok (success, [Http.H.ct_plain], Cgi.Response.body "ok")
 537       | sta ->
 538         Logr.warn (fun m -> m "%s.%s %a\n%a\n\n%s" "Ap" "send" Uri.pp to_ Cohttp.Response.pp_hum res body');
 539         Http.s502 ~body:(sta |> Cohttp.Code.string_of_status |> (Cgi.Response.body ~ee:E.e1039))
 540      ) |> Lwt.return
 541    | Error e ->
 542      Logr.warn (fun m -> m "%s.%s <- %s %a\n%s" "Ap" "send" "post" Uri.pp to_ e);
 543      Http.s500 |> Lwt.return)
 544
 545 let snd_reject
 546     ~uuid
 547     ~base
 548     ~key
 549     me
 550     (siac : As2_vocab.Types.person)
 551     (j : Ezjsonm.value) =
 552   Logr.warn(fun m -> m "%s.%s %a %a" "Ap" "snd_reject" Uuidm.pp uuid Uri.pp siac.inbox);
 553   assert (not (me |> Uri.equal siac.id));
 554   let reject me id =
 555     `O [("@context", `String As2_vocab.Constants.ActivityStreams.ns_as);
 556         ("type",     `String "Reject");
 557         ("actor",    `String (me |> Http.reso ~base |> Uri.to_string));
 558         ("object",   `String (id |> Uri.to_string))]
 559   in
 560   let id = match j with
 561     | `O (_ :: ("id", `String id) :: _) -> id |> Uri.of_string
 562     | _                                 -> Uri.empty in
 563   id
 564   |> reject me
 565   |> send ~success:`Unprocessable_entity ~key
 566     (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))
 567     siac.inbox
 568
 569 (** re-used for following as well (there using block, too) *)
 570 module Followers = struct
 571   (** follower tri-state *)
 572   module State = struct
 573     (** Tri-state *)
 574     type t =
 575       | Pending
 576       | Accepted
 577       | Blocked
 578
 579     let of_string = function
 580       | "pending"  -> Some Pending
 581       | "accepted" -> Some Accepted
 582       | "blocked"  -> Some Blocked
 583       | _ -> None
 584     let to_string = function
 585       | Pending  -> "pending"
 586       | Accepted -> "accepted"
 587       | Blocked  -> "blocked"
 588     let predicate ?(invert = false) (s : t) =
 589       let r = match s with
 590         | Pending
 591         | Accepted -> true
 592         | Blocked  -> false in
 593       if invert
 594       then not r
 595       else r
 596
 597     (** Rich follower state info:
 598
 599         state, timestamp, actor id, name, rfc7565, inbox
 600     *)
 601     type t' = t * Ptime.t * Uri.t * string option * Rfc7565.t option * Uri.t option
 602
 603     let ibox (_,_,ibox,_,_,_ : t') : Uri.t = ibox
 604     (** input to fold_left *)
 605     let ibox' f a (k,v) = f a (k,v |> ibox)
 606
 607     let of_actor tnow st (siac : As2_vocab.Types.person) : t' =
 608       let us = match Uri.host siac.id, siac.preferred_username with
 609         | None,_
 610         | _,None             -> None
 611         | Some domain, Some local -> Some Rfc7565.(make ~local ~domain ()) in
 612       (st,tnow,siac.inbox,siac.name,us,List.nth_opt siac.icon 0)
 613
 614     let decode = function
 615       | Csexp.(List [Atom "1"; Atom s; Atom t0; Atom inbox; Atom name; Atom rfc7565; Atom avatar]) ->
 616         Option.bind
 617           (s |> of_string)
 618           (fun s ->
 619              match t0 |> Ptime.of_rfc3339 with
 620              | Ok (t,_,_) ->
 621                let inbox = inbox |> Uri.of_string
 622                and rfc7565 = rfc7565 |> Rfc7565.of_string |> Result.to_option
 623                and avatar = avatar |> Uri.of_string in
 624                let r : t' = (s,t,inbox,Some name,rfc7565,Some avatar) in
 625                Some r
 626              | _ -> None )
 627
 628       (* legacy: *)
 629       (* assume the preferred_username is @ attached to the inbox *)
 630       | Csexp.(List [Atom s; Atom t0; Atom inbox]) ->
 631         Option.bind
 632           (s |> of_string)
 633           (fun s ->
 634              match t0 |> Ptime.of_rfc3339 with
 635              | Ok (t,_,_) ->
 636                let inbox = inbox |> Uri.of_string in
 637                let us = Option.bind
 638                    (inbox |> Uri.user)
 639                    (fun local -> Some Rfc7565.(make ~local ~domain:(inbox |> Uri.host_with_default ~default:"-") ())) in
 640                let r : t' = (s,t,Uri.with_userinfo inbox None,inbox |> Uri.user,us,None) in
 641                Some r
 642              | _ -> None)
 643       | _ -> None
 644     let decode' = function
 645       | Ok s -> s |> decode
 646       | _ -> None
 647     let encode ((state,t,inbox,name,(us : Rfc7565.t option) ,avatar) : t') =
 648       (* attach the preferred_username to the inbox *)
 649       let state  = state |> to_string in
 650       let t0     = t     |> Ptime.to_rfc3339 in
 651       let inbox  = inbox |> Uri.to_string in
 652       let name   = name  |> Option.value ~default:"" in
 653       let avatar = avatar
 654                    |> Option.value ~default:Uri.empty
 655                    |> Uri.to_string in
 656       let rfc7565 = Option.bind us
 657           (fun l -> Some (l |> Rfc7565.to_string))
 658                     |> Option.value ~default:"" in
 659       Csexp.(List [Atom "1"; Atom state; Atom t0; Atom inbox; Atom name; Atom rfc7565; Atom avatar])
 660
 661     let is_accepted = function
 662       | None                      -> As2.No_p_yes.No
 663       | Some (Accepted,_,_,_,_,_) -> As2.No_p_yes.Yes
 664       | Some (Blocked ,_,_,_,_,_) -> As2.No_p_yes.No
 665       | Some (Pending ,_,_,_,_,_) -> As2.No_p_yes.Pending
 666
 667     let is_blocked  = function
 668       | None                      -> As2.No_p_yes.No
 669       | Some (Accepted,_,_,_,_,_) -> As2.No_p_yes.No
 670       | Some (Blocked ,_,_,_,_,_) -> As2.No_p_yes.Yes
 671       | Some (Pending ,_,_,_,_,_) -> As2.No_p_yes.No
 672   end
 673
 674   let fold_left (fkt : 'a -> (Uri.t * State.t') -> 'a) =
 675     let kv f a (k,v) = f a
 676         (k |> Bytes.to_string |> Uri.of_string
 677         ,v |> Bytes.to_string |> Csexp.parse_string |> State.decode') in
 678     let opt f a = function
 679       | (k,None)   -> Logr.warn (fun m -> m "%s.%s ignored actor %a" "Ap.Followers" "fold_left" Uri.pp k);
 680         a
 681       | (k,Some v) -> f a (k,v) in
 682     (* caveat, this folding really looks reverse: *)
 683     fkt |> opt |> kv |> Mapcdb.fold_left
 684
 685   let cdb = Mapcdb.Cdb "app/var/db/subscribers.cdb"
 686
 687   let find
 688       ?(cdb = cdb)
 689       id : State.t' option =
 690     assert (id |> Uri.user |> Option.is_none);
 691     let ke = id |> Uri.to_string in
 692     Option.bind
 693       (Mapcdb.find_string_opt ke cdb)
 694       (fun s -> s |> Csexp.parse_string |> State.decode')
 695
 696   let update ?(cdb = cdb) id v =
 697     assert (id |> Uri.user |> Option.is_none);
 698     Mapcdb.update_string (id |> Uri.to_string) (v |> State.encode |> Csexp.to_string) cdb
 699
 700   (** remove from cdb *)
 701   let remove ?(cdb = cdb) id =
 702     assert (id |> Uri.user |> Option.is_none);
 703     Mapcdb.remove_string (id |> Uri.to_string) cdb
 704
 705   let is_in_subscribers ?(cdb = cdb) id =
 706     assert (id |> Uri.user |> Option.is_none);
 707     id
 708     |> find ~cdb
 709     |> State.is_accepted
 710
 711   (** https://www.rfc-editor.org/rfc/rfc4287#section-4.1.1 *)
 712   module Atom = struct
 713     (** create all from oldest to newest and return newest file name. *)
 714     let of_cdb
 715         ?(cdb = cdb)
 716         ?(predicate = State.predicate ~invert:false)
 717         ~base
 718         ~title
 719         ~xsl
 720         ~rel
 721         ?(page_size = 50)
 722         dir =
 723       Logr.debug (fun m -> m "%s.%s %s" "Ap.Followers.Atom" "of_cdb" dir);
 724       let predicate (s,_,_,_,_,_ : State.t') = s |> predicate in
 725       (** write one page of a paged xml feed *)
 726       let flush_page_xml ~is_last (u,p,i) =
 727         let _ = is_last
 728         and _ : (Uri.t * State.t') list = u in
 729         assert (0 <= p);
 730         assert (dir |> St.is_suffix ~affix:"/");
 731         let fn = Printf.sprintf "%s%d.xml" dir p in
 732         Logr.debug (fun m -> m "%s.%s %s" "Ap.Followers.Atom" "of_cdb.flush" dir);
 733         assert (u |> List.length = i);
 734
 735         let open Xml in
 736         let mk_rel rel i =
 737           let path,title = match rel with
 738             | Rfc4287.Link.(Rel (Single "first")) ->
 739               assert (i == -1);
 740               ".",Some "last"
 741             | _ ->
 742               assert (i >= 0);
 743               Printf.sprintf "%d.xml" i,
 744               Some (Printf.sprintf "%i" (i+1))
 745           and rel = Some rel in
 746           Rfc4287.Link.(Uri.make ~path () |> make ~rel ~title |> to_atom)
 747         in
 748         let self  = mk_rel Rfc4287.Link.self p in
 749         let first = mk_rel Rfc4287.Link.first (-1) in
 750         let last  = mk_rel Rfc4287.Link.last 0 in
 751         let prev  = mk_rel Rfc4287.Link.prev (succ p) in
 752         let add_next i l = match i with
 753           | 0 -> l
 754           | i -> sep 1 :: mk_rel Rfc4287.Link.next (pred i) :: l in
 755         let id_s = Printf.sprintf "%i.xml" p in
 756         let xml : _ Xmlm.frag =
 757           `El (((ns_a, "feed"), [
 758               ((Xmlm.ns_xmlns, "xmlns"), ns_a);
 759               ((Xmlm.ns_xml, "base"), base |> Uri.to_string);
 760             ]),
 761                sep 1
 762                :: `El (((ns_a,"title"), []), [`Data title]) :: sep 1
 763                :: `El (((ns_a,"id"), []), [`Data id_s ])
 764                :: sep 1 :: self
 765                :: sep 1 :: first
 766                :: sep 1 :: last
 767                :: sep 1 :: prev
 768                :: (u
 769                    |> List.rev
 770                    |> List.fold_left
 771                      (fun init (href,(_,_,_,title,us,_unused_icon)) ->
 772                         let href = Uri.with_userinfo href None in
 773                         let rfc7565 = Option.bind us
 774                             (fun us -> Some (us |> Rfc7565.to_string)) in
 775                         sep 1
 776                         :: Rfc4287.Link.(make ~rel ~title ~rfc7565 href |> to_atom)
 777                         :: init)
 778                      [`Data "\n"]
 779                    |> add_next p) )
 780         in
 781         fn |> File.out_channel_replace (Xml.to_chan ~xsl xml);
 782         Ok fn in
 783       (** fold a filtered list cdb into paged xml files *)
 784       fold_left (fun (l,p,i as init) (href,st as k) ->
 785           if st |> predicate
 786           then (
 787             Logr.debug (fun m -> m "%s.%s %a" "Ap.Followers.Atom" "of_cdb.fold_left" Uri.pp href);
 788             let i = succ i in
 789             if i > page_size
 790             then
 791               let _ = (l,p,i-1) |> flush_page_xml ~is_last:false in
 792               k :: [],p+1,1
 793             else
 794               k :: l,p,i)
 795           else
 796             init)
 797         ([],0,0) cdb
 798       |> flush_page_xml ~is_last:true
 799
 800     let dir = apub ^ "subscribers/"
 801     let target = dir ^ "index.xml"
 802
 803     let rule : Make.t = {
 804       target;
 805       prerequisites = PersonX.rule.target
 806                       :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
 807                       :: [];
 808       fresh         = Make.Outdated;
 809       command       = fun _pre _ _ _ ->
 810         let* base = Cfg.Base.(from_file fn) in
 811         of_cdb
 812           ~cdb
 813           ~base
 814           ~title:"📣 Subscribers"
 815           ~xsl:(Rfc4287.xsl "subscribers.xsl" target)
 816           ~rel:(Some Rfc4287.Link.subscribers)
 817           ~page_size:50
 818           dir
 819     }
 820
 821     let make = Make.make [rule]
 822   end
 823
 824   (** https://www.w3.org/TR/activitypub/#followers *)
 825   module Json = struct
 826     let to_page ~is_last (i : int) (fs : Uri.t list) : Uri.t As2_vocab.Types.collection_page =
 827       let p i =
 828         let path = i |> Printf.sprintf "%d.jsa" in
 829         Uri.make ~path () in
 830       let self = p i in
 831       let next = if i > 0
 832         then Some (p (pred i))
 833         else None in
 834       let prev = if not is_last
 835         then Some (p (succ i))
 836         else None in
 837       {
 838         id         = self;
 839         current    = Some self;
 840         first      = None;
 841         is_ordered = true;
 842         items      = fs;
 843         last       = Some (p 0);
 844         next;
 845         part_of    = Some (Uri.make ~path:"index.jsa" ());
 846         prev;
 847         total_items= None;
 848       }
 849
 850     (** write one page of an https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollection *)
 851     let to_page_json ~base _prefix ~is_last (i : int) (ids : Uri.t list) =
 852       to_page ~is_last i ids
 853       |> As2_vocab.Encode.(collection_page ~base (uri ~base))
 854
 855     (** dehydrate into https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollection
 856         and https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollectionpage
 857         dst afterwards contains an
 858         index.jsa
 859         index-0.jsa
 860         ...
 861         index-n.jsa
 862     *)
 863     let flush_page_json ~base ~oc prefix ~is_last (tot,pa,lst,_) =
 864       let fn j = j |> Printf.sprintf "%d.jsa" in
 865       Logr.debug (fun m -> m "%s.%s lst#%d" "Ap.Followers" "flush_page" (lst |> List.length));
 866       let js = lst |> List.rev |> to_page_json ~base prefix ~is_last pa in
 867       (prefix ^ (fn pa)) |> File.out_channel_replace (fun ch -> Ezjsonm.value_to_channel ~minify:false ch js);
 868       (if is_last
 869        then
 870          let p i =
 871            let path = fn i in
 872            Uri.make ~path () in
 873          let c : Uri.t As2_vocab.Types.collection =
 874            { id          = Uri.make ~path:"index.jsa" ();
 875              current     = None;
 876              first       = Some (p pa);
 877              is_ordered  = true;
 878              items       = Some [];
 879              last        = Some (p 0);
 880              total_items = Some tot;
 881            } in
 882          c
 883          |> As2_vocab.Encode.(collection ~base (uri ~base))
 884          |> Ezjsonm.value_to_channel ~minify:false oc)
 885
 886     (** paging logic *)
 887     let fold2pages pagesize flush_page (tot,pa,lst,i) id =
 888       Logr.debug (fun m -> m "%s.%s %a" "Ap.Followers" "fold2pages" Uri.pp id );
 889       if i >= pagesize
 890       then (
 891         flush_page ~is_last:false (tot,pa,lst,i);
 892         (tot |> succ,pa |> succ,id :: [],0)
 893       ) else
 894         (tot |> succ,pa,id :: lst,i |> succ)
 895
 896     (** dehydrate the cdb (e.g. followers list) into the current directory
 897
 898         uses fold2pages & flush_page_json
 899     *)
 900     let coll_of_cdb
 901         ~base
 902         ~oc
 903         ?(pagesize = 100)
 904         ?(predicate = State.predicate ~invert:false)
 905         prefix cdb =
 906       assert (0 < pagesize && pagesize < 10_001);
 907       (* Logr.debug (fun m -> m "%s.%s %d %a" "Ap.Followers" "cdb2coll" pagesize Uri.pp base ); *)
 908       let base = Http.reso ~base (Uri.make ~path:prefix ()) in
 909       let* res = fold_left (fun a (k,(s,_,_,_,_,_)) ->
 910           match a with
 911           | Error _ as e ->
 912             Logr.err (fun m -> m "%s %s.%s foohoo" E.e1008 "Ap.Followers" "coll_of_cdb");
 913             e
 914           | Ok ctx ->
 915             Ok (if s |> predicate
 916                 then k |> fold2pages pagesize (flush_page_json ~base ~oc prefix) ctx
 917                 else (
 918                   Logr.debug (fun m -> m "%s.%s ignored %a" "Ap.Followers" "coll_of_cdb.fold_left" Uri.pp k);
 919                   ctx) (* just go on *) )
 920         ) (Ok (0,0,[],0)) cdb in
 921       flush_page_json ~base prefix ~oc ~is_last:true res;
 922       Ok (prefix ^ "index.jsa")
 923
 924     let dir = apub ^ "subscribers/"
 925     let target = dir ^ "index.jsa"
 926
 927     let rule = {Atom.rule
 928                 with
 929                  target;
 930                  prerequisites = Person.rule.target
 931                                  :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
 932                                  :: [];
 933                  command = fun _pre _ _ ->
 934                    File.out_channel_replace (fun oc ->
 935                        let* base = Cfg.Base.(from_file fn) in
 936                        coll_of_cdb ~base ~oc dir cdb)
 937                }
 938     let make = Make.make [rule]
 939   end
 940
 941   let span_follow = 92 * 24 * 60 * 60 |> Ptime.Span.of_int_s
 942
 943   (* notify the follower (uri) and do the local effect *)
 944   let snd_accept
 945       ?(tnow = Ptime_clock.now ())
 946       ~uuid
 947       ~base
 948       ~key
 949       ?(cdb = cdb)
 950       me
 951       (siac : As2_vocab.Types.person)
 952       (fo : As2_vocab.Types.follow) =
 953     Logr.warn(fun m -> m "%s.%s %a %a" "Ap.Followers" "snd_accept" Uri.pp fo.actor Uuidm.pp uuid);
 954     assert (not (me |> Uri.equal fo.actor));
 955     let end_time = Ptime.(span_follow |> add_span tnow) in
 956     assert (fo.actor  |> Uri.user |> Option.is_none);
 957     let side_ok _ =
 958       let _ = State.of_actor tnow Accepted siac
 959               |> update ~cdb fo.actor
 960       in
 961       let _ = Make.make [Json.rule] Json.target in
 962       let _ = Atom.(make target) in
 963       () in
 964     match Option.bind
 965             (let ke = fo.actor |> Uri.to_string in
 966              Mapcdb.find_string_opt ke cdb)
 967             (fun s -> s |> Csexp.parse_string |> State.decode') with
 968     | None ->
 969       (* Immediately accept *)
 970       let msg = ({
 971           id        = fo.id;
 972           actor     = me;
 973           obj       = fo;
 974           published = Some tnow;
 975           end_time;
 976         } : As2_vocab.Types.follow As2_vocab.Types.accept)
 977                 |> As2_vocab.Encode.(accept (follow ~base)) ~base in
 978       send ~key side_ok siac.inbox msg
 979     | Some (Accepted,tnow,_,_,_,_)
 980     | Some (Pending,tnow,_,_,_,_) ->
 981       let msg =  ({
 982           id        = fo.id;
 983           actor     = me;
 984           obj       = fo;
 985           published = Some tnow;
 986           end_time;
 987         } : As2_vocab.Types.follow As2_vocab.Types.accept)
 988                  |> As2_vocab.Encode.(accept (follow ~base)) ~base in
 989       send ~key side_ok siac.inbox msg
 990     | Some (Blocked,_,_tnow,_,_,_) -> Lwt.return Http.s403
 991
 992   (* do the local effect *)
 993   let snd_accept_undo
 994       ?(tnow = Ptime_clock.now ())
 995       ?(cdb = cdb)
 996       ~uuid
 997       ~base
 998       ~key
 999       me
1000       (siac : As2_vocab.Types.person)
1001       (ufo : As2_vocab.Types.follow As2_vocab.Types.undo) =
1002     Logr.warn(fun m -> m "%s.%s %a %a" "Ap.Follower" "snd_accept_undo" Uri.pp ufo.obj.actor Uuidm.pp uuid);
1003     assert (not (me |> Uri.equal ufo.actor));
1004     assert (ufo.actor |> Uri.equal ufo.obj.actor );
1005     assert (ufo.actor |> Uri.equal siac.id);
1006     let _ = remove ~cdb ufo.actor in
1007     let _ = Json.(make target) in
1008     let _ = Atom.(make target) in
1009     let side_ok _ = () (* noop *) in
1010     ({
1011       id        = ufo.id;
1012       actor     = me;
1013       obj       = ufo;
1014       published = Some tnow;
1015       end_time  = None;
1016     } : As2_vocab.Types.follow As2_vocab.Types.undo As2_vocab.Types.accept)
1017     |> As2_vocab.Encode.(accept ~base (undo ~base (follow ~base)))
1018     |> send ~key side_ok siac.inbox
1019 end
1020
1021 (** Logic for https://www.w3.org/TR/activitypub/#following *)
1022 module Following = struct
1023   let n = "subscribed_to"
1024   let cdb = Mapcdb.Cdb ("app/var/db/" ^ n ^ ".cdb")
1025
1026   let find ?(cdb = cdb) = Followers.find ~cdb
1027   let remove ?(cdb = cdb) = Followers.remove ~cdb
1028   let update ?(cdb = cdb) = Followers.update ~cdb
1029
1030   (** lists whom I subscribed to *)
1031   module Subscribed_to = struct
1032     let dir = apub ^ n ^ "/"
1033
1034     (** Mostly delegates to Followers.Atom.of_cdb  *)
1035     module Atom = struct
1036       let target = dir ^ "index.xml"
1037
1038       let rule : Make.t = {
1039         target;
1040         prerequisites = PersonX.rule.target
1041                         :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
1042                         :: [];
1043         fresh         = Make.Outdated;
1044         command       = fun _pre _ _ _ ->
1045           let* base = Cfg.Base.(from_file fn) in
1046           Followers.Atom.of_cdb
1047             ~cdb
1048             ~base
1049             ~title:"👂 Subscribed to"
1050             ~xsl:(Rfc4287.xsl "subscribed_to.xsl" target)
1051             ~rel:(Some Rfc4287.Link.subscribed_to)
1052             ~page_size:50 dir
1053       }
1054     end
1055
1056     (** Mostly delegates to Followers.Json.coll_of_cdb *)
1057     module Json = struct
1058       let target = dir ^ "index.jsa"
1059
1060       let rule : Make.t = {
1061         target;
1062         prerequisites = Person.rule.target
1063                         :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
1064                         :: [];
1065         fresh         = Make.Outdated;
1066         command       = fun _pre _ _ ->
1067           File.out_channel_replace (fun oc ->
1068               let* base = Cfg.Base.(from_file fn) in
1069               Followers.Json.coll_of_cdb ~base ~oc dir cdb)
1070       }
1071     end
1072   end
1073
1074   let am_subscribed_to ?(cdb = cdb) id =
1075     assert (id |> Uri.user |> Option.is_none);
1076     id
1077     |> find ~cdb
1078     |> Followers.State.is_accepted
1079
1080   (** lists whom I block *)
1081   module Blocked = struct
1082     let dir = apub ^ "blocked" ^ "/"
1083
1084     (** Mostly delegates to Followers.Atom.of_cdb  *)
1085     module Atom = struct
1086       let target = dir ^ "index.xml"
1087
1088       let rule : Make.t = {
1089         target;
1090         prerequisites = PersonX.rule.target
1091                         :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
1092                         :: [];
1093         fresh         = Make.Outdated;
1094         command       = fun _pre _ _ _ ->
1095           let* base = Cfg.Base.(from_file fn) in
1096           Followers.Atom.of_cdb
1097             ~cdb
1098             ~predicate:Followers.State.(predicate ~invert:true)
1099             ~base
1100             ~title:"🤐 Blocked"
1101             ~xsl:(Rfc4287.xsl "blocked.xsl" target)
1102             ~rel:(Some Rfc4287.Link.blocked)
1103             ~page_size:50 dir
1104       }
1105     end
1106
1107     (** Mostly delegates to Followers.Json.coll_of_cdb *)
1108     module Json = struct
1109       let target = dir ^ "index.jsa"
1110
1111       let rule : Make.t = {
1112         target;
1113         prerequisites = Person.rule.target
1114                         :: (cdb |> (fun (Mapcdb.Cdb v) -> v))
1115                         :: [];
1116         fresh         = Make.Outdated;
1117         command       = fun _pre _ _ ->
1118           File.out_channel_replace (fun oc ->
1119               let* base = Cfg.Base.(from_file fn) in
1120               Followers.Json.coll_of_cdb
1121                 ~predicate:Followers.State.(predicate ~invert:true)
1122                 ~base ~oc dir cdb)
1123       }
1124     end
1125   end
1126
1127   let is_blocked ?(cdb = cdb) id =
1128     assert (id |> Uri.user |> Option.is_none);
1129     id
1130     |> find ~cdb
1131     |> Followers.State.is_blocked
1132
1133   let make ?(tnow = Ptime_clock.now ())  ~me ~inbox reac : As2_vocab.Activitypub.Types.follow =
1134     assert (not (me |> Uri.equal reac));
1135     let _ = inbox
1136     and end_time = Ptime.(Followers.span_follow |> add_span tnow) in
1137     {
1138       id       = Uri.with_fragment me (Some "subscribe");
1139       actor    = me;
1140       cc       = [];
1141       end_time;
1142       object_  = reac;
1143       state    = None;
1144       to_      = [];
1145     }
1146
1147   let undo ~me (o : As2_vocab.Types.follow) : As2_vocab.Types.follow As2_vocab.Types.undo =
1148     assert (not (me |> Uri.equal o.object_));
1149     assert (me |> Uri.equal o.actor );
1150     {
1151       id       = Uri.with_fragment o.id (Some "subscribe#undo");
1152       actor    = me;
1153       obj      = o;
1154       published= None;
1155     }
1156
1157   let rcv_accept
1158       ?(tnow = Ptime_clock.now ())
1159       ?(subscribed_to = cdb)
1160       ~uuid
1161       ~base
1162       me
1163       (siac : As2_vocab.Types.person)
1164       (fo : As2_vocab.Types.follow) =
1165     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Following" "rcv_accept" Uuidm.pp uuid Uri.pp fo.object_);
1166     assert (siac.id |> Uri.equal fo.object_);
1167     assert (not (me |> Uri.equal siac.id));
1168     (* assert (me |> Uri.equal fo.actor);
1169        assert (not (fo.actor |> Uri.equal fo.object_)); *)
1170     Logr.warn (fun m -> m "%s.%s TODO only take those that I expect" "Ap.Following" "accept");
1171     let _ = fo.end_time in
1172     let _ = base in
1173     let _ = Followers.State.(of_actor tnow Accepted siac)
1174             |> update ~cdb:subscribed_to siac.id in
1175     let _ = Subscribed_to.Json.(Make.make [rule] target) in
1176     let _ = Subscribed_to.Atom.(Make.make [rule] target) in
1177     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "created")
1178     |> Lwt.return
1179 end
1180
1181 let rcv_reject
1182     ?(tnow = Ptime_clock.now ())
1183     ~uuid
1184     ~base
1185     (siac : As2_vocab.Types.person)
1186     o =
1187   Logr.debug (fun m -> m "%s.%s %a %a" "Ap" "rcv_reject" Uri.pp siac.id Uuidm.pp uuid);
1188   let _ = tnow
1189   and _ = base
1190   in
1191   (match o with
1192    | `Follow (fo : As2_vocab.Types.follow) ->
1193      Logr.info (fun m -> m "%s.%s Follow request rejected by %a" "Ap" "rcv_reject" Uri.pp fo.object_);
1194      let _ = Following.remove fo.object_ in
1195      let _ = Following.Subscribed_to.Json.(Make.make [rule] target) in
1196      let _ = Following.Subscribed_to.Atom.(Make.make [rule] target) in
1197      (* @TODO: add a notification to the timeline? *)
1198      Ok (`OK, [Http.H.ct_plain], Cgi.Response.body "ok")
1199    | _ ->
1200      Logr.err (fun m -> m "%s.%s TODO" "Ap" "rcv_reject");
1201      Http.s501)
1202   |> Lwt.return
1203
1204 module Note = struct
1205   let empty = ({
1206       id          = Uri.empty;
1207       agent       = None;
1208       attachment  = [];
1209       attributed_to = Uri.empty;
1210       cc          = [];
1211       content_map = [];
1212       in_reply_to = [];
1213       reaction_inbox = None;
1214       media_type  = (Some Http.Mime.text_html); (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
1215       published   = None;
1216       sensitive   = false;
1217       source      = None;
1218       summary_map = [];
1219       tags        = [];
1220       to_         = [];
1221       url         = [];
1222     } : As2_vocab.Types.note)
1223
1224   let actor_from_author _author =
1225     Uri.make ~path:proj ()
1226
1227   let followers actor =
1228     Uri.make ~path:"subscribers/index.jsa" () |> Http.reso ~base:actor
1229
1230   let of_rfc4287
1231       ?(to_ = [As2_vocab.Constants.ActivityStreams.public])
1232       (e : Rfc4287.Entry.t)
1233     : As2_vocab.Types.note =
1234     Logr.debug (fun m -> m "%s.%s %a" "Ap.Note" "of_rfc4287" Uri.pp e.id);
1235     let tag init (lbl,term,base) =
1236       let ty = `Hashtag in
1237       let open Rfc4287.Category in
1238       let Label (Single name) = lbl
1239       and Term (Single term) = term in
1240       let path = term ^ "/" in
1241       let href = Uri.make ~path () |> Http.reso ~base  in
1242       let ta : As2_vocab.Types.tag = {ty; name; href} in
1243       ta :: init
1244     in
1245     let id = e.id in
1246     let actor = actor_from_author e.author in
1247     let cc = [actor |> followers] in
1248     let Rfc3339.T published = e.published in
1249     let published = match published |> Ptime.of_rfc3339 with
1250       | Ok (t,_,_) -> Some t
1251       | _ -> None  in
1252     let tags = e.categories |> List.fold_left tag [] in
1253     let Rfc4287.Rfc4646 lang = e.lang in
1254     let summary_map = [lang,e.title] in
1255     let content_map = [lang,e.content] in
1256     let url = e.links |> List.fold_left (
1257         (* sift, use those without a rel *)
1258         fun i (l : Rfc4287.Link.t) ->
1259           match l.rel with
1260           | None   -> l.href :: i
1261           | Some _ -> i) [] in
1262     {empty with
1263      id;
1264      content_map;
1265      attributed_to = actor;
1266      cc;
1267      media_type = Some Http.Mime.text_plain;
1268      published;
1269      summary_map;
1270      tags;
1271      to_;
1272      url;
1273     }
1274
1275   let to_rfc4287 ~tz ~now (n : As2_vocab.Types.note) : Rfc4287.Entry.t =
1276     let _ = tz
1277     and _ = now in
1278     Logr.debug (fun m -> m "%s.%s %a" "Ap.Note" "to_rfc4287" Uri.pp n.id);
1279     let published = n.published |> Option.value ~default:now |> Rfc3339.of_ptime ~tz
1280     and author    = {Rfc4287.Person.empty with
1281                      name = (match n.attributed_to |> Uri.user with
1282                          | None   -> n.attributed_to |> Uri.to_string
1283                          | Some u -> u );
1284                      uri = Some n.attributed_to} in
1285     let a (s,_,_) = s in
1286     let (lang,cont) = n.content_map |> List.hd in
1287     let sum = try let _,s = n.summary_map |> List.hd in
1288         Some s
1289       with Failure _ -> None in
1290     let links = match n.reaction_inbox with
1291       | None -> []
1292       | Some ib -> [Rfc4287.Link.(make ~rel:(Some inbox) ib )]
1293     in
1294     {Rfc4287.Entry.empty with
1295      id           = n.id;
1296      author;
1297      lang         = Rfc4287.Rfc4646 lang;
1298      title        = sum |> Option.value ~default:"" |> Html.to_plain |> a;
1299      content      = cont |> Html.to_plain |> a;
1300      published;
1301      links;
1302      updated      = published;
1303      in_reply_to  = n.in_reply_to |> List.map Rfc4287.Inreplyto.make;
1304     }
1305
1306   (** Not implemented yet *)
1307   let plain_to_html s : string =
1308     (* care about :
1309      * - newlines
1310      * - urls
1311      * - tags
1312      * - mentions
1313     *)
1314     s
1315
1316   let html_to_plain _s =
1317     failwith "not implemented yet."
1318
1319   let sensitive_marker = "⚠️"
1320
1321   (** Turn text/plain to text/html, add set id as self url
1322
1323       Mastodon interprets summary as content warning indicator. . *)
1324   let diluviate (n : As2_vocab.Types.note) =
1325     let sensitive,summary_map = n.summary_map |> List.fold_left (fun (sen,suma) (l,txt) ->
1326         let sen = sen || (txt |> Astring.String.is_prefix ~affix:sensitive_marker) in
1327         let html = txt |> plain_to_html in
1328         sen,(l,html) :: suma)
1329         (n.sensitive,[]) in
1330     (* add all urls before the content (in each language) *)
1331     let ur = n.url |> List.fold_left (fun i u ->
1332         let s = u |> Uri.to_string in
1333         Printf.sprintf "%s<a href='%s'>%s</a><br/>\n" i s s) "" in
1334     let content_map = n.content_map |> List.fold_left (fun init (l,co) ->
1335         (* if not warning, fetch summary of content language *)
1336         let su = match sensitive with
1337           | true -> ""
1338           | false -> match summary_map |> List.assoc_opt l with
1339             | None -> ""
1340             | Some su -> su ^ "<br/>\n" in
1341         let txt = su
1342                   ^ ur
1343                   ^ (if su |> String.equal "" && ur |> String.equal ""
1344                      then ""
1345                      else "<br/>\n")
1346                   ^ (co |> plain_to_html) in
1347         (l,txt) :: init) []
1348     in
1349     {n with
1350      content_map;
1351      sensitive;
1352      summary_map = if sensitive then summary_map else [];
1353      url = [n.id] }
1354
1355   (** https://www.w3.org/TR/activitypub/#create-activity-outbox *)
1356   module Create = struct
1357     let make (obj : As2_vocab.Types.note) : As2_vocab.Types.note As2_vocab.Types.create =
1358       let frag = match obj.id |> Uri.fragment with
1359         | None -> Some "Create"
1360         | Some f -> Some (f ^ "/Create") in
1361       {
1362         id             = frag |> Uri.with_fragment obj.id;
1363         actor          = obj.attributed_to;
1364         published      = obj.published;
1365         to_            = obj.to_;
1366         cc             = obj.cc;
1367         direct_message = false;
1368         obj            = obj; (* {obj with to_ = []; cc = []}; *)
1369       }
1370
1371     (** turn an Atom entry into an ActivityPub (Mastodon) Create Note activity. *)
1372     let to_json ~base n =
1373       let lang = As2_vocab.Constants.ActivityStreams.und in
1374       n
1375       |> of_rfc4287
1376       |> diluviate
1377       |> make
1378       |> As2_vocab.Encode.(create ~base ~lang (note ~base))
1379   end
1380
1381   (** Rather use a tombstone? https://www.w3.org/TR/activitypub/#delete-activity-outbox *)
1382   module Delete = struct
1383     let make (obj : As2_vocab.Types.note) : As2_vocab.Types.note As2_vocab.Types.delete =
1384       let frag = match obj.id |> Uri.fragment with
1385         | None -> Some "Delete"
1386         | Some f -> Some (f ^ "/Delete") in
1387       {
1388         id             = frag |> Uri.with_fragment obj.id;
1389         actor          = obj.attributed_to;
1390         published      = obj.published; (* rather use tnow *)
1391         obj            = obj;
1392       }
1393
1394     let to_json ~base n =
1395       n
1396       |> of_rfc4287
1397       |> make
1398       |> As2_vocab.Encode.(delete ~base (note ~base))
1399   end
1400
1401   let _5381_63 = 5381 |> Optint.Int63.of_int
1402
1403   (* http://cr.yp.to/cdb/cdb.txt *)
1404   let hash63_gen len f_get : Optint.Int63.t =
1405     let mask     = Optint.Int63.max_int
1406     and ( +. )   = Optint.Int63.add
1407     and ( << )   = Optint.Int63.shift_left
1408     and ( ^ )    = Optint.Int63.logxor
1409     and ( land ) = Optint.Int63.logand in
1410     let rec fkt (idx : int) (h : Optint.Int63.t) =
1411       if idx = len
1412       then h
1413       else
1414         let c = idx |> f_get |> Char.code |> Optint.Int63.of_int in
1415         (((h << 5) +. h) ^ c) land mask
1416         |> fkt (succ idx)
1417     in
1418     fkt 0 _5381_63
1419
1420   let hash63_str dat : Optint.Int63.t =
1421     hash63_gen (String.length dat) (String.get dat)
1422
1423   let uhash ?(off = 0) ?(buf = Bytes.make (Optint.Int63.encoded_size) (Char.chr 0)) u =
1424     u
1425     |> Uri.to_string
1426     |> hash63_str
1427     |> Optint.Int63.encode buf ~off;
1428     buf
1429     |> Bytes.to_string
1430     |> Base64.encode_string ~pad:false ~alphabet:Base64.uri_safe_alphabet
1431
1432   let ibc_dir = "app/var/cache/inbox/"
1433
1434   (** not just Note *)
1435   let to_file ~msg_id ~prefix ~dir json =
1436     let fn = msg_id
1437              |> uhash
1438              |> Printf.sprintf "%s%s.json" prefix in
1439     let tmp = dir ^ "tmp/" ^ fn in
1440     (dir ^ "new/" ^ fn) |> File.out_channel_create ~tmp
1441       (fun oc ->
1442          json
1443          |> Ezjsonm.value_to_channel oc)
1444
1445   let do_cache
1446       ?(tnow = Ptime_clock.now ())
1447       ?(dir = ibc_dir)
1448       ~(base : Uri.t)
1449       (a : As2_vocab.Types.note As2_vocab.Types.create) =
1450     let _ = tnow in
1451     Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Note" "do_cache" Uri.pp a.id);
1452     assert (a.actor |> Uri.user |> Option.is_some);
1453     assert (a.obj.attributed_to |> Uri.user |> Option.is_some);
1454     a
1455     |> As2_vocab.Encode.(create ~base (note ~base))
1456     |> to_file ~msg_id:a.id ~prefix:"note-" ~dir
1457
1458   let do_cache'
1459       ?(tnow = Ptime_clock.now ())
1460       ?(dir = ibc_dir)
1461       ~(base : Uri.t)
1462       (a : As2_vocab.Types.note As2_vocab.Types.update) =
1463     let _ = tnow in
1464     Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Note" "do_cache'" Uri.pp a.id);
1465     assert (a.actor |> Uri.user |> Option.is_some);
1466     assert (a.obj.attributed_to |> Uri.user |> Option.is_some);
1467     a
1468     |> As2_vocab.Encode.(update ~base (note ~base))
1469     |> to_file ~msg_id:a.id ~prefix:"note-" ~dir
1470
1471   let rcv_create
1472       ?(tnow = Ptime_clock.now ())
1473       ~uuid
1474       ~(base : Uri.t)
1475       (siac : As2_vocab.Types.person)
1476       (a : As2_vocab.Types.note As2_vocab.Types.create) : Cgi.Response.t' Lwt.t =
1477     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Note" "rcv_create" Uri.pp a.obj.attributed_to Uuidm.pp uuid);
1478     assert (a.actor |> Uri.equal siac.id);
1479     assert (a.actor |> Uri.equal a.obj.attributed_to);
1480     let actor = siac.preferred_username |> Uri.with_userinfo a.actor in
1481     let attributed_to = siac.preferred_username |> Uri.with_userinfo a.obj.attributed_to in
1482     let a = {a with actor} in
1483     let a = {a with obj = {a.obj with attributed_to}} in
1484     let _ = do_cache ~tnow ~base a in
1485     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "create")
1486     |> Lwt.return
1487
1488   let rcv_update
1489       ?(tnow = Ptime_clock.now ())
1490       ~uuid
1491       ~(base : Uri.t)
1492       (siac : As2_vocab.Types.person)
1493       (a : As2_vocab.Types.note As2_vocab.Types.update) : Cgi.Response.t' Lwt.t =
1494     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Note" "rcv_update" Uri.pp a.obj.attributed_to Uuidm.pp uuid);
1495     assert (a.actor |> Uri.equal siac.id);
1496     assert (a.actor |> Uri.equal a.obj.attributed_to);
1497     let actor = siac.preferred_username |> Uri.with_userinfo a.actor in
1498     let attributed_to = siac.preferred_username |> Uri.with_userinfo a.obj.attributed_to in
1499     let a = {a with actor} in
1500     let a = {a with obj = {a.obj with attributed_to}} in
1501     let _ = do_cache' ~tnow ~base a in
1502     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "update")
1503     |> Lwt.return
1504
1505 end
1506
1507 module Like = struct
1508   let do_cache
1509       ?(tnow = Ptime_clock.now ())
1510       ?(dir = Note.ibc_dir)
1511       ~(base : Uri.t)
1512       (a : As2_vocab.Types.like) =
1513     let _ = tnow in
1514     Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Like" "do_cache" Uri.pp a.id);
1515     assert (a.actor |> Uri.user |> Option.is_some);
1516     a
1517     |> As2_vocab.Encode.like ~base
1518     |> Note.to_file ~msg_id:a.id ~prefix:"like-" ~dir
1519
1520   let do_cache'
1521       ?(tnow = Ptime_clock.now ())
1522       ?(dir = Note.ibc_dir)
1523       ~(base : Uri.t)
1524       (a : As2_vocab.Types.like As2_vocab.Types.undo) =
1525     let _ = tnow in
1526     Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Like" "do_cache'" Uri.pp a.id);
1527     assert (a.actor |> Uri.user |> Option.is_some);
1528     a
1529     |> As2_vocab.Encode.(undo ~base (like ~base))
1530     |> Note.to_file ~msg_id:a.id ~prefix:"like-" ~dir
1531
1532   let rcv_like
1533       ?(tnow = Ptime_clock.now ())
1534       ~uuid
1535       ~(base : Uri.t)
1536       (siac : As2_vocab.Types.person)
1537       (a : As2_vocab.Types.like) : Cgi.Response.t' Lwt.t =
1538     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Like" "rcv_like" Uri.pp a.actor Uuidm.pp uuid);
1539     assert (a.actor |> Uri.equal siac.id);
1540     let actor = Uri.with_userinfo a.actor siac.preferred_username in
1541     let a = {a with actor} in
1542     let _ = do_cache ~tnow ~base a in
1543     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "like")
1544     |> Lwt.return
1545
1546   let rcv_like_undo
1547       ?(tnow = Ptime_clock.now ())
1548       ~uuid
1549       ~(base : Uri.t)
1550       (siac : As2_vocab.Types.person)
1551       (a : As2_vocab.Types.like As2_vocab.Types.undo) : Cgi.Response.t' Lwt.t =
1552     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Like" "rcv_like_undo" Uri.pp a.actor Uuidm.pp uuid);
1553     assert (a.actor |> Uri.equal siac.id);
1554     let actor = Uri.with_userinfo a.actor siac.preferred_username in
1555     let a = {a with actor} in
1556     let _ = do_cache' ~tnow ~base a in
1557     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "like")
1558     |> Lwt.return
1559 end
1560
1561 module Announce = struct
1562   let do_cache
1563       ?(tnow = Ptime_clock.now ())
1564       ?(dir = Note.ibc_dir)
1565       ~base
1566       (a : As2_vocab.Types.announce) =
1567     let _ = tnow in
1568     Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Announce" "do_cache" Uri.pp a.id);
1569     assert (a.actor |> Uri.user |> Option.is_some);
1570     a
1571     |> As2_vocab.Encode.announce ~base
1572     |> Note.to_file ~msg_id:a.id ~prefix:"anno-" ~dir
1573
1574   let do_cache'
1575       ?(tnow = Ptime_clock.now ())
1576       ?(dir = Note.ibc_dir)
1577       ~base
1578       (a : As2_vocab.Types.announce As2_vocab.Types.undo) =
1579     let _ = tnow in
1580     Logr.debug (fun m -> m "%s.%s TODO %a" "Ap.Announce" "do_cache'" Uri.pp a.id);
1581     assert (a.actor |> Uri.user |> Option.is_some);
1582     a
1583     |> As2_vocab.Encode.(undo ~base (announce ~base))
1584     |> Note.to_file ~msg_id:a.id ~prefix:"anno-" ~dir
1585
1586   let rcv_announce
1587       ?(tnow = Ptime_clock.now ())
1588       ~uuid
1589       ~base
1590       (siac : As2_vocab.Types.person)
1591       (a : As2_vocab.Types.announce) : Cgi.Response.t' Lwt.t =
1592     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Announce" "rcv_announce" Uri.pp a.actor Uuidm.pp uuid);
1593     assert (a.actor |> Uri.equal siac.id);
1594     let actor = Uri.with_userinfo a.actor siac.preferred_username in
1595     {a with actor} |> do_cache ~tnow ~base;
1596     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "announce")
1597     |> Lwt.return
1598
1599   let rcv_announce_undo
1600       ?(tnow = Ptime_clock.now ())
1601       ~uuid
1602       ~(base : Uri.t)
1603       (siac : As2_vocab.Types.person)
1604       (a : As2_vocab.Types.announce As2_vocab.Types.undo) : Cgi.Response.t' Lwt.t =
1605     Logr.debug (fun m -> m "%s.%s %a %a" "Ap.Announce" "rcv_announce_undo" Uri.pp a.actor Uuidm.pp uuid);
1606     assert (a.actor |> Uri.equal siac.id);
1607     let actor = Uri.with_userinfo a.actor siac.preferred_username in
1608     {a with actor} |> do_cache' ~tnow ~base;
1609     Ok (`Created, [Http.H.ct_plain], Cgi.Response.body "announce")
1610     |> Lwt.return
1611 end