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

(** Acting as an actor *)

module AP = Activitypub

type AP.E.error +=
| Post_no_iri of Iri.t (** When the server did not return an IRI after a POST. *)

let () = AP.E.register_string_of_error
  (function Post_no_iri iri ->
       let msg = Printf.sprintf "Posting to %s: server did not send an Iri in location header"
         (Iri.to_string iri)
       in
       Some msg
   | _ -> None
  )

(** An actor implements {!AP.Types.actor} with additional methods to
  post activities, create objects or retrieve information. *)
class type o = object
    inherit AP.Types.actor
    method as_actor : AP.Types.actor
    method accept : Acti.accept_fun
    method announce : Acti.announce_fun
    method create : Acti.create_fun
    method delete : Acti.delete_fun
    method dislike : Acti.dislike_fun
    method follow : Acti.follow_fun
    method like : Acti.like_fun
    method undo : Acti.undo_fun
    method update : Acti.update_fun

    (** Create a {{:https://www.w3.org/ns/activitystreams#Note}Note}. The [add]
      optional argument can be used to insert addition triples in the note object
      before sending the activity. The term parameter of the [add] function is the
      note's node in the graph. *)
    method create_note : ?add:(Rdf.Graph.graph -> Rdf.Term.term -> unit) ->
      ?content_map:string AP.Smap.t -> string -> ?in_reply_to:Iri.t list -> Acti.audience_post_fun
    method create_object : AP.Types.object_ -> ?in_reply_to:Iri.t list -> Acti.audience_post_fun
    method create_link :
        ?height:int -> ?hreflang:string -> ?media_type:Ldp.Ct.mime ->
        ?name:string -> ?rel:string list -> ?type_:Iri.t -> ?width:int ->
        Iri.t -> ?in_reply_to:Iri.t list -> Acti.audience_post_fun
    method upload_file : (?ct:Ldp.Ct.t -> string -> (Iri.t, AP.E.error) Result.t Lwt.t) option
    method followers_list : Iri.t list Lwt.t
    method following_list : Iri.t list Lwt.t
  end

(** The signature of the module we get when applying the {!Make} functor to
  and {!Acti.T} module.*)
module type T = sig
    module O : Object.T
    module Acti : Acti.T

    (** Get an object, being authenticated as the [!O.actor]. *)
    val get : ?g:Rdf.Graph.graph -> Iri.t -> o

    (** Return the authenticated actor, already dereferenced. *)
    val actor : unit -> o Lwt.t
  end

module Make (A:Acti.T) : T = struct
    module O = A.O
    module Acti = A
    let upload_file =
      match O.actor_conf.media_post_iri with
      | None -> None
      | Some iri ->
          let f ?ct file =
            let ct = match ct with
              | Some x -> x
              | None ->
                  let mime = Magic_mime.lookup file in
                  match Ldp.Ct.of_string mime with
                  | Ok ct -> ct
                  | _ -> Ldp.Ct.of_mime (AP.Utils.static_mime "application/octet-stream")
            in
            let%lwt data = Lwt_io.(with_file ~mode:Input file read) in
            match%lwt O.post_data ~data ~ct iri with
            | Ok None -> Lwt.return_error (Post_no_iri iri)
            | Ok (Some iri) -> Lwt.return_ok iri
            | Error e -> Lwt.return_error e
          in
          Some f

    module Cache =
      struct
        let validity_delay = 5 * 60
        let cache_size = 200
        module Key = struct
            type t = Iri.t
            let compare i1 i2 = Iri.compare i1 i2
            let witness = Iri.of_string ""
          end

        module Cache = Lru_cache.Make_with_monad(Lwt)(Key)
        let validate x =
          match%lwt x with
        | Error _ -> Lwt.return_false
        | Ok (_g,_root,date) ->
              let now = AP.Utils.ptime_now () in
              let span = Ptime.diff now date in
              match Ptime.Span.to_int_s span with
              | Some nsecs when nsecs <= validity_delay -> Lwt.return_true
              | _ -> Lwt.return_false

        let cache = Cache.init ~validate cache_size
        let get dereference =
          let compute iri =
            match%lwt dereference iri with
            | Error e -> Lwt.return_error e
            | Ok (g,root) -> Lwt.return_ok (g,root,AP.Utils.ptime_now())
          in
          fun iri -> Cache.get cache iri compute
      end
    let dereference iri =
      match%lwt Cache.get O.dereference iri with
      | Error e -> Lwt.return_error e
      | Ok (g,root,_) -> Lwt.return_ok (g,root)

    class o_ ?g id =
      object(self)
        inherit A.O.o ?g ~dereference id
        method accept = Acti.accept
        method announce = Acti.announce
        method create = Acti.create
        method delete = Acti.delete
        method dislike = Acti.dislike
        method follow = Acti.follow
        method like = Acti.like
        method undo = Acti.undo
        method update = Acti.update
        method create_note ?add ?content_map content =
          let (g, root) = Object.note ?add ?content_map content in
          self#create g root

        method create_object (obj:AP.Types.object_) =
          let g = match obj#g with
            | None -> Rdf.Graph.open_graph obj#iri
            | Some g -> g
          in
          self#create g obj#id

        method create_link ?height ?hreflang ?media_type ?name
          ?rel ?type_ ?width iri =
          let obj = Object.link ?height ?hreflang ?media_type ?name ?rel ?type_ ?width iri in
          self#create obj#g obj#id

        method upload_file : (?ct:Ldp.Ct.t -> string -> (Iri.t, AP.E.error) Result.t Lwt.t) option = upload_file

        method followers_list : Iri.t list Lwt.t =
          match self#followers with
          | None -> Lwt.return []
          | Some col ->
              let%lwt () = col#dereference in
              let%lwt stream = col#items in
              let stream = Lwt_stream.map AP.Types.iri_of_lo stream in
              let%lwt l = Lwt_stream.to_list stream in
              Lwt.return l

        method following_list : Iri.t list Lwt.t =
          match self#following with
          | None -> Lwt.return []
          | Some col ->
              let%lwt () = col#dereference in
              let%lwt stream = col#items in
              let stream = Lwt_stream.map AP.Types.iri_of_lo stream in
              let%lwt l = Lwt_stream.to_list stream in
              Lwt.return l
      end

    let get ?g iri = (new o_ ?g (Rdf.Term.Iri iri) :> o)
    let actor () =
      let a = get O.actor_iri in
      let%lwt () = a#dereference in
      Lwt.return a

  end