seppo/as2_vocab/decode.ml

(* has an alloc, use Astring.String or ocaml >= 4.13 *)
let is_prefix ~affix s =
  let lp = affix |> String.length in
  lp <= (s |> String.length)
  && (affix |> String.equal (String.sub s 0 lp))

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* obj       = field "object" uri
  (* and* raw = value *) in
  succeed ({id; actor; 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* end_time  = field_opt "endTime" rfc3339
  and* obj       = field "object" obj
  (*and* raw = value *) in
  succeed ({id;published;actor;end_time;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 actor =
  let open D in
  (* how would we get the default @language from the @context? *)
  let* typ                         = field            "type" string
  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_or_default "inbox" uri Uri.empty
  and* outbox                      = field_or_default "outbox" uri Uri.empty
  and* summary                     = field_or_default "summary" (nullable string) None
  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                        = field_or_default "icon" (singleton_or_list (at ["url"] uri)) []
  and* image                       = maybe            (at ["image";"url"] uri)
  (* and* raw = value *) in
  succeed ({
      typ;
      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.actor)

let note ?(lang = "und") =
  let open D in
  let* ()          = field "type" @@ constant ~msg:"expected Note (received %s)" "Note"
  and* id          = field "id" uri
  and* agent       = field_opt "_agent" string
  and* attachment  = field_or_default "attachment" (singleton_or_list attachment) []
  and* attributed_to  = one_of ["actor", field "actor" uri; "attributed_to", field "attributedTo" uri]
  and* to_         = field "to" (singleton_or_list uri)
  and* in_reply_to = field_or_default "inReplyTo" (singleton_or_list uri) []
  and* reaction_inbox = field_opt "_reaction_inbox" uri
  and* cc          = field_or_default "cc" (singleton_or_list uri) []
  and* content     = field_or_default "content" (nullable string) None
  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" bool false
  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_or_default "url" (singleton_or_list uri) []
  (* and* raw = value *) in
  let lang,content_map = match content,content_map with
    | None,[] -> lang,[]
    | None,((la,_) :: _ as map) -> la,map
    | Some co,((la,s) :: _ as map) when "" |> String.equal co || s |> String.equal co -> la,map
    | Some co,map -> lang,(lang,co) :: map
  in
  let summary_map = match summary,summary_map with
    | None,map
    | Some "",map   -> map
    | Some co, ((_,s) :: _ as map) when s |> String.equal co -> map
    | Some co,map -> (lang,co) :: map
  in
  succeed ({ id; agent; attachment; in_reply_to; reaction_inbox; attributed_to; to_; cc;
             sensitive;
             media_type; content_map; source; summary_map; tags; published; url(*; raw*) }: Types.note)

let follow =
  let open D in
  let* ()      = field "type" @@ constant ~msg:"expected follow 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* end_time= field_opt "endTime" rfc3339
  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; end_time; to_; id; object_; state(*; raw*)}: Types.follow)

let announce =
  let open D in
  let* ()        = field "type" @@ constant ~msg:"expected announce 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" uri
  (* 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 update 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 reject obj =
  let open D in
  let* ()             = field "type" @@ constant ~msg:"expected reject object (received %s)" "Reject"
  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; actor; published;
      obj;
      (*raw;*)
    }: _ Types.reject)

let core_obj () =
  let open D in
  let* ty = field_opt "type" string in
  match ty with
  | Some "Actor"  -> actor  >|= fun v -> `Actor 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
  | Some "Announce" -> announce >|= fun v -> `Announce 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
  | "Reject"   -> reject   enc >|= fun v -> `Reject 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 str |> is_prefix ~affix:Constants.ContentType.text_html     -> succeed `Html
    | str when str |> is_prefix ~affix:Constants.ContentType.app_json      -> succeed `Json
    | str when str |> is_prefix ~affix:Constants.ContentType._app_act_json -> succeed `ActivityJson_
    | str when str |> is_prefix ~affix:Constants.ContentType.app_jlda      -> 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