src/headers.ml

@@ -12,9 +12,6 @@ let select_mimetype headers =
   Cohttp.Accept.media_ranges opt
   |> Cohttp.Accept.qsort
   |> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
-  |> function
-  | None -> Assets.Mimetype.default
-  | Some mime -> mime
 
 let select_language headers =
   let opt = Vif.Headers.get headers "accept-language" in
@@ -22,9 +19,6 @@ let select_language headers =
   |> Cohttp.Accept.qsort
   |> List.map snd
   |> List.find_map Assets.Language.of_cohttp
-  |> function
-  | None -> Assets.Language.default
-  | Some lang -> lang
 
 let select_encoding headers =
   let opt = Vif.Headers.get headers "accept-encoding" in

src/respond.ml

@@ -24,6 +24,15 @@ let bad_request ?hint req =
   let body = mk_error_content ?hint `Bad_request in
   respond_json req body `Bad_request
 
+let unsupported_media_type req =
+  Logs.err (fun m -> m "unsupported media type");
+  let open Vif.Response in
+  let open Syntax in
+  let* () = add ~field:"accept" Headers.accept_header_value in
+  let* () = add ~field:"avail-languages" Headers.avail_languages_header_value in
+  let body = mk_error_content `Unsupported_media_type in
+  respond_json req body `Unsupported_media_type
+
 let ok content req =
   Logs.debug (fun m -> m "ok");
   respond_json req content `OK

src/static.ml

@@ -13,9 +13,14 @@ let aux asset req _server _env =
   match has_matching_etag with
   | Error e -> Respond.bad_request ~hint:e req
   | Ok true -> Respond.not_modified ()
-  | Ok false ->
+  | Ok false -> (
-      let mime = Headers.select_mimetype headers in
+      match Headers.select_mimetype headers with
-      let lang = Headers.select_language headers in
+      | None -> Respond.unsupported_media_type req
+      | Some mime ->
+          let lang =
+            Headers.select_language headers
+            |> Option.value ~default:Assets.Language.default
+          in
           let compression = Headers.select_encoding headers in
           let data = Assets.get_content ~mime ~lang asset in
           (* -- *)
@@ -26,18 +31,19 @@ let aux asset req _server _env =
             let etag_field_value = Headers_lib.Etag.to_field_string etag in
             add ~field:"etag" etag_field_value
           in
+          let* () = add ~field:"accept" Headers.accept_header_value in
+          let* () =
+            add ~field:"avail-languages" Headers.avail_languages_header_value
+          in
           let* () =
             (* todo: is it "taler-privacy-version" for /policy ? *)
             add ~field:"taler-terms-version" (Assets.legal_version asset)
           in
-      let* () =
-        add ~field:"avail-languages" Headers.avail_languages_header_value
-      in
           let* () =
             let content_type = Fmt.str "%a" Assets.Mimetype.pp mime in
             add ~field:"content-type" content_type
           in
-      respond `OK
+          respond `OK)
 
 let terms req _server _env =
   Logs.info (fun m -> m "GET /terms");