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 time = time |> Ptime.to_rfc3339 ~tz_offset_s:0 |> E.string
let uri ~base u = u |> Uri.resolve "https" base |> Uri.to_string |> E.string
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 ?(context = None) ty ls =
  let ls = ls |> List.flatten in
  let ls = ("type", E.string ty) :: ls in
  let ls = match context 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 ~context: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 ~context: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 ?(context = None) ~base enc ({ id; actor; published; to_; cc; direct_message; obj(*(*; raw=_*)*) }:
                                          _ Types.create) =
  ap_obj ~context "Create" [
    "id"            @ id <: uri ~base;
    "actor"         @ actor <: uri ~base;
    "published"     @? published <: ptime;
    "to"            @ to_ <: E.(list (uri ~base));
    "cc"            @ cc <: E.(list (uri ~base));
    "directMessage" @ direct_message <: E.bool;
    "object"        @ obj <: enc;
  ]

let update ?(context = None) ~base enc ({ id; actor; published; to_; cc; direct_message; obj(*(*; raw=_*)*) }:
                                          _ Types.update) =
  ap_obj ~context "Update" [
    "id"            @ id <: uri ~base;
    "actor"         @ actor <: uri ~base;
    "published"     @? published <: ptime;
    "to"            @ to_ <: E.(list (uri ~base));
    "cc"            @ cc <: E.(list (uri ~base));
    "directMessage" @ direct_message <: E.bool;
    "object"        @ obj <: enc;
  ]

let announce ~base enc ({ id; actor; published; to_; cc; obj(*(*; raw=_*)*) } : _ Types.announce) =
  ap_obj ~context:Constants.ActivityStreams.und "Announce" [
    "id"        @ id <: uri ~base;
    "actor"     @ actor <: uri ~base;
    "published" @? published <: ptime;
    "to"        @ to_ <: E.(list (uri ~base));
    "cc"        @ cc <: E.(list (uri ~base));
    "object"    @ obj <: enc;
  ]

let accept ~base enc ({ id; actor; published; obj(*; raw=_*) } : _ Types.accept) =
  ap_obj ~context:Constants.ActivityStreams.und "Accept" [
    "id"        @ id <: uri ~base;
    "actor"     @ actor <: uri ~base;
    "published" @? published <: ptime;
    "object"    @ obj <: enc;
  ]

let reject ~base enc ({ id; actor; published; obj(*; raw=_*) } : _ Types.reject) =
  ap_obj ~context:Constants.ActivityStreams.und "Reject" [
    "id"        @ id <: uri ~base;
    "actor"     @ actor <: uri ~base;
    "published" @? published <: ptime;
    "object"    @ obj <: enc;
  ]

let undo ?(context = Constants.ActivityStreams.und) ~base enc ({ id; actor; published; obj(*; raw=_*) } : _ Types.undo) =
  ap_obj ~context "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 ~context: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 ~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=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 ~context "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      <: E.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 <: E.list property_value;
    "icon"                      @? ic <: image ~base;
    "image"                     @? im <: image ~base;
  ]

let state = function
    `Pending -> E.string "pending"
  | `Cancelled -> E.string "cancelled"


let follow ?(context = Constants.ActivityStreams.und) ~base ({ id; actor; cc; object_; to_; state=st(*; raw=_*) }: Types.follow) =
  ap_obj ~context "Follow" [
    "id"     @ id <: uri ~base;
    "actor"  @ actor <: uri ~base;
    "to"     @ to_ <: E.list (uri ~base);
    "cc"     @ cc <: E.list (uri ~base);
    "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 ?(context = None)
    ~base
    ({ id; actor; to_; in_reply_to; cc; media_type; content; content_map; sensitive; source; summary; summary_map;
       attachment=att;
       published; tags; url(*; raw=_*) }: Types.note) =
  let in_reply_to = match in_reply_to with
    | [] -> None (* ActivityStreams goes insane on optional lists being present but empty. https://www.w3.org/TR/activitystreams-vocabulary/#dfn-inreplyto *)
    | l  -> Some l in
  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
  let att = match att with [] -> None | _ -> Some att in
  ap_obj ~context "Note" [
    "id"         @ id           <: uri ~base;
    "actor"      @ actor        <: uri ~base;
    "attachment" @? att         <: E.list (attachment ~base);
    "to"         @ to_          <: E.list (uri ~base);
    "cc"         @ cc           <: E.list (uri ~base);
    "inReplyTo"  @? in_reply_to <: E.list (uri ~base);
    "mediaType"  @? media_type  <: E.string;
    "content"    @ content      <: E.string;
    "contentMap" @?. content_map<: E.obj;
    "sensitive"  @ sensitive    <: E.bool;
    "source"     @? source      <: uri ~base;
    "summary"    @? summary     <: E.string;
    "summaryMap" @?. summary_map<: E.obj;
    "published"  @? published   <: ptime;
    "tags"       @ tags         <: E.list (tag ~base);
    "url"        @ url          <: E.list (uri ~base);
  ]

let block ~base ({ id; obj; published; actor(*; raw=_*) }: Types.block) =
  ap_obj ~context:Constants.ActivityStreams.und "Block" [
    "id"        @ id <: uri ~base;
    "object"    @ obj <: uri ~base;
    "actor"     @ actor <: uri ~base;
    "published" @? published <: ptime;
  ]

let like ~base ({ id; actor; published; obj(*; raw=_*) }: Types.like) =
  ap_obj ~context:Constants.ActivityStreams.und "Like" [
    "id"        @ id <: uri ~base;
    "actor"     @ actor <: uri ~base;
    "object"    @ obj <: uri ~base;
    "published" @? published <: ptime;
  ]


let core_obj ?(context = 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
  | `Link r -> E.string r
  | `Note n -> note ~base n
  | `Person p -> person ~base ~context p

let event ~base enc : _ Types.event E.encoder = function
  | `Accept a -> accept ~base enc a
  | `Reject a -> reject ~base enc a
  | `Announce a -> announce ~base enc a
  | `Create c -> create ~base enc c
  | `Update c -> update ~base enc c
  | `Delete d -> delete ~base enc d
  | `Undo u -> undo ~base enc u

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