99 lines
3.4 KiB
OCaml
99 lines
3.4 KiB
OCaml
(* MTE - the MirageOS Taler Exchange
|
|
Copyright (C) 2025 Olivier Pierre <swrup@protonmail.com>
|
|
|
|
This program is free software: you can redistribute it and/or modify
|
|
it under the terms of the GNU Affero General Public License as published by
|
|
the Free Software Foundation, either version 3 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU Affero General Public License for more details.
|
|
|
|
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/>. *)
|
|
|
|
module Assets = struct
|
|
let get path =
|
|
let path = Fpath.to_string path in
|
|
match Assets.read path with
|
|
| None -> Fmt.failwith "asset loading failure `%s`" path
|
|
| Some data -> data
|
|
end
|
|
|
|
let static _kind req _server _env =
|
|
let open Vif.Response.Syntax in
|
|
let headers = Vif.Request.headers req in
|
|
let media_l =
|
|
let accept = Vif.Headers.get headers "accept" in
|
|
Cohttp.Accept.media_ranges accept
|
|
|> Cohttp.Accept.qsort
|
|
|> List.map (fun (_q, (m, _p)) -> m)
|
|
in
|
|
let accept_language_l =
|
|
let accept_language = Vif.Headers.get headers "accept-language" in
|
|
Cohttp.Accept.languages accept_language
|
|
|> Cohttp.Accept.qsort
|
|
|> List.map (fun (_q, lang) -> lang)
|
|
|>
|
|
(* ignore language subtags *)
|
|
List.map (function
|
|
| Cohttp.Accept.AnyLanguage -> "*"
|
|
| Language l -> (
|
|
match l with
|
|
| [] -> Fmt.failwith "language subtags error"
|
|
| primary_tag :: _ -> primary_tag))
|
|
in
|
|
(* todo: not sure what to do if no accept-lenguage header *)
|
|
assert (List.length accept_language_l > 0);
|
|
(* find an approriate extension + supported lang_l *)
|
|
let opt =
|
|
media_l
|
|
|> List.find_map (fun media ->
|
|
match media with
|
|
| Cohttp.Accept.MediaType (m, m_sub) ->
|
|
List.assoc_opt (m, m_sub) Config.terms_assoc
|
|
| AnyMediaSubtype m ->
|
|
List.find_opt
|
|
(fun ((mm, _), _) -> String.equal m mm)
|
|
Config.terms_assoc
|
|
|> Option.map snd
|
|
| AnyMedia -> List.nth_opt Config.terms_assoc 0 |> Option.map snd)
|
|
in
|
|
let lang, ext =
|
|
match opt with
|
|
| None ->
|
|
(* todo respond with smthing approriate *)
|
|
Fmt.failwith "usuported mimetype"
|
|
| Some (ext, lang_l) -> (
|
|
(* pick best language to use *)
|
|
match Config.preferred_lang ~supported:lang_l accept_language_l with
|
|
| None ->
|
|
(* todo respond with smthing approriate *)
|
|
Fmt.failwith "usuported accepted language"
|
|
| Some lang -> (lang, ext))
|
|
in
|
|
(* todo add headers ... *)
|
|
let data =
|
|
Assets.get @@ Fpath.((Config.terms_dir / lang / Config.terms_etag) + ext)
|
|
in
|
|
let* () = Vif.Response.with_string ~compression:`Gzip req data in
|
|
let field = "content-type" in
|
|
let* () = Vif.Response.add ~field "html; charset=utf-8" in
|
|
Vif.Response.respond `OK
|
|
|
|
let routes =
|
|
let open Vif.Uri in
|
|
let open Vif.Route in
|
|
(*let open Vif.Type in*)
|
|
[
|
|
get (rel / "terms" /?? nil) --> static `Terms
|
|
; get (rel / "privacy" /?? nil) --> static `Privacy
|
|
]
|
|
|
|
let () =
|
|
Miou_unix.run @@ fun () ->
|
|
let env = () in
|
|
let middlewares = Vif.Middlewares.[] in
|
|
Vif.run ~middlewares routes env
|