seppo/as2_vocab/types.ml

(* inspired by https://github.com/Gopiandcode/ocamlot/src/master/lib/activitypub/decode.ml *)

(* keep this module agnostic of the json library.
 * So we discard the 'raw' json for now and keep only the data
 * we expect.
 *
 * Jsonm.lexeme has no equal, so raw could not be equaled.
*)
type jsonm = Jsonm.lexeme
let pp_jsonm = Jsonm.pp_lexeme
(* let equal_jsonm l r = Jsonm.equal l r *)

type uri = Uri.t
let pp_uri = Uri.pp
let equal_uri = Uri.equal

(** https://www.w3.org/TR/activitystreams-core/#collections *)
type 'a collection_page = {
  id         : uri;
  current    : uri option;
  first      : uri option;
  is_ordered : bool;
  items      : 'a list;
  last       : uri option;
  next       : uri option;
  part_of    : uri option;
  prev       : uri option;
  total_items: int option;
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-core/#collections *)
type 'a collection = {
  id         : uri;
  current    : uri option;
  first      : uri option;
  is_ordered : bool;
  items      : 'a list option;
  last       : uri option;
  total_items: int option;
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-vocabulary/#activity-types *)
(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-create *)
type 'a create = {
  id            : uri;
  actor         : uri;
  cc            : uri list;
  direct_message: bool;
  obj           : 'a;
  published     : Ptime.t option;
  to_           : uri list;
  (* raw: jsonm; *)
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-vocabulary/#activity-types *)
(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-update *)
type 'a update = {
  id            : uri;
  actor         : uri;
  cc            : uri list;
  direct_message: bool;
  obj           : 'a;
  published     : Ptime.t option;
  to_           : uri list;
  (* raw: jsonm; *)
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-announce *)
type 'a announce = {
  id       : uri;
  actor    : uri;
  cc       : uri list;
  obj      : 'a;
  published: Ptime.t option;
  to_      : uri list;
  (*  raw: jsonm; *)
} [@@deriving show, eq]


(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-accept *)
type 'a accept = {
  id       : uri;
  actor    : uri;
  obj      : 'a;
  published: Ptime.t option;
  (*  raw: jsonm; *)
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-reject *)
type 'a reject = {
  id       : uri;
  actor    : uri;
  obj      : 'a;
  published: Ptime.t option;
  (*  raw: jsonm; *)
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-undo *)
type 'a undo = {
  id       : uri;
  actor    : uri;
  obj      : 'a;
  published: Ptime.t option;
  (*  raw: jsonm; *)
} [@@deriving show, eq]

(** https://www.w3.org/TR/activitystreams-vocabulary/#dfn-delete *)
type 'a delete = {
  id       : uri;
  actor    : uri;
  obj      : 'a;
  published: Ptime.t option;
  (*  raw: jsonm; *)
}
[@@deriving show, eq]

type 'a event = [
    `Create of 'a create
  | `Update of 'a update
  | `Announce of 'a announce
  | `Accept of 'a accept
  | `Reject of 'a reject
  | `Undo of 'a undo
  | `Delete of 'a delete
] [@@deriving show, eq]


type public_key = {
  id   : uri;
  owner: uri option; (* deprecated however mastodon insists https://digitalcourage.social/@sl007/111838268844684366 *)
  pem  : string;
  signatureAlgorithm: string option;
} [@@deriving show, eq]

(* Attachment as seen on typical actor/person profiles, e.g.
 * $ curl -L -H 'Accept: application/activity+json' 'https://digitalcourage.social/users/mro'
 *
 * https://www.w3.org/TR/activitystreams-vocabulary/#dfn-attachment
 * https://docs.joinmastodon.org/spec/activitypub/#schema
 *
    {
      "name": "Support",
      "value": "<a href=\"https://seppo.social/support\">Seppo.Social/support</a>",
      "type": "PropertyValue"
    },
*)
type property_value = {
  name      : string;
  name_map  : (string * string) list;
  value     : string;
  value_map : (string * string) list;
} [@@deriving show, eq]

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-link *)
type link = {
  href      : uri;
  name      : string option;
  name_map  : (string * string) list;
  rel       : string option;
} [@@deriving show, eq]

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-person
 * https://www.w3.org/TR/activitystreams-core/#actors
*)
type person = {
  id                         : uri;
  inbox                      : uri;
  outbox                     : uri;
  followers                  : uri option;
  following                  : uri option;

  attachment                 : property_value list;
  discoverable               : bool;
  (* generator https://www.w3.org/TR/activitystreams-vocabulary/#dfn-generator *)
  generator                  : link option;
  icon                       : uri option;
  image                      : uri option;
  manually_approves_followers: bool;
  name                       : string option;
  name_map                   : (string * string) list;
  preferred_username         : string option;
  preferred_username_map     : (string * string) list;
  public_key                 : public_key;
  published                  : Ptime.t option;
  summary                    : string option;
  summary_map                : (string * string) list;
  url                        : uri list;
  (*  raw: jsonm; *)
}  [@@deriving show, eq]

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-follow *)
type follow = {
  id     : uri;
  actor  : uri;
  cc     : uri list;
  object_: uri;
  state  : [`Pending | `Cancelled ] option;
  to_    : uri list;
  (*  raw: jsonm; *)
} [@@deriving show, eq]

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-tag *)
type tag = {
  ty  : [`Mention | `Hashtag ];
  href: uri;
  name: string;
} [@@deriving show, eq]

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-attachment *)
type attachment = {
  type_     : string option;
  (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
  media_type: string option;
  name      : string option;
  url       : uri;
} [@@deriving show, eq]

(* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-note*)
type note = {
  id         : uri;
  actor      : uri;
  attachment : attachment list;
  cc         : uri list;
  in_reply_to: uri list;
  media_type : string option; (* https://www.w3.org/TR/activitystreams-vocabulary/#dfn-mediatype *)
  content    : string;
  content_map: (string * string) list;
  published  : Ptime.t option;
  sensitive  : bool;
  source     : uri option;
  summary    : string option;
  summary_map: (string * string) list;
  tags       : tag list;
  to_        : uri list;
  url        : uri list;
  (*raw: jsonm;*)
} [@@deriving show, eq]

(*  https://www.w3.org/TR/activitystreams-vocabulary/#dfn-follow  *)
type block = {
  id       : uri;
  actor    : uri;
  obj      : uri;
  published: Ptime.t option;
  (*raw: jsonm;*)
} [@@deriving show, eq]

(*  https://www.w3.org/TR/activitystreams-vocabulary/#dfn-like *)
type like = {
  id       : uri;
  actor    : uri;
  obj      : uri;
  published: Ptime.t option;
  (*raw: jsonm;*)
}
[@@deriving show, eq]


type core_obj = [
  | `Block  of block
  | `Follow of follow
  | `Like   of like
  | `Link   of string
  | `Note   of note
  | `Person of person
] [@@deriving show, eq]

type core_event = core_obj event
[@@deriving show, eq]

type obj = [ core_obj | core_event ]
[@@deriving show, eq]

module Webfinger = struct

  type ty = [
    | `ActivityJson_ (* we may phase this out completely as Mike pointed out https://www.w3.org/TR/activitypub/#retrieving-objects *)
    | `ActivityJsonLd
    | `Atom (* RFC4287 *)
    | `Html
    | `Json
  ]
  [@@deriving show, eq]

  type link =
    | Self             of ty * uri
    | ProfilePage      of ty * uri
    | Alternate        of ty * uri
    | OStatusSubscribe of string (* https://www.rfc-editor.org/rfc/rfc6415#section-3.1.1.1 should contain unescaped {} *)
  [@@deriving show, eq]

  type query_result = {
    subject: string;
    aliases: string list;
    links  : link list;
  }
  [@@deriving show, eq]

  let self_link =
    List.find_map (function
        | Self ((`ActivityJsonLd
                | `ActivityJson_
                | `Json), url) -> Some url
        | _ -> None)

  let profile_page =
    List.find_map (function
        | ProfilePage ((`Html
                       | `Atom), url) -> Some url
        | _ -> None)

  let ostatus_subscribe =
    List.find_map (function
        | OStatusSubscribe tpl -> Some tpl
        | _ -> None)
end