From 221f6340a809b3e1c4a86cdbabd93dd5d048bbf7 Mon Sep 17 00:00:00 2001 From: swrup Date: Sun, 30 Nov 2025 03:33:25 +0100 Subject: [PATCH] --- src/mte.ml | 84 --------------------------------------------------- src/static.ml | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+), 84 deletions(-) create mode 100644 src/static.ml diff --git a/src/mte.ml b/src/mte.ml index 7870e038..328fcb5d 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -13,90 +13,6 @@ You should have received a copy of the GNU Affero General Public License along with this program. If not, see . *) -let error_detail ?hint _status = - let open Api in - let code = -1 in - let s = encode_exn ErrorDetail.jsont { code; hint } in - s - -module Respond_with = struct - open Vif.Response - open Syntax - - let bad_request ?hint req = - let body = error_detail ?hint `Bad_request in - let* () = with_string ?compression:None req body in - respond `Bad_request - - 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 - - pick the version in the most preferred language of the user - - apply compression if that is allowed by the client - - set ETAG header - - If it did not change, a "304 Not Modified" response will be returned - - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms - - 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 f kind req _server _env = - let etag = Assets.etag kind in - let headers = Vif.Request.headers req in - let has_matching_etag = - match Vif.Headers.get headers "if-none-match" with - | None -> Ok false - | Some s -> - Headers_lib.Etag.parse s - |> Result.map (Headers_lib.Etag.evaluate etag) - in - match has_matching_etag with - | Error e -> Respond_with.bad_request ~hint:e req - | Ok true -> Respond_with.not_modified () - | Ok 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" Assets.terms_legal_version - in - let* () = - add ~field:"avail-languages" Headers.avail_languages_header_value - in - let* () = - let content_type = Fmt.str "%a" Assets.Mimetype.pp_mime mime in - add ~field:"content-type" content_type - in - respond `OK) - - let terms = f Assets.Terms - let privacy = f Assets.Privacy -end - let hello req _server _env = let open Vif.Response in let open Syntax in diff --git a/src/static.ml b/src/static.ml new file mode 100644 index 00000000..a69d2dc0 --- /dev/null +++ b/src/static.ml @@ -0,0 +1,83 @@ +(* TODO check for mathcing ETAG with a middleware instead? *) +(* /terms + /privacy + - try to find a response with an acceptable mime-type + - pick the version in the most preferred language of the user + - apply compression if that is allowed by the client + - set ETAG header + - If it did not change, a "304 Not Modified" response will be returned + - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms + - When returning a full response (not a "304 Not Modified"), + include a "Avail-Languages" header: a comma-separated list of the languages available *) + +module Respond_with = struct + open Vif.Response + open Syntax + + open struct + let error_detail ?hint _status = + let open Api in + let code = -1 in + let s = encode_exn ErrorDetail.jsont { code; hint } in + s + end + + let bad_request ?hint req = + let body = error_detail ?hint `Bad_request in + let* () = with_string ?compression:None req body in + respond `Bad_request + + 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 + +let aux kind req _server _env = + let etag = Assets.etag kind in + let headers = Vif.Request.headers req in + let has_matching_etag = + match Vif.Headers.get headers "if-none-match" with + | None -> Ok false + | Some s -> + Headers_lib.Etag.parse s |> Result.map (Headers_lib.Etag.evaluate etag) + in + match has_matching_etag with + | Error e -> Respond_with.bad_request ~hint:e req + | Ok true -> Respond_with.not_modified () + | Ok 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" Assets.terms_legal_version + in + let* () = + add ~field:"avail-languages" Headers.avail_languages_header_value + in + let* () = + let content_type = Fmt.str "%a" Assets.Mimetype.pp_mime mime in + add ~field:"content-type" content_type + in + respond `OK) + +let terms req _server _env = aux Assets.Terms req _server _env +let privacy req _server _env = aux Assets.Privacy req _server _env