123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360 |
- module E = Decoders_ezjsonm.Encode
- let (<:) = function
- | (_, None) -> fun _ -> []
- | (field, Some vl) -> fun ty -> [field, ty vl]
- let (@) field vl = (field, Some vl)
- let (@?) field vl = (field, vl)
- let (@?.) field vl = (field, match vl with | [] -> None | l -> Some l)
- let ptime ?(tz_offset_s = Some 0) time = time |> Ptime.to_rfc3339 ?tz_offset_s |> E.string
- let uri ~base u = u |> Uri.resolve "https" base |> Uri.to_string |> E.string
- let jsonld_list a = function
- (* don't know if that's in ActivityPub, ActivityStreams or JSONLD *)
- (* ActivityStreams goes insane on optional lists being present but empty. https://www.w3.org/TR/activitystreams-vocabulary/#dfn-inreplyto *)
- | [] -> E.null (* none => null *)
- | [b] -> E.encode_value a b (* single => value *)
- | b -> E.list a b (* many => array *)
- let obj ls = E.obj @@ List.flatten ls
- let obj0 ls =
- let ls = ls |> List.flatten in
- let ls = ("@context", `A [ `O [ "@language", `Null ] ]) :: ls in
- E.obj ls
- let ap_obj ?(lang = None) ty ls =
- let ls = ls |> List.flatten in
- let ls = ("type", E.string ty) :: ls in
- let ls = match lang with
- | None -> ls
- | Some lang -> Constants.ActivityStreams.context lang :: ls in
- E.obj ls
- let or_raw conv = function
- | `Raw v -> v
- | `Value v -> conv v
- (** https://www.w3.org/TR/activitystreams-core/#collections *)
- let collection_page ~base enc
- ({ id;
- current;
- first;
- is_ordered;
- items;
- last;
- next;
- part_of;
- prev;
- total_items
- }: _ Types.collection_page) =
- ap_obj ~lang:Constants.ActivityStreams.und "OrderedCollectionPage" [
- "id" @ id <: uri ~base;
- "current" @? current <: uri ~base;
- "first" @? first <: uri ~base;
- "last" @? last <: uri ~base;
- "next" @? next <: uri ~base;
- "partOf" @? part_of <: uri ~base;
- "prev" @? prev <: uri ~base;
- "totalItems" @? total_items <: E.int;
- (match is_ordered with
- | true -> "orderedItems"
- | false -> "items") @ items <: E.list enc
- ]
- let collection ~base enc
- ({ id;
- current;
- first;
- is_ordered;
- items;
- last;
- total_items;
- }: _ Types.collection) =
- ap_obj ~lang:Constants.ActivityStreams.und "OrderedCollection" [
- "id" @ id <: uri ~base;
- "current" @? current <: uri ~base;
- "first" @? first <: uri ~base;
- "last" @? last <: uri ~base;
- "totalItems" @? total_items <: E.int;
- (match is_ordered with
- | true -> "orderedItems"
- | false -> "items") @? items <: E.list enc
- ]
- let create ?(lang = None) ~base enc ({ id; actor; published; to_; cc; direct_message; obj(*(*; raw=_*)*) }:
- _ Types.create) =
- ap_obj ~lang "Create" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "to" @?. to_ <: jsonld_list (uri ~base);
- "cc" @?. cc <: jsonld_list (uri ~base);
- "directMessage" @ direct_message <: E.bool;
- "object" @ obj <: enc;
- ]
- let update ?(lang = None) ~base enc ({ id; actor; published; to_; cc; direct_message; obj(*(*; raw=_*)*) }:
- _ Types.update) =
- ap_obj ~lang "Update" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "to" @?. to_ <: jsonld_list (uri ~base);
- "cc" @?. cc <: jsonld_list (uri ~base);
- "directMessage" @ direct_message <: E.bool;
- "object" @ obj <: enc;
- ]
- let accept ~base enc ({ id; actor; published; end_time; obj(*; raw=_*) } : _ Types.accept) =
- ap_obj ~lang:Constants.ActivityStreams.und "Accept" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "endTime" @? end_time <: ptime;
- "object" @ obj <: enc;
- ]
- let reject ~base enc ({ id; actor; published; obj(*; raw=_*) } : _ Types.reject) =
- ap_obj ~lang:Constants.ActivityStreams.und "Reject" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "object" @ obj <: enc;
- ]
- let undo ?(lang = Constants.ActivityStreams.und) ~base enc ({ id; actor; published; obj(*; raw=_*) } : _ Types.undo) =
- ap_obj ~lang "Undo" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "object" @ obj <: enc;
- ]
- let delete ~base enc ({ id; actor; published; obj(*; raw=_*) } : _ Types.delete) =
- ap_obj ~lang:Constants.ActivityStreams.und "Delete" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "object" @ obj <: enc;
- ]
- (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-link *)
- let link ?(base = Uri.empty) ({ href; name; name_map; rel } : Types.link) =
- let _ = name_map
- and _ = rel in
- obj [
- "type" @ "Link" <: E.string;
- "href" @ href <: uri ~base;
- "name" @? name <: E.string;
- "nameMap" @?. [] <: E.obj;
- ]
- (** * Objects *)
- let public_key ~base (key: Types.public_key) =
- obj0 [
- "id" @ key.id <: uri ~base;
- "owner" @? key.owner <: uri ~base;
- "publicKeyPem" @ key.pem <: E.string;
- "signatureAlgorithm" @? key.signatureAlgorithm <: E.string;
- ]
- let property_value (v : Types.property_value) =
- let kv f (k,v) = (k,f v) in
- let name_map = v.name_map |> List.map (kv E.string) in
- let value_map = v.value_map |> List.map (kv E.string) in
- obj [
- "type" @ "PropertyValue" <: E.string;
- "name" @ v.name <: E.string;
- "nameMap" @?. name_map <: E.obj;
- "value" @ v.value <: E.string;
- "valueMap" @?. value_map <: E.obj;
- ]
- let image ~base url =
- obj [
- "type" @ "Image" <: E.string;
- (* mediatype? *)
- "url" @ url <: uri ~base;
- ]
- let person ~base ~lang
- ({ id; name; name_map; url; inbox; outbox;
- preferred_username; preferred_username_map; summary; summary_map;
- manually_approves_followers;
- discoverable; generator; followers; following;
- public_key=key; published; attachment; icon=ic; image=im(*; raw=_*) }: Types.person) =
- let name_map = name_map |> List.map (fun (k,v) -> (k,E.string v)) in
- let preferred_username_map = preferred_username_map |> List.map (fun (k,v) -> (k,E.string v)) in
- let summary_map = summary_map |> List.map (fun (k,v) -> (k,E.string v)) in
- ap_obj ~lang "Person" [
- "id" @ id <: uri ~base;
- "inbox" @ inbox <: uri ~base;
- "outbox" @ outbox <: uri ~base;
- "followers" @? followers <: uri ~base;
- "following" @? following <: uri ~base;
- "name" @? name <: E.string;
- "nameMap" @?. name_map <: E.obj;
- "url" @?. url <: jsonld_list (uri ~base);
- "preferredUsername" @? preferred_username <: E.string;
- "preferredUsernameMap" @?. preferred_username_map <: E.obj;
- "summary" @? summary <: E.string;
- "summaryMap" @?. summary_map <: E.obj;
- "publicKey" @ key <: public_key ~base;
- "published" @? published <: ptime;
- "manuallyApprovesFollowers" @ manually_approves_followers <: E.bool;
- "discoverable" @ discoverable <: E.bool;
- "generator" @? generator <: link;
- "attachment" @?. attachment <: jsonld_list property_value;
- "icon" @?. ic <: jsonld_list (image ~base);
- "image" @? im <: image ~base;
- ]
- let state = function
- | `Pending -> E.string "pending"
- | `Cancelled -> E.string "cancelled"
- (** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-follow *)
- let follow ?(lang = Constants.ActivityStreams.und) ~base ({ id; actor; cc; end_time; object_; to_; state=st(*; raw=_*) }: Types.follow) =
- ap_obj ~lang "Follow" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "to" @?. to_ <: jsonld_list (uri ~base);
- "cc" @?. cc <: jsonld_list (uri ~base);
- "endTime" @? end_time <: ptime;
- "object" @ object_ <: uri ~base;
- "state" @? st <: state;
- ]
- (* https://www.w3.org/TR/activitystreams-vocabulary/#microsyntaxes *)
- let tag ~base ({ ty; href; name }: Types.tag) =
- let ty,pre = match ty with
- | `Mention -> "Mention","@"
- | `Hashtag -> "Hashtag","#" in
- ap_obj ty [
- "href" @ href <: uri ~base;
- "name" @ (pre ^ name) <: E.string;
- ]
- let attachment ~base ({media_type; name; url; type_}: Types.attachment) =
- obj [
- "type" @? type_ <: E.string;
- "mediaType" @? media_type <: E.string;
- "name" @? name <: E.string;
- "url" @ url <: uri ~base;
- ]
- let note ?(lang = None)
- ~base
- ({ id; agent; to_; in_reply_to; attributed_to; cc; reaction_inbox; media_type; content_map; sensitive; source; summary_map;
- attachment=att;
- published; tags; url(*; raw=_*) }: Types.note) =
- let content_map = content_map |> List.map (fun (k,v) -> (k,E.string v)) in
- let summary_map = summary_map |> List.map (fun (k,v) -> (k,E.string v)) in
- ap_obj ~lang "Note" [
- "id" @ id <: uri ~base;
- "_agent" @? agent <: E.string;
- "attachment" @?. att <: jsonld_list (attachment ~base);
- "attributedTo" @ attributed_to <: uri ~base;
- "to" @?. to_ <: jsonld_list (uri ~base);
- "cc" @?. cc <: jsonld_list (uri ~base);
- "inReplyTo" @?. in_reply_to<: jsonld_list (uri ~base);
- "_reaction_inbox" @? reaction_inbox <: uri ~base;
- "mediaType" @? media_type <: E.string;
- "contentMap" @?. content_map<: E.obj;
- "sensitive" @ sensitive <: E.bool;
- "source" @? source <: uri ~base;
- "summaryMap" @?. summary_map<: E.obj;
- "published" @? published <: ptime;
- "tags" @?. tags <: jsonld_list (tag ~base);
- "url" @?. url <: jsonld_list (uri ~base);
- ]
- let block ~base ({ id; obj; published; actor(*; raw=_*) }: Types.block) =
- ap_obj ~lang:Constants.ActivityStreams.und "Block" [
- "id" @ id <: uri ~base;
- "object" @ obj <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- ]
- let announce ~base ?(lang = Constants.ActivityStreams.und) ({ id; actor; published; to_; cc; obj(*(*; raw=_*)*) } : Types.announce) =
- ap_obj ~lang "Announce" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "published" @? published <: ptime;
- "to" @?. to_ <: jsonld_list (uri ~base);
- "cc" @?. cc <: jsonld_list (uri ~base);
- "object" @ obj <: uri ~base;
- ]
- let like ~base ?(lang = Constants.ActivityStreams.und) ({ id; actor; obj(*; raw=_*) }: Types.like) =
- ap_obj ~lang "Like" [
- "id" @ id <: uri ~base;
- "actor" @ actor <: uri ~base;
- "object" @ obj <: uri ~base;
- ]
- let core_obj ?(lang = Constants.ActivityStreams.und) ~base : Types.core_obj E.encoder = function
- | `Block b -> block ~base b
- | `Follow f -> follow ~base f
- | `Like l -> like ~base l
- | `Announce a -> announce ~base a
- | `Link r -> E.string r
- | `Note n -> note ~base n
- | `Person p -> person ~base ~lang p
- let event ~base enc : _ Types.event E.encoder = function
- | `Accept a -> accept ~base enc a
- | `Create c -> create ~base enc c
- | `Delete d -> delete ~base enc d
- | `Reject a -> reject ~base enc a
- | `Undo u -> undo ~base enc u
- | `Update c -> update ~base enc c
- let object_ ~base : Types.obj E.encoder = function
- | #Types.core_obj as c -> core_obj ~base c
- | #Types.core_event as e -> event ~base (core_obj ~base) e
- module Webfinger = struct
- let ty = function
- | `ActivityJson_ -> E.string Constants.ContentType._app_act_json
- | `ActivityJsonLd -> E.string Constants.ContentType.app_jlda
- | `Atom -> E.string Constants.ContentType.app_atom_xml
- | `Html -> E.string Constants.ContentType.text_html
- | `Json -> E.string Constants.ContentType.app_json
- | `Xml -> E.string Constants.ContentType.text_xml
- let link ~base = function
- | Types.Webfinger.Self (t, href) -> obj [
- "href" @ href <: uri ~base;
- "rel" @ Constants.Webfinger.self_rel <: E.string;
- "type" @ t <: ty;
- ]
- | ProfilePage (t, href) -> obj [
- "href" @ href <: uri ~base;
- "rel" @ Constants.Webfinger.profile_page <: E.string;
- "type" @ t <: ty;
- ]
- | Alternate (t, href) -> obj [
- "href" @ href <: uri ~base;
- "rel" @ Constants.Webfinger.alternate <: E.string;
- "type" @ t <: ty;
- ]
- | OStatusSubscribe template -> obj [
- "rel" @ Constants.Webfinger.ostatus_rel <: E.string;
- "template" @ template <: E.string;
- ]
- let query_result ~base ({subject;aliases;links}: Types.Webfinger.query_result) =
- let l = ( "links" @ links <: E.list (link ~base); ) :: [] in
- let l = match aliases with
- | [] -> l
- | _ -> ( "aliases" @ aliases <: E.(list string); ) :: l in
- let l = ( "subject" @ subject <: E.string; ) :: l in
- obj l
- end
|