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

(** Simple cache implementation to cache HTTP query results. *)

type E.error +=
| No_scheme of Iri.t
| No_host of Iri.t
| Unexpected_json of Yojson.Safe.t
| Missing_json_field of string

(**/**)

let unexpected_json json = E.error (Unexpected_json json)
let missing_json_field fd = E.error (Missing_json_field fd)

let string_of_error =
  let msg str = Some (Printf.sprintf "Cache: %s" str) in
  function
  | No_scheme iri -> msg (Printf.sprintf "No scheme in %S" (Iri.to_string iri))
  | No_host iri -> msg (Printf.sprintf "No host in %S" (Iri.to_string iri))
  | Unexpected_json json -> msg (Printf.sprintf "Unexpected JSON %S" (Yojson.Safe.to_string json))
  | Missing_json_field field -> msg (Printf.sprintf "Missing field %S in JSON" field)
  | _ -> None

let () = E.register_string_of_error string_of_error

let fp_append p x =
  let r = Fpath.append p x in
  (*Log.debug (fun m -> m "append %S + %S => %S"
    (Fpath.to_string p) (Fpath.to_string x) (Fpath.to_string r));*)
  r

let file_of_iri cache_root iri =
  let iri = Iri.normalize iri in
  let scheme = Iri.scheme iri in
  let host = match Iri.host iri with
    | None -> E.error (No_host iri)
    | Some h -> h
  in
  let p =
    let base = Printf.sprintf "%s+++%s%s%s"
      scheme
        (match Iri.user iri with None -> "" | Some s -> Printf.sprintf "@%s" s)
        host
        (match Iri.port iri with None -> "" | Some n -> Printf.sprintf ":%d" n)
    in
    fp_append cache_root (Fpath.v base)
  in
  let fn =
    let iri = Iri.with_scheme iri "" in
    let iri = Iri.with_user iri None in
    let iri = Iri.with_host iri None in
    let iri = Iri.with_port iri None in
    let iri = Iri.with_fragment iri None in
    Iri.to_string iri
  in
  let fn =
    match fn with
    | "/" -> "/"
    | _ ->
        match Fpath.(relativize ~root:(v "/") (v fn)) with
        | None -> assert false
        | Some fn -> Fpath.to_string fn
  in
  let fn = Digest.(to_hex (string fn)) in
  fp_append p (Fpath.v fn)

let json_get ~map field l =
  match map, List.assoc field l with
  | exception Not_found -> missing_json_field field
  | `String f, `String str -> f str
  | `String f, `Int n -> f (string_of_int n)
  | `Int f, `Int n -> f n
  | `Bool f, `Bool b -> f b
  | `Json f, json -> f json
  | _, json -> unexpected_json json

let string_of_encoding =
  function
  | Cohttp.Transfer.Chunked -> "chunked"
  | Fixed i -> Printf.sprintf "%Ld" i
  | Unknown -> "unknown"
let encoding_of_string = function
  | "chunked" -> Cohttp.Transfer.Chunked
  | "unknown" -> Cohttp.Transfer.Unknown
  | str ->
    try Cohttp.Transfer.Fixed (Int64.of_string str)
    with _ -> unexpected_json (`String str)

let header_value_of_json = function
| `String str -> [ str ]
| `List l -> List.map (function `String s -> s | json -> unexpected_json json) l
| json -> unexpected_json json

let header_of_json = function
| `Assoc l ->
    begin
      let module H = Cohttp.Header in
      List.fold_left
        (fun acc (key, json) -> H.add_multi acc key (header_value_of_json json))
        (H.init())
        l
    end
| json -> unexpected_json json

let response_of_json = function
| `Assoc l ->
    begin
      let encoding = json_get
        ~map:(`String encoding_of_string) "encoding" l
      in
      let version = json_get ~map:(`String Cohttp.Code.version_of_string) "version" l in
      let status = json_get ~map:(`Int (fun n -> Cohttp.Code.status_of_code n)) "status" l in
      let flush = json_get ~map:(`Bool (fun b -> b)) "flush" l in
      let headers = json_get ~map:(`Json header_of_json) "headers" l in
      { Cohttp.Response.encoding ; headers ; version ; status ; flush }
    end
| json -> unexpected_json json

let meta_of_json = function
| `Assoc l ->
    let iri = json_get ~map:(`String Iri.of_string) "iri" l in
    let resp = json_get ~map:(`Json response_of_json) "response" l in
    (iri, resp)
| json -> unexpected_json json

let json_of_header h =
  let module H = Cohttp.Header in
  let assoc = ref [] in
  H.iter (fun k -> function
     | "" -> ()
     | v -> assoc := (k, `String v) :: !assoc)
     h;
  `Assoc !assoc

let json_of_response r =
  let open Cohttp.Response in
  `Assoc [
    "encoding", `String (string_of_encoding r.encoding) ;
    "headers", json_of_header r.headers ;
    "status", `Int (Cohttp.Code.code_of_status r.status) ;
    "version", `String (Cohttp.Code.string_of_version r.version) ;
    "flush", `Bool r.flush ;
  ]

let store_resource file iri resp body =
  let file = Fpath.to_string file in
  let%lwt () = Utils.mkdir (Filename.dirname file) in
  match%lwt Lwt_io.(with_file ~mode:output file (fun oc -> write oc body)) with
  | exception e ->
      Log.err (fun m -> m "%s" (Printexc.to_string e));
      Lwt.return_unit
  | () ->
      let file_meta = file^",meta" in
      let json =
        `Assoc [
          "iri", `String (Iri.to_string iri) ;
          "response", json_of_response resp ;
        ]
      in
      let json_s = Yojson.Safe.pretty_to_string json in
      match%lwt Lwt_io.(with_file ~mode:output file_meta (fun oc -> write oc json_s)) with
      | exception e ->
          Log.err (fun m -> m "%s" (Printexc.to_string e));
          Lwt_unix.unlink file
      | () -> Lwt.return_unit

(* FIXME: add cache date in header in
  https://www.rfc-editor.org/rfc/rfc9110#field.date format.
let cache_date_header = "cache-date"
 *)
let read_resource file =
  let file = Fpath.to_string file in
  match%lwt Lwt_io.(with_file ~mode:input file read) with
  | exception _ -> Lwt.return_none
  | body ->
      let file = file^",meta" in
      match%lwt Lwt_io.(with_file ~mode:input file read) with
      | exception _ -> Lwt.return_none
      | str ->
          let%lwt st = Lwt_unix.stat file in
          let mtime = st.Unix.st_mtime in
          let mtime = Utils.to_ptime mtime in
          match meta_of_json (Yojson.Safe.from_string str) with
          | exception _ ->
              (* corruted file, remove it *)
              let%lwt () = try%lwt Lwt_unix.unlink file with _ -> Lwt.return_unit in
              Lwt.return_none
          | (_iri, resp) ->
              (*let module H = Cohttp.Header in
                 let headers = H.add resp.Cohttp.Response.headers cache_date_header cache_date in
                 let resp = { resp with headers } in*)
              Lwt.return_some (mtime, resp, body)

(**/**)

(** [mk_cache ~root ~delay] creates a cache storing files under [root]
  and entries expiring after [delay].*)
let mk_cache ~root ~delay =
  Log.info (fun m -> m "Initializing cache root %S" root);
  let%lwt () = Utils.mkdir root in
  let module Cache_impl =
    struct
      type key = (Fpath.t * Iri.t)
      let clear () = Lwt.return_unit
      let key h iri =
          try Some (file_of_iri (Fpath.v root) iri, iri)
          with e ->
              Log.err (fun m -> m "%s" (Printexc.to_string e));
              None
      let store (file, iri) resp body =
        Log.debug (fun m -> m "Cache: storing %a to %s" Iri.pp iri (Fpath.to_string file));
        let%lwt() = store_resource file iri resp body in
        Lwt.return (resp, body)
      let find (file, iri) =
        match%lwt read_resource file with
        | Some (mtime, resp, body) ->
          let now = Utils.ptime_now () in
          let span = Ptime.diff now mtime in
          (match Ptime.Span.to_int_s span with
           | Some nsecs when nsecs <= delay ->
                Log.debug (fun m -> m "Cache: %a found (%s)" Iri.pp iri (Fpath.to_string file));
                Lwt.return (Ldp.Http.Found (resp, body))
           | Some _ ->
                Log.debug (fun m -> m "Cache: %a expired (%s)" Iri.pp iri (Fpath.to_string file));
                let f _ _ = Lwt.return (resp, body) in
                Lwt.return (Ldp.Http.If_error f)
           | None ->
                Log.debug (fun m -> m "Cache: %a NOT found (%s)" Iri.pp iri (Fpath.to_string file));
                Lwt.return Ldp.Http.Not_found
          )
        | None ->
            Log.debug (fun m -> m "Cache: %a NOT found (%s)" Iri.pp iri (Fpath.to_string file));
            Lwt.return Ldp.Http.Not_found
    end
  in
  Lwt.return (module Cache_impl : Ldp.Http.Cache_impl)