diff --git a/src/assets.ml b/src/assets.ml index 6b09c6c5..156cdcfd 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -24,8 +24,6 @@ let base_dir = function | Terms -> Config.terms_dir | Privacy -> Config.privacy_dir -let path ~lang ~ext t = Fpath.((base_dir t / lang / etag t) + ext) - (* TODO better use of Fmt to have error prefix or smthing use Logs *) @@ -95,11 +93,21 @@ let supported_lang_arr, supported_ext_arr = in (Array.of_list lang_l, Array.of_list ext_l) +let supported_mimetype_arr = + Array.map Util.extension_to_mimetype supported_ext_arr |> Array.map Option.get + let is_supported_lang lang = Array.mem lang supported_lang_arr let is_supported_ext ext = Array.mem ext supported_ext_arr +let is_supported_mimetype mime = Array.mem mime supported_mimetype_arr -let get_content ~lang ~ext t = - let path = Fpath.to_string (path ~lang ~ext t) in +(* ! lang and mime must be supported *) +let get_content ~lang ~mime t = + let ext = + match Util.mimetype_to_extension mime with + | None -> Fmt.failwith "mimetype `%s/%s` unknown" (fst mime) (snd mime) + | Some ext -> ext + in + let path = Fpath.to_string Fpath.((base_dir t / lang / etag t) + ext) in match Assets_crunch.read path with - | None -> Fmt.error "static file not found: `%s`" path - | Some data -> Ok data + | None -> Fmt.failwith "static file not found: `%s`" path + | Some data -> data diff --git a/src/headers.ml b/src/headers.ml index 68f974ba..94868650 100644 --- a/src/headers.ml +++ b/src/headers.ml @@ -1,14 +1,15 @@ let avail_languages_header_value = - let pp_avail_languages = Fmt.array ~sep:(Fmt.any ", ") Fmt.string in - let s = Fmt.str "%a" pp_avail_languages Assets.supported_lang_arr in + let pp_array = Fmt.array ~sep:(Fmt.any ", ") Fmt.string in + let s = Fmt.str "%a" pp_array Assets.supported_lang_arr in s -let select_extension headers = +let select_mimetype headers = let accept = Vif.Headers.get headers "accept" in Cohttp.Accept.media_ranges accept |> Cohttp.Accept.qsort - |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m) - |> List.find_opt Assets.is_supported_ext + |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_known_mimetype m) + |> List.find_opt Assets.is_supported_mimetype + |> Option.to_result ~none:"no acceptable mimetype" let select_language headers = let accept_language = Vif.Headers.get headers "accept-language" in @@ -23,6 +24,7 @@ let select_language headers = | [] -> assert false | primary_tag :: _ -> primary_tag)) |> List.find_opt Assets.is_supported_lang + |> Option.to_result ~none:"no acceptable language" let select_encoding headers = Vif.Headers.get headers "accept-encoding" diff --git a/src/mte.ml b/src/mte.ml index 6cdbbb6e..fedc463b 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -23,18 +23,6 @@ - When returning a full response (not a "304 Not Modified"), include a "Avail-Languages" header: a comma-separated list of the languages available *) module Static = struct - let select_file headers kind = - let open Syntax in - let* ext = - Option.to_result ~none:"no acceptable mimetype" - (Headers.select_extension headers) - in - let* lang = - Option.to_result ~none:"no acceptable language" - (Headers.select_language headers) - in - Assets.get_content ~lang ~ext kind - let static kind req _server _env = let get_ok = function | Error e -> Fmt.failwith "TODO handle me, %s" e @@ -46,24 +34,28 @@ module Static = struct in let headers = Vif.Request.headers req in let has_matching_etag = - get_ok - @@ match Vif.Headers.get headers "if-none-match" with - | None -> Ok false + | None -> false | Some s -> - Headers.Etag.parse s |> Result.map (Headers.Etag.evaluate etag) + s |> Headers.Etag.parse |> get_ok |> Headers.Etag.evaluate etag in - let open Vif.Response.Syntax in match has_matching_etag with | true -> + let open Vif.Response.Syntax in let* () = Vif.Response.empty in Vif.Response.respond `Not_modified | false -> - let data = select_file headers kind |> get_ok in + let mime = Headers.select_mimetype headers |> get_ok in + let lang = Headers.select_language headers |> get_ok in let compression = Headers.select_encoding headers in + let data = Assets.get_content ~mime ~lang kind in + (* -- *) + let open Vif.Response.Syntax in let* () = Vif.Response.with_string ?compression req data in - let etag_field_value = Headers.Etag.to_field_value etag in - let* () = Vif.Response.add ~field:"etag" etag_field_value in + let* () = + let etag_field_value = Headers.Etag.to_field_value etag in + Vif.Response.add ~field:"etag" etag_field_value + in let* () = (* todo: is it "taler-privacy-version" for /policy ? *) Vif.Response.add ~field:"taler-terms-version" @@ -73,9 +65,9 @@ module Static = struct Vif.Response.add ~field:"avail-languages" Headers.avail_languages_header_value in - (* TODO content-type *) let* () = - Vif.Response.add ~field:"content-type" "html; charset=utf-8" + let content_type = Fmt.str "%s/%s" (fst mime) (snd mime) in + Vif.Response.add ~field:"content-type" content_type in Vif.Response.respond `OK diff --git a/src/util.ml b/src/util.ml index cd5894cb..d9ea04d5 100644 --- a/src/util.ml +++ b/src/util.ml @@ -1,29 +1,36 @@ (* TODO Taler documentation markdown mimetype should be the prefered one, and be supported, according to DD we take text/plain as default instead for now *) +let default_mimetype = ("text", "plain") let default_extension = "txt" -let is_valid_filename, media_to_extension = - let mimetype_ext_assoc = - [ - (("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") - ] - in - (* <> than the actual set of "supported" extension (which depends on config files) *) - let all_known_extensions = mimetype_ext_assoc |> List.split |> snd in - let is_valid_filename path = Fpath.mem_ext all_known_extensions path in - let media_to_extension = function - | Cohttp.Accept.MediaType (m, m_sub) -> - List.assoc_opt (m, m_sub) mimetype_ext_assoc - | AnyMediaSubtype m -> - List.find_map - (fun ((m', _), ext) -> - match String.equal m m' with false -> None | true -> Some ext) - mimetype_ext_assoc - | AnyMedia -> Some default_extension - in - (is_valid_filename, media_to_extension) +let mimetype_ext_assoc = + [ + (("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") + ] + +(* <> than the actual set of "supported" extension (which depends on config files) *) +let all_known_mimetypes, all_known_extensions = List.split mimetype_ext_assoc +let is_valid_filename path = Fpath.mem_ext all_known_extensions path + +let media_to_known_mimetype = function + | Cohttp.Accept.MediaType (m, m_sub) -> + List.find_opt (( = ) (m, m_sub)) all_known_mimetypes + | AnyMediaSubtype m -> + List.find_opt (fun (m', _) -> String.equal m m') all_known_mimetypes + | AnyMedia -> Some default_mimetype + +let mimetype_to_extension (m, m_sub) = + assert (m <> "*"); + assert (m_sub <> "*"); + List.assoc_opt (m, m_sub) mimetype_ext_assoc + +let extension_to_mimetype ext = + List.find_map + (fun (mime, ext') -> + match String.equal ext ext' with false -> None | true -> Some mime) + mimetype_ext_assoc