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

(** Utilities *)

type E.error +=
| Time_error of string

let () = E.register_string_of_error
  (function
   | Time_error msg -> Some (Printf.sprintf "Time error: %s" msg)
   | _ -> None)

let sha256 str =
  let hash = Cryptokit.Hash.sha256 () in
  hash#add_string str ;
  let str = hash#result in
  hash#wipe ;
  str

let mkdir dir =
  let com = Printf.sprintf "mkdir -p %s" (Filename.quote dir) in
  match%lwt Lwt_process.(exec (shell com)) with
    Unix.WEXITED 0 -> Lwt.return_unit
  | _ -> Lwt.fail_with (Printf.sprintf "Command failed: %s" com)

let dir_exists dir =
  try%lwt
    let%lwt s = Lwt_unix.stat dir in
    match s.Unix.st_kind with
    | S_DIR -> Lwt.return_true
    | _ -> Lwt.return_false
  with Unix.Unix_error _ -> Lwt.return_false

(** [graph_keep_only_from ?keep g term] returns a new graph with the same name as [g],
  keeping only triples reachable from [term], and only following blank nodes or
  IRIs when [keep iri] returns [true], i.e. when an IRI is encountered, we do
  not add triples with this IRI as subject if [keep iri] returns [false].
  Default [keep] always return false. *)
let graph_keep_only_from =
  let module S = Rdf.Term.TSet in
  let rec f keep g1 g2 seen (sub, pred, obj) =
    g2.Rdf.Graph.add_triple ~sub ~pred ~obj;
    match obj with
    | Rdf.Term.Blank_ _ -> fold keep g1 g2 seen obj
    | Rdf.Term.Iri iri when keep iri -> fold keep  g1 g2 seen obj
    | _ -> seen
  and fold keep g1 g2 seen sub =
    if S.mem sub seen then
      seen
    else
      let seen = S.add sub seen in
      List.fold_left (f keep g1 g2) seen (g1.Rdf.Graph.find ~sub ())
  in
  fun ?(keep=(fun _ -> false)) g term ->
    let g2 = Rdf.Graph.(open_graph (g.name())) in
    ignore (fold keep g g2 S.empty term);
    g2

let filename_wrapper =
  let to_json ?with_doc fn = `String fn in
  let from_json ?def = function
  | `String str ->
      begin
        if Filename.is_relative str then
          Filename.concat (Sys.getcwd()) str
        else
          str
      end
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

let iri_wrapper =
  let to_json ?with_doc iri = `String (Iri.to_string iri) in
  let from_json ?def = function
  | `String str -> Iri.of_string str
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

let mime_wrapper =
  let to_json ?with_doc mime = `String (Ldp.Ct.mime_to_string mime) in
  let from_json ?def = function
  | (`String str) as json ->
      (match Ldp.Ct.mime_of_string str with
       | Error _ -> Ocf.invalid_value json
       | Ok m -> m)
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

let ptime_wrapper =
  let to_json ?with_doc t = `String (Ptime.to_rfc3339 t) in
  let of_json ?def = function
  | `String s ->
      (
       match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
       | Error (`Msg msg) ->
           Log.err (fun m -> m "%s: %s" s msg);
           Ocf.invalid_value (`String s)
       | Ok (t, _, _) -> t
      )
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json of_json

let is_prefix_iri =
  let rec is_prefix_path l1 l2 =
    match l1, l2 with
    | [], [] -> true
    | _, [] -> false
    | [], _
    | [""], _ -> true
    | h1 :: q1, h2 :: q2 -> h1 = h2 && is_prefix_path q1 q2
  in
  fun i1 i2 ->
    let open Iri in
    let b =
      Iri.scheme i1 = Iri.scheme i2
      && Iri.host i1 = Iri.host i2
      && Iri.user i1 = Iri.user i2
      && Iri.port i1 = Iri.port i2
      && (
      match Iri.path i1, Iri.path i2 with
      | Absolute l1, Absolute l2 -> is_prefix_path l1 l2
      | _ -> false
      )
    in
    (*if not b then Log.debug (fun m -> m "i1=%a\ni2=%a" Iri.pp_details i1 Iri.pp_details i2);*)
    b


let static_mime str =
  match Ldp.Ct.mime_of_string str with
  | Ok t -> t
  | Error e ->  prerr_endline (Ldp.Ct.string_of_error e); assert false

let mime_xhtml = Ldp.Ct.mime_xhtml
let mime_nquads = static_mime "application/n-quads"
let mime_jsonld = static_mime "application/ld+json"
let mime_ap = static_mime "application/activity+json"
let mime_jrd_json = static_mime "application/jrd+json"

let jsonld_document_loader (dl: ?headers:Cohttp.Header.t -> Iri.t -> (string, exn) result Lwt.t) iri =
  match Iri.Map.find_opt iri Jsonld_static.contexts with
  | Some str -> Lwt.return_ok str
  | None ->
      let headers = Cohttp.Header.init_with "accept" (Ldp.Ct.mime_to_string mime_jsonld) in
      dl ~headers iri

let location_header : Ldp.Types.meta -> string option = fun meta ->
  let (resp, _) = meta.Ldp.Types.info in
  let h = resp.headers in
  Cohttp.Header.get h "location"

let list_slice =
  let rec iter acc ~start ~stop i = function
  | [] -> List.rev acc
  | h :: q ->
      if i > stop then
        List.rev acc
      else
        let acc =
          if i >= start && i <= stop then h::acc else acc
        in
        iter acc ~start ~stop (i+1) q
  in
  fun ~start ~stop l -> iter [] ~start ~stop 0 l

module AS = Rdf.Activitypub

let hack_jsonld : Rdf_json_ld.J.json -> Rdf_json_ld.J.json =
  let open Rdf_json_ld.J in
  let contexts =
    List.map Iri.of_string
      [ "https://www.w3.org/ns/activitystreams#" ;
        "https://w3id.org/security/v1#" ;
        "http://www.w3.org/ns/ldp#" ;
        "http://www.w3.org/1999/02/22-rdf-syntax-ns#" ;
      ]
  in
  let map_iri str =
    match Iri.of_string str with
    | iri ->
        if List.exists (fun i -> is_prefix_iri iri i) contexts then
          match Iri.fragment iri with
          | None -> None
          | Some k -> Some k
        else
          None
    | exception _ -> None
  in
  let split_values_on_id = function
  | { data = `Obj l } ->
      List.fold_left (fun (acc, acc_other) -> function
         | { data = "id"}, v -> v, acc_other
         | { data = "@id"}, _ -> acc, acc_other
         | k, v -> acc, (k,v) :: acc_other
      ) (Rdf_json_ld.J.string "", []) l
  | x -> x, []
  in
  let rec simplify_obj (json:json) : json =
    match json.data with
    | `Obj [ {data="id"}, v ] -> v
    | `Obj [ {data="@value"}, v ] -> v
    | `List l -> { json with data = `List (List.map simplify_obj l) }
    | _ -> json
  in
  let rec iter = function
  | { data = `Obj fields } as x ->
      let fields = List.map iter_assoc fields in
      (* if "type" is orderedCollection or orderedCollectionPage then replace
         items field by orderedItems *)
      let fields =
        match Rdf_json_ld.J.map_get fields "type" with
        | Some { data = `String ("OrderedCollection" | "OrderedCollectionPage") } ->
            (match Rdf_json_ld.J.map_get fields "items" with
             | None -> fields
             | Some v ->
                 Rdf_json_ld.J.(map_add_value
                  (map_remove_value fields "items") "orderedItems" v)
            )
        | _ -> fields
      in
      (* remove id if @id is present *)
      let (fields, replaced_fields) =
        match List.find_opt (function ({ data = "id" },_) -> true | _ -> false) fields with
        | None ->
            List.fold_left (fun (acc_f, acc_rf) -> function
               | ({data = "@id"} as k, v) ->
                   let v_id, other_fields = split_values_on_id v in
                   ({ k with data = "id"}, v_id) :: acc_f, acc_rf @ other_fields
               | x -> x::acc_f, acc_rf
            ) ([], []) fields
        | Some (k,v) ->
            let fields = List.filter
              (function ({ data = ("@id"|"id") },_) -> false | _ -> true) fields
            in
            let v_id, other_fields = split_values_on_id v in
            let fields = (k,v_id) :: fields in
            fields, other_fields
      in
      let fields = List.fold_left
        (fun map (k,v) ->
           Rdf_json_ld.J.(map_add_value (map_remove_value map k.data) k.data v))
          fields replaced_fields
      in
      (* put datetimes inline *)
      let fields = List.map
        (function
             (k, ({ data = `Obj l } as v)) ->
             if List.exists
               (function ({data="@type"}, {data=`String "http://www.w3.org/2001/XMLSchema#dateTime"}) -> true
                | _ -> false)
                 l
             then
               match Rdf_json_ld.J.map_get l "@value" with
               | None -> (k, v)
               | Some va -> (k, va)
             else (k, v)
         | x -> x
        )
        fields
      in
      (*Log.debug (fun m -> m "fields=%a" pp (ranged (`Obj fields)));*)
      let fields = List.map (fun (k, v) -> (k, simplify_obj v)) fields in
      (*Log.debug (fun m -> m "simplified(fields)=%a" pp (ranged (`Obj fields)));*)
      { x with data = `Obj fields }
  | { data = `List l} as x -> { x with data = `List (List.map iter l) }
  | { data = `String str} as x ->
      (match map_iri str with
       | None -> x
       | Some frag -> { x with data = `String frag }
      )
  | x -> x
  and iter_assoc (key, json) =
      let key =
        match map_iri key.data with
        | None -> key
        | Some k -> {key with data = k}
      in
      let json =
        match key.data, json.data with
        | "@id", `String str ->
            (match map_iri str with
             | None -> iter json
             | Some frag -> ranged (`String frag))
        | "type", `Obj [{ data = "@id" }, json] -> iter json
        | ("to" | "cc" | "bto" | "bcc"), `List _ -> iter json
        | ("to" | "cc" | "bto" | "bcc"), _ ->
            (*Log.debug (fun m -> m "to|cc|bto|bcc: %a" pp json);*)
            iter (ranged (`List [json]))
        | _ -> iter json
      in
      (key, json)
  in
  fun json ->
    match iter json with
    | { data = `Obj fields } as x->
        (
         let fields =
           (ranged "@context", ranged (`List [
              ranged (`String "https://www.w3.org/ns/activitystreams") ;
              ranged (`String "https://w3id.org/security/v1") ;
            ])) :: fields
         in
         { x with data = `Obj fields }
        )
    | x -> iter x


(*
let hack_jsonld x =
  let hx = hack_jsonld x in
  Rdf_json_ld.J.(Log.info (fun m -> m "hack_jsonld: %a\n=>\n%a"
      pp x pp hx));
  hx
*)

let log_level_wrapper : Logs.level option Ocf.Wrapper.t =
  let to_j ?with_doc k = `String (Logs.level_to_string k) in
  let from_j ?def = function
  | `String s ->
      (match Logs.level_of_string s with
      | Ok l -> l
      | Error (`Msg _) ->
           failwith (Printf.sprintf "invalid log level %S" s)
      )
  | json ->
      let msg = Printf.sprintf
        "Invalid key %S" (Yojson.Safe.to_string json)
      in
      failwith msg
  in
  Ocf.Wrapper.make to_j from_j

let to_ptime f =
  match Ptime.of_float_s f with
  | None -> E.error (Time_error (Printf.sprintf "invalid time %f" f))
  | Some t -> t

let ptime_now () = to_ptime (Unix.gettimeofday ())

let ptime_to_utc_string t =
  let www =
    Ptime.weekday t |> function `Sat -> "Sat" |`Fri -> "Fri" |`Mon -> "Mon" |`Wed -> "Wed" |`Sun -> "Sun" |`Tue -> "Tue" |`Thu -> "Thu" in
  let ((yyyy,mmm,dd), ((hh,mm,ss), _)) = Ptime.to_date_time t  in
  let mmm = match mmm with
    | 1 -> "Jan" | 2 -> "Feb" | 3 -> "Mar" | 4 -> "Apr" | 5 -> "May"
    | 6 -> "Jun" | 7 -> "Jul" | 8 -> "Aug" | 9 -> "Sep" | 10 -> "Oct"
    | 11 -> "Nov" | 12 -> "Dec" | _ -> assert false in
  Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT"
    www dd mmm yyyy hh mm ss