mte/src/assets.ml

(* https://docs.taler.net/design-documents/003-tos-rendering.html
   https://docs.taler.net/design-documents/003-tos-rendering.html

   must support `text/plain` and `text/markdown` *)

type t =
  | Terms
  | Privacy

module Assets_config = struct
  (* 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
  let base_dir = function Terms -> "terms" | Privacy -> "privacy"

  (* TODO this should be in the config like terms_etag *)
  let terms_legal_version = "0"
  let privacy_legal_version = "0"
end

let etag k =
  let etag =
    match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
  in
  etag |> Headers_lib.Etag.parse |> Result.get_ok

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

let supported_lang_arr, supported_ext_arr =
  let aux t =
    let prefix = Fpath.v (Assets_config.base_dir t) in
    let path_l = List.map Fpath.v Assets_crunch.file_list in
    let path_l = List.filter_map (Fpath.rem_prefix prefix) path_l in
    let ext_l =
      path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare
    in
    let lang_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 Fpath.(prefix // path)))
        path_l
    in
    let lang_l = List.sort_uniq String.compare lang_l in
    let etag = (etag t).value in
    List.iter
      (fun path ->
        let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in
        if not @@ String.equal etag etag' then
          Fmt.failwith
            "filename of file `%s` does not match configuration ETAG value `%s`"
            (Fpath.to_string Fpath.(prefix // path))
            etag)
      path_l;
    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 Assets_config.default_lang lang_l then
      Fmt.failwith "default language `%s` files not found"
        Assets_config.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"
    else (lang_l, ext_l)
  in
  let lang_l, ext_l = aux Terms in
  let lang_l', ext_l' = aux Privacy in
  match
    List.equal String.equal lang_l lang_l'
    && List.equal String.equal ext_l ext_l'
  with
  | false ->
      Fmt.failwith
        "invalid folder structure, /terms and /privacy must support the same \
         set of languages and mimetypes"
  | true -> (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 arr =
    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 -> Array.of_list all_supported

  let default =
    match
      List.mem
        (Assets_config.default_mimetype, Assets_config.default_extension)
        assoc
    with
    | false ->
        Fmt.failwith "default content type `%a` not supported" pp
          Assets_config.default_mimetype
    | true -> Assets_config.default_mimetype

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

  let to_extension_exn t =
    match List.assoc_opt t assoc with
    | None -> Fmt.failwith "Mimetype.to_extension failure: `%a` unknown" pp t
    | Some ext -> ext
end

module Language = struct
  type t = string

  let arr = supported_lang_arr
  let default = Assets_config.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 ext = Mimetype.to_extension_exn mime in
  let path =
    Fpath.to_string
      Fpath.((v (Assets_config.base_dir t) / lang / (etag t).value) + ext)
  in
  match Assets_crunch.read path with
  | None -> Fmt.failwith "static file not found: `%s`" path
  | Some data -> data