Source file types.ml

(*********************************************************************************)
(*                OCaml-ActivityPub                                              *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: maxence.guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Interface of activitypub objects + convenient functions. *)

(* This module defines class interfaces of various activitypub
  objects. They are implemented in server and client side. *)

(** {2 Object types} *)

(** An id is an RDF term. *)
type id = Rdf.Term.term

(** Generate a new id, by appending to a given base IRI. For a same base IRI,
  Ids are guaranteed to be generated in increasing order when compared
  alphanumerically. The function returns both the id and the corresponding IRI, for conveniency. *)
let gen_id base_iri =
  let t = Printf.sprintf "%0.12f" (Ptime.to_float_s (Ptime_clock.now())) in
  let l = String.split_on_char '.' t in
  let s = String.concat "" l in
  let iri = Iri.append_path base_iri [s] in
  (Rdf.Term.Iri iri, iri)

(** A {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-link}Link}'s interface. *)
class type link =
  object
    method id : Rdf.Term.term
    method height : int option
    method href : Iri.t
    method hreflang : string option
    method media_type : Ldp.Ct.mime option
    method name : string option
    method rel : string list
    method width : int option
    method g : Rdf.Graph.graph
  end

(** An {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-object}Object}'s interface.

Most of the methods are accessors, querying the internal [#g] graph. Before
querying any information, it is important that the object have been
dererefenced using the [#dereference] method. Calling [#dereference] on an
already dereferenced object has no effect, i.e. the internal graph is not updated.
*)
and object_ =
  object
    method id : id
    method as_id : Iri.t option
    method iri : Iri.t
    method type_ : Iri.t
    method attachment : [`L of link | `O of object_ ] list
    method attributed_to : [`L of link | `O of object_ ] option
    method audience : [`L of link | `O of object_ ] option
    method likes : collection option
    method shares : collection option
    method content : string option
    method content_map : string Smap.t
    method name : string option
    method name_map : string Smap.t
    method end_time : Rdf.Term.datetime option
    method generator : [`L of link | `O of object_] option
    method icon : [`L of link | `I of image] list
    method image : [`L of link | `I of image] list
    method in_reply_to : [`L of link | `O of object_] list
    method preview : [`L of link | `O of object_] option
    method published : Rdf.Term.datetime option
    method replies : collection option
    method start_time : Rdf.Term.datetime option
    method summary : string option
    method summary_map : string Smap.t
    method tag : [`L of link | `O of object_] list
    method updated : Rdf.Term.datetime option
    method url : [`L of link | `I of Iri.t] list
    method to_ : [`L of link | `O of object_] list
    method bto : [`L of link | `O of object_] list
    method cc : [`L of link | `O of object_] list
    method bcc : [`L of link | `O of object_] list
    method media_type : Ldp.Ct.mime option
    method g : Rdf.Graph.graph option
    method is_empty : bool
    method pp : Format.formatter -> unit -> unit
    method dereference : unit Lwt.t
    method as_link : link
    method as_activity : activity
  end

(** A {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-document}Document}'s interface.*)
and document =
  object
    inherit object_
  end

(** An {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-image}Image}'s interface. *)
and image =
  object
    inherit document
  end

(** A {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-collection}Collection}'s interface. *)
and collection =
  object
    inherit object_
    method total_items : int
    method current : [`L of link | `I of Iri.t] option
    method first : [`L of link | `I of Iri.t] option
    method last : [`L of link | `I of Iri.t] option
    method items : [`L of link | `O of object_] Lwt_stream.t Lwt.t
  end

(** A {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-collectionpage}CollectionPage}'s interface. *)
and collection_page =
  object
    inherit collection
    method part_of : [`L of link | `I of Iri.t] option
    method next : [`L of link | `I of Iri.t] option
    method prev : [`L of link | `I of Iri.t] option
  end

(** An {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollection}OrderedCollection}'s interface. *)
and ordered_collection =
  object
    inherit collection
  end

(** An {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-orderedcollectionpage}OrderedCollectionPage}'s interface. *)
and ordered_collection_page =
  object
    inherit ordered_collection
    inherit collection_page
    method start_index : int option
  end

(** An {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-actor}Actor}'s interface. *)
and actor =
  object
    inherit object_
    method inbox : ordered_collection
    method outbox : ordered_collection
    method following : collection option
    method followers : collection option
    method liked : collection option
    method manually_approves_followers : bool (** default should be [false] *)
    method streams : collection list
    method preferred_username : string option
    method public_keypem : X509.Public_key.t option
    method public_key_iri : Iri.t option
    method private_keypem : X509.Private_key.t option Lwt.t
  end

(** An {{:https://www.w3.org/TR/activitystreams-vocabulary/#dfn-activity}Activity}'s interface. *)
and activity =
  object
    inherit object_
    method actor : [`L of link | `O of object_] option
    method as_object : object_
    method object_ : object_ option
    method target : [`L of link | `O of object_] option
    method origin : [`L of link | `O of object_] option
    method result : [`L of link | `O of object_] option
    method instrument : [`L of link | `O of object_] list
  end

module AS = Rdf.Activitypub

(** {2 Activity types} *)

type activity_type = [
  | `Accept
  | `Add
  | `Announce
  | `Arrive
  | `Block
  | `Create
  | `Delete
  | `Dislike
  | `Flag
  | `Follow
  | `Ignore
  | `Invite
  | `Join
  | `Leave
  | `Like
  | `Listen
  | `Move
  | `Offer
  | `Question
  | `Read
  | `Reject
  | `Remove
  | `TentativeAccept
  | `TentativeReject
  | `Travel
  | `Undo
  | `Update
  | `View
  ]

let activity_types : (activity_type * Iri.t) list =
  [
   `Accept, AS.c_Accept ;
   `Add, AS.c_Add ;
   `Announce, AS.c_Announce ;
   `Arrive, AS.c_Arrive ;
   `Block, AS.c_Block ;
   `Create, AS.c_Create ;
   `Delete, AS.c_Delete ;
   `Dislike, AS.c_Dislike ;
   `Flag, AS.c_Flag ;
   `Follow, AS.c_Follow ;
   `Ignore, AS.c_Ignore ;
   `Invite, AS.c_Invite ;
   `Join, AS.c_Join ;
   `Leave, AS.c_Leave ;
   `Like, AS.c_Like ;
   `Listen, AS.c_Listen ;
   `Move, AS.c_Move ;
   `Offer, AS.c_Offer ;
   `Question, AS.c_Question ;
   `Reject, AS.c_Reject ;
   `Read, AS.c_Read ;
   `Remove, AS.c_Remove ;
   `TentativeReject, AS.c_TentativeReject ;
   `TentativeAccept, AS.c_TentativeAccept ;
   `Travel, AS.c_Travel ;
   `Undo, AS.c_Undo ;
   `Update, AS.c_Update ;
   `View, AS.c_View ;
  ]

let activity_type_of_iri : Iri.t -> activity_type option =
  let map =
    List.fold_left (fun acc (t, iri) -> Iri.Map.add iri t acc)
      Iri.Map.empty activity_types
  in
  fun iri -> Iri.Map.find_opt iri map

let iri_of_activity_type : activity_type -> Iri.t =
  let module M = Map.Make(struct type t = activity_type let compare = Stdlib.compare end) in
  let map =
    List.fold_left (fun acc (t, iri) -> M.add t iri acc)
      M.empty activity_types
  in
  fun t -> M.find t map

(** {2 Actor types} *)

type actor_type = [ `Application | `Group | `Organization | `Person | `Service ]
let actor_types : (actor_type * Iri.t) list =
  [
   `Application, AS.c_Application ;
   `Group, AS.c_Group ;
   `Organization, AS.c_Organization ;
   `Person, AS.c_Person ;
   `Service, AS.c_Service ;
  ]

let actor_type_of_iri : Iri.t -> actor_type option =
  let map =
    List.fold_left (fun acc (t, iri) -> Iri.Map.add iri t acc)
      Iri.Map.empty actor_types
  in
  fun iri -> Iri.Map.find_opt iri map

let iri_of_actor_type : actor_type -> Iri.t =
  let module M = Map.Make(struct type t = actor_type let compare = Stdlib.compare end) in
  let map =
    List.fold_left (fun acc (t, iri) -> M.add t iri acc)
      M.empty actor_types
  in
  fun t -> M.find t map

(** {2 Convenient functions} *)

(** [iri_of_lo (`L link)] returns [link#href].
  [iri_of_lo (`O obj)] returns [obj#iri]. *)
let iri_of_lo : [`L of link | `O of object_] -> Iri.t =
  function  `L l -> l#href | `O o -> o#iri

(** [iri_of_liri (`L link)] returns [link#href].
  [iri_of_liri (`I iri)] returns [iri]. *)
let iri_of_liri : [`L of link | `I of Iri.t] -> Iri.t =
  function  `L l -> l#href | `I i -> i

(** [iri_of_li (`L link)] returns [link#href].
  [iri_of_li (`I image)] returns the iri associated to [image#id],
  or else the first iri of [image#url]. *)
let iri_of_li : [`L of link | `I of image] -> Iri.t =
  function
  | `L l -> l#href
  | `I i ->
      match i#id with
      | Rdf.Term.Iri iri -> iri
      | _ -> match i#url with
          | [] -> i#iri
          | `I iri :: _ -> iri
          | `L l :: _ -> l#href

(** [actor_name a] returns name of actor is present, or preferred_username
  if present, or [""]. Whe a [lang] argument is given, lookup for the name
  in then name language map of [a]. *)
let actor_name ?lang a =
  match
    match lang with
    | None -> a#name
    | Some lang ->
        match Smap.find_opt lang a#name_map with
        | None -> a#name
        | x -> x
  with
  | None -> Option.value ~default:"" a#preferred_username
  | Some str -> str

(** [object_content o] returns content string of [o] if
  present, or [""]. If a [lang] argument is given, lookup in
  the content map of [o]. *)
let object_content ?lang (o:object_) =
  Option.value ~default:""
    (match lang with
     | None -> o#content
     | Some lang ->
         match Smap.find_opt lang o#content_map with
         | None -> o#content
         | x -> x
    )

(** {2 Activity trees}

This is a recursive representation of activities, since activities
can refer to activities, themselves referring to other activities and so on.

It is sometimes useful to be able to pattern-match on activities on different
depths. *)

type activity_obj =
  [ `None
  | `Activity of activity_tree
  | `Actor of actor_type * object_
  | `Object of object_
  | `Loop of id
  ]
and activity_tree = activity_type * activity * activity_obj

(** Build an {!type-activity_tree} from the given object and
 its internal graph. No dereferencing is performed
 to build the tree. *)
let activity_tree =
  let rec iter seen : object_ option -> activity_obj = function
  | None -> `None
  | Some o ->
      if Rdf.Term.TSet.mem o#id seen then
        `Loop o#id
      else
          let typ = o#type_ in
          match activity_type_of_iri typ with
          | Some t ->
              let a = o#as_activity in
              `Activity (t, a, iter (Rdf.Term.TSet.add a#id seen) a#object_)
          | None ->
              match actor_type_of_iri typ with
              | Some t -> `Actor(t, o)
              | None -> `Object o
  in
  fun o ->
    match activity_type_of_iri o#type_ with
    | None -> None
    | Some t -> Some (t, o, iter Rdf.Term.TSet.empty o#object_)