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

module AP = Activitypub
module Log = AP.Log
module AS = Rdf.Activitypub

module Make(O:Object.T)(A:Actor.T)(POut:Process.T) : Process.P = struct
    let prefix = "process_in"
    let handle_not_implemented ~actor activity obj graphs =
      Process.lwt_return_internal_error
        "Unhandled activity type %s" (Iri.to_string activity#type_)

    let handle_nothing ~actor activity obj graphs =
      Log.info (fun m -> m "Nothing done for activity type %a" Iri.pp activity#type_);
      Lwt.return_ok ()

    let store_local_graph ?g o graphs =
      let iri = o#iri in
      let g =
        match g with
        | Some g -> g
        | None ->
            match Iri.Map.find_opt iri graphs with
            | None -> failwith
                (Printf.sprintf "Process_in.store_local_graph: no graph for %s"
                 (Iri.to_string iri))
            | Some g -> g
      in
      O.store_local_graph g iri

    let store_if_foreign ~actor iri graphs =
      if O.is_local_iri iri then
        Lwt.return_false
      else
        match Iri.Map.find_opt iri graphs with
        | None ->
            Log.warn (fun m -> m "Process_in.store_if_foreign: no graph for %a"
               Iri.pp iri);
            Lwt.return_true
        | Some g ->
            let%lwt () = O.store_foreign_graph ~actor g iri in
            Lwt.return_true

    let rec store_obj ~actor graphs (tree:AP.Types.activity_obj) =
      match tree with
      | `Activity (typ,activity,obj) ->
          if%lwt store_if_foreign ~actor activity#iri graphs then
            store_obj ~actor graphs obj
          else
            Lwt.return_unit
      | `Actor _ ->
          (* do not store actors *)
          Lwt.return_unit
      | `Object obj ->
          let%lwt _ = store_if_foreign ~actor obj#iri graphs in
          Lwt.return_unit
      | _ -> Lwt.return_unit

    let accept_follow ~actor activity =
      match actor#following with
      | None ->
          Process.lwt_return_internal_error
            "(in)Accept Follow: no following collection for actor %s"
            (Iri.to_string actor#iri)
      | Some following ->
          match%lwt O.local_collection following#iri with
          | Error (`Msg msg) ->
              Process.lwt_return_internal_error "%s" msg
          | Ok following ->
              match activity#actor with
              | None ->
                  Process.lwt_return_internal_error
                         "(in)Accept Follow: no actor from activity %s"
                         (Iri.to_string activity#iri)
              | Some lo ->
                  let followed = Rdf.Term.Iri (AP.Types.iri_of_lo lo) in
                  match%lwt following#add_item ~unique:true followed with
                  | Error (`Msg msg) ->
                      Process.lwt_return_internal_error "(in)Accept Follow: %s" msg
                  | Ok () ->
                      Lwt.return_ok true

    let handle_accept ~actor activity obj graphs =
      Log.debug (fun m -> m "(out)Accept %a" Iri.pp activity#iri);
      let%lwt () = store_local_graph activity graphs in
      match obj with
      | `Loop _ | `None ->
          Process.lwt_return_bad_request
            "(in)Accept %s: no object" (Iri.to_string activity#iri)
      | `Activity (`Follow, _, _) -> accept_follow ~actor activity
      | _ -> handle_not_implemented ~actor activity obj graphs

    let handle_add = handle_not_implemented

    let handle_plus_one ~allow_multiple act_name (col_fun:O.object_collection_fun)
      ~actor activity obj graphs =
      Log.debug (fun m -> m "(in)%s %a" act_name Iri.pp activity#iri);
      let%lwt () = store_local_graph activity graphs in
      let%lwt () = store_obj ~actor graphs obj in
      match Process.activity_obj_as_object obj with
      | None ->
          Process.lwt_return_bad_request "(in)%s: %s has no object"
            act_name (Iri.to_string activity#iri)
      | Some o ->
            (* if the object belongs to actor, add the activity to
             the collection (fun_col) of the object *)
          match Process.activity_obj_author obj with
          | None ->
              Process.lwt_return_bad_request
                "(in)%s: Object %s has no attributedTo or actor"
                act_name (Iri.to_string o#iri)
          | Some author ->
              match Iri.equal actor#iri author with
              | false ->
                  Log.debug (fun m -> m "(in)%s: Object %a is not attributed to %a"
                     act_name Iri.pp o#iri Iri.pp actor#iri);
                  Lwt.return_ok true
              | true ->
                  match Option.map AP.Types.iri_of_lo activity#actor with
                  | None -> (* no author for activity *)
                      Process.lwt_return_bad_request
                      "(in)%s: No author for activity %s"
                        act_name (Iri.to_string activity#iri)
                  | Some liker ->
                      match%lwt col_fun o with
                      | Error (`Msg msg) ->
                          Process.lwt_return_internal_error "(in)%s: %s" act_name msg
                      | Ok likes ->
                          (* if conf does not allow multiple,
                             check that the liker is not yet in the list
                             of like activities of the object *)
                          let%lwt can_add =
                            if allow_multiple then
                              Lwt.return_true
                            else
                              let%lwt g_likes = likes#graph_copy in
                              match g_likes.Rdf.Graph.find ~pred:AS.actor ~obj:(Rdf.Term.Iri liker) () with
                              | _ :: _ ->
                                  Log.info (fun m -> m "(in)%s: %a already %sd %a, not adding"
                                     act_name Iri.pp liker act_name Iri.pp o#iri);
                                  Lwt.return_false
                                | [] -> Lwt.return_true
                          in
                          if can_add then
                            (
                             let payload = [ AS.actor, Rdf.Term.Iri liker ] in
                             let orig_id = match activity#as_id with
                               | None -> activity#id
                               | Some i -> Rdf.Term.Iri i
                             in
                             match%lwt likes#add_item ~unique:true ~payload orig_id with
                             | Error (`Msg msg) ->
                                 Process.lwt_return_internal_error
                                   "(in)%s: %s: %s" act_name
                                   (Rdf.Term.string_of_term activity#id) msg
                             | Ok () ->
                                 Log.info (fun m -> m "(in)%s: %a added to %ss of %a"
                                    act_name Iri.pp liker act_name Iri.pp o#iri);
                                 Lwt.return_ok true
                            )
                          else
                            Lwt.return_ok true

    let handle_announce = handle_plus_one
      ~allow_multiple:O.conf.allow_multiple_announcements
        "Announce" O.object_announces

    let handle_arrive = handle_not_implemented
    let handle_block = handle_not_implemented

    let handle_create ~actor activity obj graphs =
      Log.debug (fun m -> m "(in)handle Create %a" Iri.pp activity#iri);
      let%lwt () = store_local_graph activity graphs in
      let%lwt () = store_obj ~actor graphs obj in
      match Process.activity_obj_as_object obj with
      | None ->
          Process.lwt_return_bad_request "(in)Create %s: no object"
            (Iri.to_string activity#iri)
      | Some o ->
          let%lwt () = Lwt_list.iter_s
            (fun lo -> O.add_reply_to ~acti:activity ~reply:o (AP.Types.iri_of_lo lo))
              o#in_reply_to
          in
          Lwt.return_ok true

    let handle_delete ~actor activity obj graphs =
      Log.debug (fun m -> m "(in)Delete %a" Iri.pp activity#iri);
      match Process.activity_obj_as_object obj with
      | None ->
          Process.lwt_return_bad_request "(in)Delete %s: no object"
            (Iri.to_string activity#iri)
      | Some deleted ->
          (* check permissions from original object, not the one sent
             in activity, to prevent an actor deleting other actor's object
             by pretending being the author. If we can't have original foreign
             object, then we will remove the object in foreign object cache. *)
          let orig_deleted = O.get ~actor deleted#id in
          let%lwt () = orig_deleted#dereference in
          match orig_deleted#is_empty with
          | true ->
              Log.warn (fun m -> m "(in)Delete %a: original %a could not be retrieved, ignoring"
                 Iri.pp activity#iri Iri.pp deleted#iri);
              Lwt.return_ok false
          | false when Iri.equal deleted#type_ AS.c_Tombstone ->
              Log.info (fun m -> m "(in)Delete %a: %a already deleted, ignoring"
                 Iri.pp activity#iri Iri.pp deleted#iri);
              Lwt.return_ok false
          | false ->
              match activity#actor, orig_deleted#as_activity#actor, orig_deleted#attributed_to with
              | None, _, _ ->
                  Log.warn (fun m -> m "(in)Delete %a: %a has no actor"
                     Iri.pp activity#iri Iri.pp deleted#iri);
                  Lwt.return_ok false
              | _, None, None ->
                  Log.warn (fun m -> m "(in)Delete %a: original %a has no actor nor attributedTo"
                     Iri.pp activity#iri Iri.pp deleted#iri);
                  Lwt.return_ok false
              | Some a1, Some a2, _
              | Some a1, None, Some a2 ->
                  let iri1 = AP.Types.iri_of_lo a1
                  and iri2 = AP.Types.iri_of_lo a2 in
                  match Iri.equal iri1 iri2 with
                  | false ->
                      Process.lwt_return_bad_request
                        "(in)Delete: %s and original %s have different actors: %s <> %s"
                         (Iri.to_string activity#iri) (Iri.to_string deleted#iri)
                        (Iri.to_string iri1) (Iri.to_string iri2)
                  | true ->
                      let%lwt () = store_local_graph activity graphs in
                      let%lwt () = O.delete_object ~actor orig_deleted#as_object in
                      Lwt.return_ok true

    let handle_dislike ~actor activity obj graphs =
      Log.debug (fun m -> m "(in)Dislike %a" Iri.pp activity#iri);
      let%lwt () = store_local_graph activity graphs in
      Lwt.return_ok true

    let handle_flag = handle_not_implemented

    let handle_follow ~actor activity obj graphs =
      (* automatically accept by now *)
      Log.debug (fun m -> m "(in)Follow %a" Iri.pp activity#iri);
      match activity#g with
      | None ->
          Process.lwt_return_internal_error "(in)Follow %s: no graph"
            (Iri.to_string activity#iri)
      | Some g ->
          match activity#as_id with
          | None ->
              Process.lwt_return_internal_error "(in)Follow: %s: no original activity iri. g=\n%s"
                 (Iri.to_string activity#iri) (Rdf.Ttl.to_string g)
          | Some orig_acti_iri ->
              let orig_acti_id = Rdf.Term.Iri orig_acti_iri in
              match Process.activity_obj_as_object obj with
              | None ->
                  Process.lwt_return_bad_request "(in)Follow %s: no object_"
                    (Iri.to_string activity#iri)
              | Some followed ->
                  Log.debug (fun m -> m "(in)Follow: followed=%a" Iri.pp followed#iri);
                  match Iri.equal followed#iri actor#iri with
                  | false ->
                      Process.lwt_return_bad_request "actor %s is not the followed %s"
                         (Iri.to_string actor#iri) (Iri.to_string followed#iri)
                  | true ->
                      match activity#actor with
                      | None ->
                          Process.lwt_return_bad_request "(in)Follow: no follower actor"
                      | Some follower ->
                          let follower_iri = AP.Types.iri_of_lo follower in
                          match%lwt O.local_collection actor#outbox#iri with
                          | Error (`Msg msg) ->
                              Process.lwt_return_internal_error "%s" msg
                          | Ok outbox ->
                              let%lwt () = store_local_graph activity graphs in
                              if not actor#manually_approves_followers then
                                ( (* auto-accept the follow demand *)
                                 Log.info (fun m -> m "Auto-accepting Follow demand of %a from %a"
                                    Iri.pp followed#iri Iri.pp follower_iri);
                                 let (accept_id, accept_iri) = AP.Types.gen_id outbox#iri in
                                 let gacc =
                                   let act_id = activity#id in
                                   AP.Object.map_graph
                                     (fun id2 -> if Rdf.Term.equal id2 act_id then orig_acti_id else id2)
                                     g
                                 in
                                 let sub = Rdf.Term.Iri accept_iri in
                                 gacc.add_triple ~sub ~pred:Rdf.Rdf_.type_ ~obj:(Rdf.Term.Iri AS.c_Accept) ;
                                 gacc.add_triple ~sub ~pred:AS.actor ~obj:(Rdf.Term.Iri actor#iri) ;
                                 gacc.add_triple ~sub ~pred:AS.to_ ~obj:(Rdf.Term.Iri follower_iri) ;
                                 gacc.add_triple ~sub ~pred:AS.object_ ~obj:orig_acti_id ;
                                 gacc.add_triple ~sub ~pred:AS.published ~obj:(Rdf.Term.term_of_datetime()) ;
                                 let accept = O.get ~actor ~g:gacc sub in
                                 match%lwt outbox#add_item accept_id with
                                 | Error (`Msg msg) ->
                                     Process.lwt_return_internal_error "(in)Follow: %s" msg
                                 | Ok () ->
                                     Log.warn (fun m -> m "Sending accept to %a" Iri.pp follower_iri);
                                     match%lwt POut.process ~actor accept#as_activity with
                                     | Error e -> Lwt.return_error e
                                     | Ok _ ->
                                         match actor#followers with
                                         | None ->
                                             Process.lwt_return_internal_error
                                               "(in)Follow: no followers collection for %s"
                                            (Iri.to_string actor#iri)
                                         | Some followers ->
                                             match%lwt O.local_collection followers#iri with
                                             | Error (`Msg msg) ->
                                                 Process.lwt_return_internal_error "%s" msg
                                             | Ok followers ->
                                                 match%lwt followers#add_item ~unique:true (Rdf.Term.Iri follower_iri) with
                                                 | Error (`Msg msg) ->
                                                     Process.lwt_return_internal_error "(in)Follow: %s" msg
                                                 | Ok () ->
                                                     Lwt.return_ok true
                                )
                              else
                                Lwt.return_ok true

    let handle_ignore  = handle_not_implemented
    let handle_invite  = handle_not_implemented
    let handle_join  = handle_not_implemented
    let handle_leave  = handle_not_implemented

    let handle_like = handle_plus_one ~allow_multiple:false "Like" O.object_likes

    let handle_listen  = handle_not_implemented
    let handle_move  = handle_not_implemented
    let handle_offer  = handle_not_implemented
    let handle_question  = handle_not_implemented
    let handle_read  = handle_not_implemented
    let handle_reject  = handle_not_implemented
    let handle_remove  = handle_not_implemented
    let handle_tentative_accept  = handle_not_implemented
    let handle_tentative_reject  = handle_not_implemented
    let handle_travel  = handle_not_implemented

    let undo_plus_one act_name col_fun ~actor undone =
      Log.debug (fun m -> m "(in)Undo %s: %a" act_name Iri.pp undone#iri);
      match undone#object_ with
      | None ->
          Process.lwt_return_bad_request
            "(in)Undo %s: %s has no object_" act_name (Iri.to_string undone#iri)
      | Some obj ->
          let%lwt () = obj#dereference in
          match Option.map AP.Types.iri_of_lo obj#attributed_to,
            Option.map AP.Types.iri_of_lo obj#as_activity#actor
          with
          | None, None ->
              Process.lwt_return_bad_request
                "(in)Undo %s: Object %s has no attributedTo or actor"
                 act_name (Iri.to_string obj#iri)
          | Some author_iri, _
          | None, Some author_iri ->
              match Iri.equal author_iri actor#iri with
              | false -> (* current actor is not the author of the object, nothing to do *)
                  Log.info (fun m -> m "(in)Undo %s: actor %s is not the author of %s"
                     act_name (Iri.to_string actor#iri) (Iri.to_string obj#iri));
                  Lwt.return_ok true
              | true ->
                  (* remove original activity (undone) from the
                     collection of the object. *)
                  match%lwt col_fun obj with
                  | Error (`Msg msg) ->
                      Process.lwt_return_internal_error "(in)Undo %s: %s" act_name msg
                  | Ok col ->
                      match%lwt col#remove_item undone#id with
                      | Error (`Msg msg) ->
                          Process.lwt_return_internal_error "(in)Undo %s: %s: %s"
                            act_name (Rdf.Term.string_of_term obj#id) msg
                      | Ok () ->
                          Log.info (fun m -> m "(in)Undo %s: %a removed from %ss of %a"
                             act_name Iri.pp undone#iri act_name Rdf.Term.pp_term obj#id);
                          Lwt.return_ok true

    let undo_announce = undo_plus_one "Announce" O.object_announces

    let undo_dislike ~actor undone =
      Log.debug (fun m -> m "(in)Undo Dislike: %a (nothing to be done)" Iri.pp undone#iri);
      Lwt.return_ok true

    let undo_follow ~actor undone =
      Log.debug (fun m -> m "(in)Undo Follow: %a" Iri.pp undone#iri);
      match undone#object_ with
      | None ->
          Process.lwt_return_bad_request
            "(in)Undo Follow: %s has no object_" (Iri.to_string undone#iri)
      | Some followed ->
          match Iri.equal followed#iri actor#iri with
          | false ->
              Process.lwt_return_bad_request
                "(in)Undo Follow: actor %s is not the followed one %s"
                (Iri.to_string actor#iri) (Iri.to_string followed#iri)
          | true ->
              match undone#actor with
              | None ->
                  Process.lwt_return_bad_request "(in)Undo Follow: no follower actor"
              | Some follower ->
                  let follower_iri = AP.Types.iri_of_lo follower in
                  match actor#followers with
                  | None ->
                      Process.lwt_return_internal_error
                        "(in)Undo Follow: no followers collection for %s"
                        (Iri.to_string actor#iri)
                  | Some followers ->
                      match%lwt O.local_collection followers#iri with
                      | Error (`Msg msg) ->
                          Process.lwt_return_internal_error "%s" msg
                      | Ok followers ->
                          match%lwt followers#remove_item (Rdf.Term.Iri follower_iri) with
                          | Error (`Msg msg) ->
                              Process.lwt_return_internal_error "(in)Undo Follow: %s" msg
                          | Ok () ->
                              Log.info (fun m -> m "%a does not follow %a any more"
                                 Iri.pp follower_iri Iri.pp actor#iri);
                              Lwt.return_ok true

    let undo_like = undo_plus_one "Like" O.object_likes

    let handle_undo ~actor activity obj graphs =
      Log.debug (fun m -> m "(in)Undo %a" Iri.pp activity#iri);
      let%lwt () = store_local_graph activity graphs in
      match obj with
      | `None | `Loop _ ->
          Process.lwt_return_bad_request
            "(in)Undo: %s has no object_" (Iri.to_string activity#iri)
      | `Actor (_,o) | `Object o ->
          Process.lwt_return_bad_request "(in)Undo %s: cannot undo actor or activity %s"
            (Iri.to_string activity#iri) (Iri.to_string o#iri)
      | `Activity (t_undone, undone, _) ->
          let%lwt () = undone#dereference in
          match activity#actor, undone#actor with
          | None, _ ->
              Process.lwt_return_bad_request "(in)Undo: %s has no actor"
                (Iri.to_string activity#iri)
          | _, None ->
              Process.lwt_return_bad_request "(in)Undo: undone %s has no actor"
                (Iri.to_string undone#iri)
          | Some a1, Some a2 ->
              let iri1 = AP.Types.iri_of_lo a1
              and iri2 = AP.Types.iri_of_lo a2 in
              match Iri.equal iri1 iri2 with
              | false ->
                  Process.lwt_return_bad_request
                    "(in)Undo: %s and %s have different actors: %s <> %s"
                    (Iri.to_string activity#iri) (Iri.to_string undone#iri)
                    (Iri.to_string iri1) (Iri.to_string iri2)
              | true ->
                  match t_undone with
                  | `Announce -> undo_announce ~actor undone
                  | `Dislike -> undo_dislike ~actor undone
                  | `Follow -> undo_follow ~actor undone
                  | `Like -> undo_like ~actor undone
                  | t ->
                      Process.lwt_return_internal_error
                        "(in)Undo %s: undo not handled on type %s"
                         (Iri.to_string activity#iri)
                        ( Iri.to_string (AP.Types.iri_of_activity_type t_undone))

    let handle_update ~actor activity obj graphs =
      Log.debug (fun m -> m "(in)Update %a" Iri.pp activity#iri);
      match Process.activity_obj_as_object obj with
      | None ->
          Process.lwt_return_bad_request "(in)Update %s: no object"
            (Iri.to_string activity#iri)
      | Some updated when O.is_local_iri updated#iri ->
          (* do nothing, as the graph has already been updated by POut *)
          let%lwt () = store_local_graph activity graphs in
          Lwt.return_ok true
      | Some updated ->
          (* check permissions from original object, not the one sent
             in activity, to prevent an actor updating other actor's object
             by pretending being the author. If we can't have original
             object, then we ignore the activity. *)
          let orig_updated = O.get ~actor updated#id in
          let%lwt () = orig_updated#dereference in
          match orig_updated#is_empty with
          | true ->
              Log.info (fun m -> m "(in)Update: original %a could not be retrieved, ignoring"
                 Iri.pp activity#iri);
              Lwt.return_ok false
          | false ->
              let%lwt () = store_local_graph activity graphs in
              match activity#actor, orig_updated#as_activity#actor, orig_updated#attributed_to with
              | None, _, _ ->
                  Log.info (fun m -> m "(in)Update: %a has no actor, ignoring" Iri.pp activity#iri);
                  Lwt.return_ok true
              | _, None, None ->
                  Log.info (fun m -> m "(in)Update: original %a has no actor nor attributedTo, ignoring"
                     Iri.pp updated#iri);
                  Lwt.return_ok true
              | Some a1, Some a2, _
              | Some a1, None, Some a2 ->
                  let iri1 = AP.Types.iri_of_lo a1
                  and iri2 = AP.Types.iri_of_lo a2 in
                  match Iri.equal iri1 iri2 with
                  | false ->
                      Process.lwt_return_bad_request
                        "(in)Update: %s and original %s have different actors: %s <> %s"
                        (Iri.to_string activity#iri) (Iri.to_string updated#iri)
                        (Iri.to_string iri1) (Iri.to_string iri2)
                  | true ->
                      (* merge old and new object's graphs *)
                      match Iri.Map.find_opt updated#iri graphs, orig_updated#g with
                      | _, None -> assert false
                      | None, _ ->
                          Log.err (fun m -> m "(in)Update %a: no graph for object %a, ignoring"
                             Iri.pp activity#iri Iri.pp updated#iri);
                          Lwt.return_ok true
                      | Some g, Some old_g ->
                          let g_updated = Process_out.update_graph ~base:old_g ~changes:g updated#id in
                          (* remember we reach here only if this is a foreign graph *)
                          let%lwt () = O.store_foreign_graph ~actor g_updated updated#iri in
                          Lwt.return_ok true

    let handle_view = handle_not_implemented

    let handle_public ~actor activity obj graphs =
      let%lwt () = store_local_graph activity graphs in
      Lwt.return_ok true

(*
    (* store top activity and recursively store foreign objects *)
    let store ~actor (tree:AP.Types.activity_tree) graphs =
      let%lwt () = actor#dereference in
      let (typ, activity, obj) = tree in
      let iri = activity#iri in
      let%lwt () =
        match Iri.Map.find_opt iri graphs with
        | None -> failwith
            (Printf.sprintf "Process_in.store: no graph for %s"
             (Iri.to_string iri))
        | Some g ->  O.store_local_graph g iri
      in
      match typ, obj with
      | ((`Add|`Update|`Create), `None) ->
          Log.warn (fun m -> m "Process_in.store: activity without object: %a" Iri.pp iri);
          Lwt.return_unit
      | ((`Add|`Update|`Create), `Loop _) ->
          Log.warn (fun m -> m "Process_out.store: activity with loop: %a" Iri.pp iri);
          Lwt.return_unit
      | (_, obj) -> store_rec ~actor graphs obj
*)
  end