seppo/as2_vocab/encode.ml

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