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