diff --git a/src/assets.ml b/src/assets.ml index 3c8676ff..3fff233c 100644 --- a/src/assets.ml +++ b/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 diff --git a/src/headers.ml b/src/headers.ml index 4e10975d..5ae0c4a7 100644 --- a/src/headers.ml +++ b/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" diff --git a/src/mte.ml b/src/mte.ml index b1c6c913..79ecd9c5 100644 --- a/src/mte.ml +++ b/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 . *) +(* 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 - 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* () = - let etag_field_value = Headers_lib.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" - Config.terms_legal_version - in - let* () = - Vif.Response.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 - in - Vif.Response.respond `OK + | 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 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 + add ~field:"etag" etag_field_value + in + let* () = + (* todo: is it "taler-privacy-version" for /policy ? *) + add ~field:"taler-terms-version" Config.terms_legal_version + in + let* () = + add ~field:"avail-languages" Headers.avail_languages_header_value + in + let* () = + let content_type = Fmt.str "%a" Util.pp_mime mime in + add ~field:"content-type" content_type + in + 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 diff --git a/src/util.ml b/src/util.ml index a82fd35f..d3be0ab5 100644 --- a/src/util.ml +++ b/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