add content-type header

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 =
+(* ! lang and mime must be supported *)
-  let path = Fpath.to_string (path ~lang ~ext t) in
+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
+  | None -> Fmt.failwith "static file not found: `%s`" path
-  | Some data -> Ok data
+  | Some data -> data

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 pp_array = Fmt.array ~sep:(Fmt.any ", ") Fmt.string in
-  let s = Fmt.str "%a" pp_avail_languages Assets.supported_lang_arr 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.filter_map (fun (_q, (m, _p)) -> Util.media_to_known_mimetype m)
-  |> List.find_opt Assets.is_supported_ext
+  |> 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"

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* () =
-        let* () = Vif.Response.add ~field:"etag" etag_field_value in
+          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
 

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 =
-  let mimetype_ext_assoc =
+  [
-    [
+    (("text", "plain"), "txt"); (("text", "markdown"), "md")
-      (("text", "plain"), "txt"); (("text", "markdown"), "md")
+  ; (("text", "html"), "html"); (("text", "html"), "htm")
-    ; (("text", "html"), "html"); (("text", "html"), "htm")
+  ; (("application", "pdf"), "pdf"); (("image", "jpeg"), "jpg")
-    ; (("application", "pdf"), "pdf"); (("image", "jpeg"), "jpg")
+  ; (("image", "jpeg"), "jpeg"); (("image", "png"), "png")
-    ; (("image", "jpeg"), "jpeg"); (("image", "png"), "png")
+  ; (("image", "gif"), "gif")
-    ; (("image", "gif"), "gif")
+  ]
-    ]
+
-  in
+(* <> than the actual set of "supported" extension (which depends on config files) *)
-  (* <> 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 all_known_extensions = mimetype_ext_assoc |> List.split |> snd in
+let is_valid_filename path = Fpath.mem_ext all_known_extensions path
-  let is_valid_filename path = Fpath.mem_ext all_known_extensions path in
+
-  let media_to_extension = function
+let media_to_known_mimetype = function
-    | Cohttp.Accept.MediaType (m, m_sub) ->
+  | Cohttp.Accept.MediaType (m, m_sub) ->
-        List.assoc_opt (m, m_sub) mimetype_ext_assoc
+      List.find_opt (( = ) (m, m_sub)) all_known_mimetypes
-    | AnyMediaSubtype m ->
+  | AnyMediaSubtype m ->
-        List.find_map
+      List.find_opt (fun (m', _) -> String.equal m m') all_known_mimetypes
-          (fun ((m', _), ext) ->
+  | AnyMedia -> Some default_mimetype
-            match String.equal m m' with false -> None | true -> Some ext)
+
-          mimetype_ext_assoc
+let mimetype_to_extension (m, m_sub) =
-    | AnyMedia -> Some default_extension
+  assert (m <> "*");
-  in
+  assert (m_sub <> "*");
-  (is_valid_filename, media_to_extension)
+  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