mte/src/static.ml

(* /terms + /privacy *)

(* TODO response *)
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 err = ErrorDetail.make ?hint code in
      let s = encode_exn ErrorDetail.jsont err in
      Logs.err (fun m -> m "ErrorDetail: `%s`" s);
      s
  end

  let bad_request ?hint req =
    let body = error_detail ?hint `Bad_request in
    let* () = add ~field:"content-type" "application/json" in
    let* () = with_string ?compression:None req body in
    respond `Bad_request

  let not_modified () =
    let* () = empty in
    respond `Not_modified
end

let aux asset req _server _env =
  let etag = Assets.etag asset 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 ->
        Result.map (Headers_lib.Etag.evaluate etag) (Headers_lib.Etag.parse s)
  in
  match has_matching_etag with
  | Error e ->
      Logs.err (fun m -> m "bad request");
      Respond_with.bad_request ~hint:e req
  | Ok true ->
      Logs.err (fun m -> m "not modified");
      Respond_with.not_modified ()
  | Ok false ->
      let mime = Headers.select_mimetype headers in
      let lang = Headers.select_language headers in
      let compression = Headers.select_encoding headers in
      let data = Assets.get_content ~mime ~lang asset 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.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

let terms req _server _env =
  Logs.info (fun m -> m "GET /terms");
  aux Assets.Terms req _server _env

let privacy req _server _env =
  Logs.info (fun m -> m "GET /privacy");
  aux Assets.Privacy req _server _env