123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368 |
- (*
- * _ _ ____ _
- * _| || |_/ ___| ___ _ __ _ __ ___ | |
- * |_ .. _\___ \ / _ \ '_ \| '_ \ / _ \| |
- * |_ _|___) | __/ |_) | |_) | (_) |_|
- * |_||_| |____/ \___| .__/| .__/ \___/(_)
- * |_| |_|
- *
- * 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>�x10;\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
|