seppo/as2_vocab/decode.ml

(* has an alloc, but part of ocaml >= 4.13 anyway *)
let starts_with ~prefix s =
  let lp = prefix |> String.length in
  lp <= (s |> String.length)
  && (prefix |> String.equal (String.sub s 0 lp))
let string_prefix ~pre = starts_with ~prefix:pre

open Common

let decode_string enc vl = D.decode_string enc vl
                           |> Result.map_error D.string_of_error

let uri dec =
  Result.bind
    (D.string dec)
    (fun s -> D.succeed (s |> Uri.of_string) dec)

let collection_page obj =
  let open D in
  let* ()                  = field "type" @@ constant ~msg:"Expected OrderedCollectionPage (received %s)" "OrderedCollectionPage"
  and* id                  = field "id" uri
  and* next                = field_opt "next" uri
  and* first               = field_opt "first" uri
  and* last                = field_opt "last" uri
  and* current             = field_opt "current" uri
  and* prev                = field_opt "prev" uri
  and* part_of             = field_opt "partOf" uri
  and* total_items         = field_opt "totalItems" int
  and* (is_ordered, items) = items obj in
  succeed ({id;
            current;
            first;
            is_ordered;
            items;
            last;
            next;
            part_of;
            prev;
            total_items;
           }: _ Types.collection_page)

let collection obj =
  let open D in
  let* ()          = field "type" @@ constant ~msg:"Expected OrderedCollection (received %s)" "OrderedCollection"
  and* id                  = field "id" uri
  and* first               = field_opt "first" uri
  and* last                = field_opt "last" uri
  and* current             = field_opt "current" uri
  and* total_items         = field_opt "totalItems" int
  and* items'              = items_opt obj in
  let (is_ordered,items)   = match items' with
    | Some (b,l) -> (b,Some l)
    | None -> (false,None) in
  succeed ({id;
            current;
            first;
            is_ordered;
            items;
            last;
            total_items;
           }: _ Types.collection)

let mention =
  let open D in
  let* ()   = field "type" @@ constant ~msg:"expected Mention (received %s)" "Mention"
  and* href = field "href" uri
  and* name = field "name" string in
  succeed ({ty=`Mention; href;name} : Types.tag)

let hashtag =
  let open D in
  let* ()   = field "type" @@ constant ~msg:"expected Hashtag (received %s)" "Hashtag"
  and* href = field "href" uri
  and* name = field "name" string in
  succeed ({ty=`Hashtag; href;name}: Types.tag)

let tag =
  let open D in
  let* ty = field "type" string in
  match ty with
  | "Mention" -> mention
  | "Hashtag" -> hashtag
  | _ -> fail (Printf.sprintf "unknown tag %s" ty)

let undo obj =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected Undo (received %s)" "Undo"
  and* id        = field "id" uri
  and* actor     = field "actor" uri
  and* published = field_opt "published" rfc3339
  and* obj       = field "object" obj
  (* and* raw = value *) in
  succeed ({id;published;actor;obj(*;raw*)}: _ Types.undo)

let like =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected Like (received %s)" "Like"
  and* id        = field "id" uri
  and* actor     = field "actor" uri
  and* published = field_opt "published" rfc3339
  and* obj       = field "object" uri
  (* and* raw = value *) in
  succeed ({id; actor; published; obj (*; raw*)}: Types.like)

let tombstone =
  let open D in
  let* () = field "type" @@ constant ~msg:"expected Tombstone (received %s)" "Tombstone"
  and* id = field "id" uri in
  succeed id

let delete obj =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected Delete (received %s)" "Delete"
  and* id        = field "id" uri
  and* actor     = field "actor" uri
  and* published = field_opt "published" rfc3339
  and* obj       = field "object" obj
  (* and* raw = value *) in
  succeed ({id;published;actor;obj(*;raw*)}: _ Types.delete)

let block =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected Block (received %s)" "Block"
  and* id        = field "id" uri
  and* obj       = field "object" uri
  and* published = field_opt "published" rfc3339
  and* actor     = field "actor" uri
  (* and* raw = value *) in
  succeed ({id;published;obj;actor(*;raw*)}: Types.block)

let accept obj =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected Accept (received %s)" "Accept"
  and* id        = field "id" uri
  and* actor     = field "actor" uri
  and* published = field_opt "published" rfc3339
  and* obj       = field "object" obj
  (*and* raw = value *) in
  succeed ({id;published;actor;obj(*;raw*)}: _ Types.accept)

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-link *)
let link =
  let open D in
  (*
  let* ()    = field "type" @@ constant ~msg:"expected Link (received %s)" "Link"
  and* href  = field "href" uri
  and* name  = field_opt "name" string in
  let name_map = []
  and rel = None in
  succeed (Some ({href;name;name_map;rel}: Types.link))
  *)
  succeed None

let public_key =
  let open D in
  let* id    = field "id" uri
  and* owner = field_opt "owner" uri
  and* pem   = field "publicKeyPem" string
  and* signatureAlgorithm = field_opt "signatureAlgorithm" string in
  succeed ({id;owner;pem;signatureAlgorithm}: Types.public_key)

let property_value =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected PropertyValue (received %s)" "PropertyValue" in
  let* name      = field "name" string
  and* name_map  = field_or_default "nameMap" (key_value_pairs string) []
  and* value     = field "value" string 
  and* value_map = field_or_default "valueMap" (key_value_pairs string) [] in
  succeed ({name;name_map;value;value_map}: Types.property_value)

let attachment =
  let open D in
  let* media_type = field_opt "mediaType" string
  and* name       = field_opt "name" string
  and* type_      = field_opt "type" string
  and* url        = field "url" uri in
  succeed ({media_type;name;type_;url}: Types.attachment)

let person =
  let open D in
  (* how would we get the default @language from the @context? *)
  let* ()                          =  one_of [
      "type", field "type" @@ constant ~msg:"expected Person (received %s)" "Person";
      (* pleroma uses type='service' at times. *)
      "type", field "type" @@ constant ~msg:"expected Service (received %s)" "Service";
    ]
  and* id                          = field            "id" uri
  and* name                        = field_or_default "name" (nullable string) None
  and* name_map                    = field_or_default "nameMap" (key_value_pairs string) []
  and* url                         = field_or_default "url" (singleton_or_list uri) []
  and* preferred_username          = field_opt        "preferredUsername" string
  and* preferred_username_map      = field_or_default "preferredUsernameMap" (key_value_pairs string) []
  and* inbox                       = field            "inbox" uri
  and* outbox                      = field            "outbox" uri
  and* summary                     = field_opt        "summary" string
  and* summary_map                 = field_or_default "summaryMap" (key_value_pairs string) []
  and* public_key                  = field            "publicKey" public_key
  and* published                   = field_opt        "published" rfc3339
  and* manually_approves_followers = field_or_default "manuallyApprovesFollowers" bool false
  and* discoverable                = field_or_default "discoverable" bool false
  and* generator                   = field_or_default "generator" link None
  and* followers                   = field_opt        "followers" uri
  and* following                   = field_opt        "following" uri
  and* attachment                  = field_or_default "attachment" (list_ignoring_unknown property_value) []
  and* icon                        = maybe            (at ["icon";"url"] uri)
  and* image                       = maybe            (at ["image";"url"] uri)
  (* and* raw = value *) in
  succeed ({
      id;
      inbox;
      outbox;
      followers;
      following;

      name; name_map;
      url;

      preferred_username; preferred_username_map;

      summary; summary_map;
      public_key;
      published;
      manually_approves_followers;
      discoverable;
      generator;
      attachment;
      icon;
      image;
      (* raw; *)
    }: Types.person)

let note =
  let open D in
  let* ()          = field "type" @@ constant ~msg:"expected Note (received %s)" "Note"
  and* id          = field "id" uri
  and* actor       = one_of ["actor", field "actor" uri; "attributed_to", field "attributedTo" uri]
  and* attachment  = field_or_default "attachment" (singleton_or_list attachment) []
  and* to_         = field "to" (singleton_or_list uri)
  and* in_reply_to = field_or_default "inReplyTo" (singleton_or_list uri) []
  and* cc          = field_or_default "cc" (singleton_or_list uri) []
  and* content     = field "content" string
  and* content_map = field_or_default "contentMap" (key_value_pairs string) []
  and* source      = field_opt "source"
      (one_of ["string", uri; "multi-encode", field "content" uri])
  and* summary     = field_or_default "summary" (nullable string) None
  and* summary_map = field_or_default "summaryMap" (key_value_pairs string) []
  and* sensitive   = field_or_default "sensitive" (nullable bool) None
  and* media_type  = field_opt "mediaType" string
  and* published   = field_opt "published" rfc3339
  and* tags        = field_or_default "tag" (list_ignoring_unknown tag) []
  and* url         = field "url" (singleton_or_list uri)
  (* and* raw = value *) in
  succeed ({ id; actor; attachment; in_reply_to; to_; cc;
             sensitive=Option.value ~default:false sensitive;
             media_type; content; content_map; source; summary; summary_map; tags; published; url(*; raw*) }: Types.note)

let follow =
  let open D in
  let* ()      = field "type" @@ constant ~msg:"expected create object (received %s)" "Follow"
  and* actor   = field "actor" uri
  and* cc      = field_or_default "cc" (singleton_or_list uri) []
  and* to_     = field_or_default "to" (singleton_or_list uri) []
  and* id      = field "id" uri
  and* object_ = field "object" uri
  and* state   = field_opt "state" (string >>= function "pending" -> succeed `Pending
                                                      | "cancelled" -> succeed `Cancelled
                                                      | _ -> fail "unknown status")
  (* and* raw = value *) in
  succeed ({actor; cc; to_; id; object_; state(*; raw*)}: Types.follow)

let announce obj =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected create object (received %s)" "Announce"
  and* actor     = field "actor" uri
  and* id        = field "id" uri
  and* published = field_opt "published" rfc3339
  and* to_       = field "to" (singleton_or_list uri)
  and* cc        = field_or_default "cc" (singleton_or_list uri) []
  and* obj       = field "object" obj
  (* and* raw = value *) in
  succeed ({id; published; actor; to_; cc; obj(* ; raw*)}: _ Types.announce)

let create obj =
  let open D in
  let* ()             = field "type" @@ constant ~msg:"expected create object (received %s)" "Create"
  and* id             = field "id" uri
  and* actor          = field "actor" uri
  and* direct_message = field_or_default "direct" bool false
  and* published      = field_opt "published" rfc3339
  and* to_            = field_or_default "to" (singleton_or_list uri) []
  and* cc             = field_or_default "cc" (singleton_or_list uri) []
  and* obj            = field "object" obj
  (* and* raw = value *) in

  succeed ({
      id; actor; published;
      to_; cc;
      direct_message;
      obj;
      (*raw;*)
    }: _ Types.create)

let update obj =
  let open D in
  let* ()             = field "type" @@ constant ~msg:"expected create object (received %s)" "Update"
  and* id             = field "id" uri
  and* actor          = field "actor" uri
  and* direct_message = field_or_default "direct" bool false
  and* published      = field_opt "published" rfc3339
  and* to_            = field_or_default "to" (singleton_or_list uri) []
  and* cc             = field_or_default "cc" (singleton_or_list uri) []
  and* obj            = field "object" obj
  (* and* raw = value *) in

  succeed ({
      id; actor; published;
      to_; cc;
      direct_message;
      obj;
      (*raw;*)
    }: _ Types.update)

let core_obj () =
  let open D in
  let* ty = field_opt "type" string in
  match ty with
  | Some "Person" -> person >|= fun v -> `Person v
  | Some "Follow" -> follow >|= fun v -> `Follow v
  | Some "Note"   -> note   >|= fun v -> `Note v
  | Some "Block"  -> block  >|= fun v -> `Block v
  | Some "Like"   -> like   >|= fun v -> `Like v
  | None          -> string >|= fun v -> `Link v
  | Some ev       -> fail ("unsupported event" ^ ev)

let core_obj = core_obj ()

let event (enc: Types.core_obj D.decoder) : Types.obj D.decoder =
  let open D in
  let* ty = field "type" string in
  match ty with
  | "Accept"   -> accept   enc >|= fun v -> `Accept v
  | "Announce" -> announce enc >|= fun v -> `Announce v
  | "Create"   -> create   enc >|= fun v -> `Create v
  | "Update"   -> update   enc >|= fun v -> `Update v
  | "Delete"   -> delete   enc >|= fun v -> `Delete v
  | "Undo"     -> undo     enc >|= fun v -> `Undo v
  | _          -> fail "unsupported event"

let obj : Types.obj D.decoder =
  D.one_of [
    "core_obj", core_obj;
    "core_obj event", (event core_obj)
  ]

module Webfinger = struct

  let ty =
    let open D in
    string >>= function
    | str when string_prefix ~pre:Constants.ContentType.text_html     str -> succeed `Html
    | str when string_prefix ~pre:Constants.ContentType.app_json      str -> succeed `Json
    | str when string_prefix ~pre:Constants.ContentType._app_act_json str -> succeed `ActivityJson_
    | str when string_prefix ~pre:Constants.ContentType.app_jlda      str -> succeed `ActivityJsonLd
    | _ -> fail "unsupported self link type"

  let self =
    let open D in
    let* ty   = field "type" ty
    and* href = field "href" uri in
    succeed @@ Types.Webfinger.Self (ty, href)

  let profile_page =
    let open D in
    let* ty   = field "type" ty
    and* href = field "href" uri in
    succeed @@ Types.Webfinger.ProfilePage (ty, href)

  let ostatus_subscribe =
    let open D in
    let* template = field "template" string in
    succeed @@ Types.Webfinger.OStatusSubscribe template

  let link =
    let open D in
    let* rel = field "rel" string in
    match rel with
    | "self" -> self
    | str when String.equal str Constants.Webfinger.ostatus_rel ->
      ostatus_subscribe
    | str when String.equal str Constants.Webfinger.profile_page ->
      profile_page
    | _ -> fail "unsupported link relation"

  let query_result =
    let open D in
    let* subject = field "subject" string
    and* aliases = field_or_default "aliases" (list string) []
    and* links   = field "links" (list_ignoring_unknown link) in

    succeed Types.Webfinger.{subject;aliases;links}
end