Source file object.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Implementation of objects *)

(**/**)

module AP = Activitypub
module O = AP.Object
module Types = AP.Types
module Log = AP.Log
module AS = Rdf.Activitypub

(**/**)

(** {2 Objects} *)

(** Implementation of objects inherits from [Activitypub.Object.object_]
  and here we provide a way to dereference objects. To dereference an
  object, you need an actor and its public/private key to sign http queries.
  An {!Http_t} module is used by {!Make} to create a module of type {!T}
  which can be used to create and dereference objects with the actor
  of the {!Http_t} module in parameter of {!Make}. *)

(** Performing HTTP queries as a given actor. *)
module type Http_t = sig
  val conf : Conf.t
  val actor_conf : Conf.actor
  val actor_iri : Iri.t
  include Ldp.Http.Http
  end

(** A [dereferencer] takes an IRI and returns the result as a RDF graph and an
  optional IRI (for queries creating remote objects, like POST queries). *)
type dereferencer = Iri.t -> (Rdf.Graph.graph * Iri.t option, AP.E.error) result Lwt.t

(** The type of modules to create, dereference and query objects as a given actor. *)
module type T = sig
    val conf : Conf.t
    val actor_conf : Conf.actor
    val actor_iri : Iri.t
    module H : Http_t
    val jsonld_string_to_graph : ?g:Rdf.Graph.graph -> string -> (Rdf.Graph.graph * Iri.t option) Lwt.t
    val graph_to_jsonld_string : Rdf.Graph.graph -> string
    val dereference : dereferencer
    class o : ?g:Rdf.Graph.graph -> ?dereference:dereferencer -> Types.id -> object
        inherit Types.object_
        inherit Types.ordered_collection_page
        inherit Types.activity
        inherit Types.actor
        method as_object : Types.object_
        method as_collection : Types.collection
        method as_ordered_collection : Types.ordered_collection
        method as_collection_page : Types.collection_page
        method as_ordered_collection_page : Types.ordered_collection_page
        method as_activity : Types.activity
        method as_actor : Types.actor
      end
    val get : ?g:Rdf.Graph.graph -> ?dereference:dereferencer -> Types.id -> o
    val of_iri : ?g:Rdf.Graph.graph -> ?dereference:dereferencer -> Iri.t -> o
    val of_object : ?dereference:dereferencer -> Types.object_ -> o
    val post :  Iri.t -> Rdf.Graph.graph ->
      (Iri.t option, AP.E.error) result Lwt.t
    val post_data : ?headers:Cohttp.Header.t -> ct:Ldp.Ct.t -> data:string -> Iri.t ->
      (Iri.t option, AP.E.error) result Lwt.t
    val collection_next_items : ?check_delay:float -> ?after:Iri.t -> AP.Types.collection ->
      ([`L of AP.Types.link | `O of AP.Types.object_] Lwt_stream.t * (unit -> unit))
  end

module Make (H:Http_t) : T =
  struct
    let conf = H.conf
    let actor_conf = H.actor_conf
    let actor_iri = H.actor_iri
    module H = H

    let document_loader ?headers iri =
      match%lwt H.get_non_rdf ?headers iri with
      | Ok (_,str) -> Lwt.return_ok str
      | Error qe ->
          let msg = Ldp.Http.string_of_query_error qe in
          let e = AP.E.Error (AP.Object.Http_error (iri, `GET, msg)) in
          Lwt.return_error e

    let jsonld_document_loader = AP.Utils.jsonld_document_loader document_loader

    let graph_to_jsonld_string g =
      let options = Rdf_json_ld.T.options jsonld_document_loader (* FIXME: pass actor to doc loader *) in
      let ds = Rdf.Ds.mem_dataset g in
      let json = Rdf_json_ld.Json_ld.from_rdf options ds in
      Rdf_json_ld.J.to_string json

    let jsonld_string_to_graph ?g str =
      let options = Rdf_json_ld.T.options jsonld_document_loader in
      O.jsonld_string_to_graph ?g options str

    let parse_graph = O.parse_graph ~jsonld_loader:jsonld_document_loader
      actor_conf.jsonld_cache_dir

    let http_headers ?(headers=Cohttp.Header.init ()) ?token () =
      match token with
      | None -> headers
      | Some str -> Cohttp.Header.add headers "authorization" str

    let token iri =
      match actor_conf.token with
      | None -> None
      | Some token ->
          match Iri.host iri, Iri.host actor_iri with
          | None, _
          | _, None -> None
          | Some h, Some hs ->
              if String.lowercase_ascii hs = String.lowercase_ascii h &&
                match Iri.port iri, Iri.port actor_iri with
                | None, None -> true
                | Some sp, Some p -> sp = p
                | None, Some 80
                | Some 80, None -> true
                | _ -> false
                  then
                Some token
              else
                None

    let dereference iri =
      Log.debug (fun m -> m "dereferencing %a" Iri.pp iri);
      (* send token only to server in conf, not other server *)
      let token = token iri in
      (* some servers require http signing queries when accepting jsonld
         (but don't require signing when accepting html...), but let's
         not sign our requests by now. *)
      let headers = http_headers ?token () in
      match%lwt H.get_non_rdf ~headers ~accept:O.accept_rdf_cts iri with
      | exception e ->
          let msg = Printexc.to_string e in
          Lwt.return_error (O.Http_error (iri, `GET, msg))
      | Error qe ->
          let msg = Ldp.Http.string_of_query_error qe in
          Lwt.return_error (O.Http_error (iri, `GET, msg))
      | Ok (ct, body) -> parse_graph iri ct body

    class o ?g ?(dereference=dereference) id =
      object(self)
        inherit Activitypub.Actor.actor ?g id
        inherit O.object_ ?g id
        method private new_object ?g id = (new o ?g id :> Types.object_)
        method private new_activity ?g id = (new o ?g id :> Types.activity)
        method private new_collection ?g id = (new o ?g id :> Types.collection)
        method private new_ordered_collection ?g id = (new o ?g id :> Types.ordered_collection)
        method private new_collection_page ?g id = (new o ?g id :> Types.collection_page)
        method private new_ordered_collection_page ?g id = (new o ?g id :> Types.ordered_collection_page)
        method private new_image ?g id = (new o ?g id :> Types.image)
        method as_actor = (self :> Types.actor)
        method dereference =
          match g with
          | Some g -> Lwt.return_unit
          | None ->
              match id with
              | Rdf.Term.Iri iri ->
                  (match%lwt dereference iri with
                   | Error e ->
                       Log.err (fun m -> m "%s" (Activitypub.E.string_of_error e));
                       Lwt.return_unit
                   | Ok (graph, root) ->
                       g <- Some graph;
                       Log.debug (fun m -> m "graph at %s: root = %s"
                          (Iri.to_string iri)
                            (match root with None -> "NONE" | Some i -> Iri.to_string i));
                       Option.iter (fun root -> id <- Rdf.Term.Iri root) root ;
                       Lwt.return_unit
                  )
              | _ -> g <- Some self#g_ ; Lwt.return_unit
      end

    let get ?g ?dereference id = new o ?g ?dereference id
    let of_iri ?g ?dereference iri = get ?g ?dereference (Rdf.Term.Iri iri)
    let of_object ?dereference o = get ?g:o#g ?dereference o#id

    let post_data ?headers ~ct ~data iri =
      Log.debug (fun m -> m "posting to %a" Iri.pp iri);
      (* send token only to server in conf, not other server *)
      match token iri with
      | None ->
          let msg = Printf.sprintf "no token for posting to %s" (Iri.to_string iri) in
          Lwt.return_error  (O.Http_error (iri, `POST, msg))
      | Some token ->
          let headers = http_headers ?headers ~token () in
          match%lwt H.post ~headers ~data ~ct iri with
          | exception e ->
              let msg = Printexc.to_string e in
              Lwt.return_error (O.Http_error (iri, `POST, msg))
          | Error qe ->
              let msg = Ldp.Http.string_of_query_error qe in
              Lwt.return_error (O.Http_error (iri, `POST, msg))
          | Ok meta ->
              match AP.Utils.location_header meta with
              | None -> Lwt.return_ok None
              | Some str ->
                  match Iri.of_string str with
                  | iri -> Lwt.return_ok (Some iri)
                  | exception (Iri.Error e) ->
                     let msg = Printf.sprintf "Invalid location %s: %s"
                       str (Iri.string_of_error e)
                     in
                     Lwt.return_error (O.Http_error (iri, `POST, msg))

    let post iri g =
      let data = graph_to_jsonld_string g in
      let ct = Ldp.Ct.of_mime AP.Utils.mime_jsonld in
      post_data ~ct ~data iri

    let collection_next_items =
      let get_head col_id =
        let col = get col_id in
        let%lwt () = col#dereference in
        let%lwt st = col#items in
        Lwt_stream.get st
      in
      let pred iri lo =
        let iri2 = AP.Types.iri_of_lo lo in
        Lwt.return (not (Iri.equal iri iri2))
      in
      let rec check waiter delay push col_id last =
        let col = get col_id in
        let%lwt () = col#dereference in
        match Lwt.state waiter with
        | Lwt.Return _ | Lwt.Fail _ ->
            push None;
            Lwt.return_unit
        | Lwt.Sleep ->
            let%lwt items = col#items in
            let%lwt new_items = Lwt_stream.get_while_s (pred last) items in
            let last =
              match new_items with
              | [] -> last
              | h :: _ ->
                  List.iter (fun x -> push (Some x)) (List.rev new_items);
                  AP.Types.iri_of_lo h
            in
            let%lwt () = Lwt_unix.sleep delay in
            check waiter delay push col_id last
      in
      fun ?(check_delay=30.) ?after (col:AP.Types.collection) ->
        let (stream, push) = Lwt_stream.create () in
        let (waiter, waker) = Lwt.wait () in
        Lwt.async (fun () ->
           let%lwt last = match after with
             | Some iri -> Lwt.return iri
             | None ->
                 match%lwt get_head col#id with
                 | None -> Lwt.return (Iri.of_string "")
                 | Some lo -> Lwt.return (AP.Types.iri_of_lo lo)
           in
           check waiter check_delay push col#id last);
        let stop () = Lwt.wakeup_later waker () in
        stream, stop
  end

(** {2 Convenient functions to create some specific objects and graphs.} *)

(** [note content] creates a new graph, with empty name, of type
  {{:https://www.w3.org/ns/activitystreams#Note}Note},
  with the given {{:https://www.w3.org/ns/activitystreams#content}content}.
  An optional [content_map] can be passed to specify language-specific contents.
  The function returns the graph and the subject [sub] (a blank node)
  corresponding to the note id.
  The [add] optional argument is called on [g] and [sub] before returning.
*)
let note ?add ?(content_map=AP.Smap.empty) content =
  let g = Rdf.Graph.open_graph (Iri.of_string "") in
  let sub = Rdf.Term.blank_ (g.Rdf.Graph.new_blank_id ()) in
  g.add_triple ~sub ~pred:Rdf.Rdf_.type_ ~obj:(Rdf.Term.Iri AS.c_Note) ;
  AP.Smap.iter (fun lang str ->
     let obj = Rdf.Term.term_of_literal_string ~lang str in
     g.Rdf.Graph.add_triple ~sub ~pred:AS.content ~obj)
    content_map;
  g.add_triple ~sub ~pred:AS.content ~obj:(Rdf.Term.term_of_literal_string content);
  Option.iter (fun f -> f g sub) add ;
  (g, sub)

(** [link iri] creates a new {!Activitypub.Object.link} from the given parameters.*)
let link ?(g=Rdf.Graph.open_graph (Iri.of_string "")) ?root
  ?height ?hreflang ?media_type ?name ?(rel=[]) ?(type_=AS.c_Link) ?width iri =
  let sub = match root with Some t -> t | None -> Rdf.Term.blank_ (g.Rdf.Graph.new_blank_id()) in
  g.add_triple ~sub ~pred:AS.href ~obj:(Rdf.Term.Iri iri) ;
  Option.iter
    (fun h -> g.add_triple ~sub ~pred:AS.height ~obj:(Rdf.Term.term_of_int h))
    height;
  Option.iter
    (fun s -> g.add_triple ~sub ~pred:AS.hreflang ~obj:(Rdf.Term.term_of_literal_string s))
    hreflang;
  Option.iter
    (fun ct -> g.add_triple ~sub ~pred:AS.mediaType
       ~obj:(Rdf.Term.term_of_literal_string (Ldp.Ct.mime_to_string ct)))
    media_type;
  Option.iter
    (fun s -> g.add_triple ~sub ~pred:AS.name ~obj:(Rdf.Term.term_of_literal_string s))
    name;
  List.iter
    (fun s -> g.add_triple ~sub ~pred:AS.rel ~obj:(Rdf.Term.term_of_literal_string s))
    rel;
  g.add_triple ~sub ~pred:Rdf.Rdf_.type_ ~obj:(Rdf.Term.Iri type_);
  Option.iter
    (fun w -> g.add_triple ~sub ~pred:AS.width ~obj:(Rdf.Term.term_of_int w))
    width;
  new AP.Object.link g sub

type attachment =
[ `Iri of Iri.t
| `Link of AP.Types.link
| `Obj of AP.Types.object_
]

(** [add_attachment g sub a] adds [a] as an attachment to [sub] in graph [g],
  eventually merging parts of [a]'s triples into [g]. *)
let add_attachment g sub (a:attachment) =
  let obj = match a with
    | `Iri iri -> Rdf.Term.Iri iri
    | `Link l ->
        let g2 = AP.Utils.graph_keep_only_from l#g l#id in
        Rdf.Graph.merge ~map:(fun t -> Some t) g g2;
        l#id
    | `Obj o ->
        match o#g with
        | None -> Rdf.Term.Iri o#iri
        | Some g2 ->
            let g2 = AP.Utils.graph_keep_only_from g2 o#id in
            Rdf.Graph.merge ~map:(fun t -> Some t) g g2;
            o#id
  in
  g.Rdf.Graph.add_triple ~sub ~pred:AS.attachment ~obj

(** [document (module O) url] creates a new object [O.o] from the given parameters.
   If no graph [g] is provided, a new one with an empty named is used.
   If no [root] node is provided, a blank node is used as id for the object.
  Default type of the object is {{:https://www.w3.org/ns/activitystreams#Document}Document} but
  another one can be specified with [typ] argument.
*)
let document (module O:T) ?(g=Rdf.Graph.open_graph (Iri.of_string "")) ?root
  ?height ?media_type ?name ?(type_=AS.c_Document) ?width url : AP.Types.document =
  let sub = match root with Some t -> t | None -> Rdf.Term.blank_ (g.Rdf.Graph.new_blank_id()) in
  g.add_triple ~sub ~pred:AS.url ~obj:(Rdf.Term.Iri url) ;
  Option.iter
    (fun h -> g.add_triple ~sub ~pred:AS.height ~obj:(Rdf.Term.term_of_int h))
    height;
  Option.iter
    (fun ct -> g.add_triple ~sub ~pred:AS.mediaType
       ~obj:(Rdf.Term.term_of_literal_string (Ldp.Ct.to_string ct)))
    media_type;
  Option.iter
    (fun s -> g.add_triple ~sub ~pred:AS.name ~obj:(Rdf.Term.term_of_literal_string s))
    name;
  g.add_triple ~sub ~pred:Rdf.Rdf_.type_ ~obj:(Rdf.Term.Iri type_);
  Option.iter
    (fun w -> g.add_triple ~sub ~pred:AS.width ~obj:(Rdf.Term.term_of_int w))
    width;
  (new O.o ~g sub :> AP.Types.document)