mte/src/assets.ml

(* doc: https://docs.taler.net/design-documents/003-tos-rendering.html
   - must support `text/plain` and `text/markdown` *)

(* hardcoded config just for static assets *)
let default_lang = "en"
let default_mimetype = ("text", "plain")
let default_extension = ".txt"
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity

(* TODO how to update ToS version? *)
let terms_legal_version = "0"
let privacy_legal_version = "0"

(* TODO config *)
type t =
  | Terms
  | Privacy

(* TODO etag = filename *)
let etag k =
  let etag = match k with Terms -> "0" | Privacy -> "0" in
  etag |> Headers_lib.Etag.of_crockford32 |> Result.get_ok

let legal_version = function
  | Terms -> terms_legal_version
  | Privacy -> privacy_legal_version

let base_dir = function Terms -> "terms" | Privacy -> "privacy"

(* TODO clean up this horror *)
let supported_lang_arr, supported_ext_arr =
  let open Syntax in
  let path_l =
    Assets_crunch.file_list |> list_map Fpath.of_string |> function
    | Error (`Msg e) -> Fmt.failwith "%s" e
    | Ok x -> x
  in
  let aux t =
    let prefix = Fpath.v (base_dir t) in
    let path_l = path_l |> List.filter_map (Fpath.rem_prefix prefix) in
    let ext_l =
      path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare
    in
    let lang_l =
      path_l
      |> List.map (fun path ->
          match Fpath.segs path with
          | [] -> assert false
          | [ dir; _file ] -> dir
          | _l ->
              Fmt.failwith "invalid folder structure, file `%s` is misplaced"
                (Fpath.to_string path))
      |> List.sort_uniq String.compare
    in
    let () =
      if List.is_empty lang_l then Fmt.failwith "no language supported";
      if List.is_empty ext_l then Fmt.failwith "no mimetype supported";
      if not @@ List.mem default_lang lang_l then
        Fmt.failwith "default language `%s` files not found" default_lang;
      if not @@ List.mem ".txt" ext_l then
        Fmt.failwith "plain text file not found";
      if not @@ List.mem ".md" ext_l then Fmt.failwith "markdown file not found";
      List.iter
        (fun dir ->
          if String.length dir <> 2 then
            Fmt.failwith "language directory with invalid name: `%s`" dir)
        lang_l;
      if List.length path_l <> List.length ext_l * List.length lang_l then
        Fmt.failwith
          "invalid folder structure, all supported language must provide the \
           same set of file mimetype"
    in
    (lang_l, ext_l)
  in
  let lang_l, ext_l = aux Terms in
  let lang_l', ext_l' = aux Privacy in
  let () =
    if
      not
      @@ (List.equal String.equal lang_l lang_l'
         && List.equal String.equal ext_l ext_l')
    then
      Fmt.failwith
        "invalid folder structure, /terms and /privacy must support the same \
         set of languages and mimetypes";
    ()
  in
  (Array.of_list lang_l, Array.of_list ext_l)

module Mimetype = struct
  type t = string * string

  let pp fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)

  let assoc =
    List.filter
      (fun (_mime, ext) -> Array.mem ext supported_ext_arr)
      [
        (("text", "plain"), ".txt");
        (("text", "markdown"), ".md");
        (("text", "html"), ".html");
        (("text", "html"), ".htm");
        (("application", "pdf"), ".pdf");
        (("image", "jpeg"), ".jpg");
        (("image", "jpeg"), ".jpeg");
        (("image", "png"), ".png");
        (("image", "gif"), ".gif");
      ]

  let all_supported =
    let all_supported, all_supported_ext = List.split assoc in
    match
      Array.find_opt
        (fun ext -> not @@ List.exists (( = ) ext) all_supported_ext)
        supported_ext_arr
    with
    | Some ext -> Fmt.failwith "extension `%s` unsupported" ext
    | None -> all_supported

  let default = default_mimetype

  let of_cohttp = function
    | Cohttp.Accept.MediaType (m, m_sub) ->
        List.find_opt (( = ) (m, m_sub)) all_supported
    | AnyMediaSubtype m ->
        List.find_opt (fun (m', _) -> String.equal m m') all_supported
    | AnyMedia -> Some default

  let to_extension_exn t =
    match List.assoc_opt t assoc with
    | None ->
        Fmt.failwith "Mimetype.to_extension failure: `%s/%s` unknown" (fst t)
          (snd t)
    | Some ext -> ext
end

module Language = struct
  type t = string

  let default = default_lang

  let of_cohttp = function
    | Cohttp.Accept.AnyLanguage -> Some default
    | Language language_range -> (
        (* ignore language subtags (e.g. "en-US" -> "en") *)
        match language_range with
        | [] -> assert false
        | lang :: _ when Array.mem lang supported_lang_arr -> Some lang
        | _ -> None)
end

(* ! lang and mime must be supported *)
let get_content ~lang ~mime t =
  let etag = Headers_lib.Etag.to_raw_string (etag t) in
  let ext = Mimetype.to_extension_exn mime in
  let path = Fpath.to_string Fpath.((v (base_dir t) / lang / etag) + ext) in
  match Assets_crunch.read path with
  | None -> Fmt.failwith "static file not found: `%s`" path
  | Some data -> data