wip basic error response

src/assets.ml

@@ -100,6 +100,9 @@ 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
 
+(* todo
+  - put content in a matrix instead?
+  - better types to force valid params? *)
 (* ! lang and mime must be supported *)
 let get_content ~lang ~mime t =
   let etag = Headers_lib.Etag.to_raw_string (etag t) in

src/headers.ml

@@ -1,6 +1,9 @@
+let accept_header_value =
+  let s = Fmt.str "%a" Util.(pp_array pp_mime) Assets.supported_mimetype_arr in
+  s
+
 let avail_languages_header_value =
-  let pp_array = Fmt.array ~sep:(Fmt.any ", ") Fmt.string in
-  let s = Fmt.str "%a" pp_array Assets.supported_lang_arr in
+  let s = Fmt.str "%a" (Util.pp_array Fmt.string) Assets.supported_lang_arr in
   s
 
 let select_mimetype headers =
@@ -9,7 +12,6 @@ let select_mimetype headers =
   |> Cohttp.Accept.qsort
   |> 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
@@ -24,7 +26,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"
+  |> Option.value ~default:Config.default_lang
 
 let select_encoding headers =
   Vif.Headers.get headers "accept-encoding"

src/mte.ml

@@ -13,6 +13,29 @@
     You should have received a copy of the GNU Affero General Public License
     along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
 
+(* TODO *)
+(* https://docs.taler.net/core/api-common.html#tsref-type-ErrorDetail *)
+let error_detail ?hint status =
+  let _ = (hint, status) in
+  "{}"
+
+module Respond_with = struct
+  open Vif.Response
+  open Syntax
+
+  let not_modified () =
+    let* () = empty in
+    respond `Not_modified
+
+  let unsupported_media_type req =
+    let body =
+      error_detail ~hint:"no acceptable mimetype" `Unsupported_media_type
+    in
+    let* () = with_string ?compression:None req body in
+    let* () = add ~field:"accept" Headers.accept_header_value in
+    respond `Unsupported_media_type
+end
+
 (* TODO check for mathcing ETAG with a middleware instead? *)
 (* /terms + /privacy
    - try to find a response with an acceptable mime-type
@@ -24,7 +47,7 @@
    - 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 static kind req _server _env =
+  let f kind req _server _env =
     let get_ok = function
       | Error e -> Fmt.failwith "TODO handle me, %s" e
       | Ok v -> v
@@ -38,46 +61,45 @@ module Static = struct
           Headers_lib.Etag.parse s |> get_ok |> Headers_lib.Etag.evaluate etag
     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 mime = Headers.select_mimetype headers |> get_ok in
-        let lang = Headers.select_language headers |> get_ok in
+    | true -> Respond_with.not_modified ()
+    | false -> (
+        match Headers.select_mimetype headers with
+        | None -> Respond_with.unsupported_media_type req
+        | Some mime ->
+            let lang = Headers.select_language headers 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 open Vif.Response in
+            let open Syntax in
+            let* () = with_string ?compression req data in
             let* () =
               let etag_field_value = Headers_lib.Etag.to_field_value etag in
-          Vif.Response.add ~field:"etag" etag_field_value
+              add ~field:"etag" etag_field_value
             in
             let* () =
               (* todo: is it "taler-privacy-version" for /policy ? *)
-          Vif.Response.add ~field:"taler-terms-version"
-            Config.terms_legal_version
+              add ~field:"taler-terms-version" Config.terms_legal_version
             in
             let* () =
-          Vif.Response.add ~field:"avail-languages"
-            Headers.avail_languages_header_value
+              add ~field:"avail-languages" Headers.avail_languages_header_value
             in
             let* () =
-          let content_type = Fmt.str "%s/%s" (fst mime) (snd mime) in
-          Vif.Response.add ~field:"content-type" content_type
+              let content_type = Fmt.str "%a" Util.pp_mime mime in
+              add ~field:"content-type" content_type
             in
-        Vif.Response.respond `OK
+            respond `OK)
 
-  let terms = static Assets.Terms
-  let privacy = static Assets.Privacy
+  let terms = f Assets.Terms
+  let privacy = f Assets.Privacy
 end
 
 let hello req _server _env =
-  let open Vif.Response.Syntax in
-  let* () = Vif.Response.with_string req "Hello~~\n" in
-  let* () = Vif.Response.add ~field:"content-type" "text/plain" in
-  Vif.Response.respond `OK
+  let open Vif.Response in
+  let open Syntax in
+  let* () = with_string req "Hello~~\n" in
+  let* () = add ~field:"content-type" "text/plain" in
+  respond `OK
 
 let routes =
   let open Vif.Uri in

src/util.ml

@@ -28,3 +28,7 @@ let extension_to_mimetype ext =
     (fun (mime, ext') ->
       match String.equal ext ext' with false -> None | true -> Some mime)
     mimetype_ext_assoc
+
+(* -- pretty printers -- *)
+let pp_mime fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
+let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item