diff --git a/src/config.ml b/src/config.ml index 31e1fa72..2464f1a6 100644 --- a/src/config.ml +++ b/src/config.ml @@ -10,9 +10,76 @@ let supported_languages = [| "en"; "fr" |] (* let supported_extensions = - [| "html"; "htm"; "txt"; "pdf"; "jpg"; "jpeg"; "png"; "gif" |] + [ "html"; "htm"; "txt"; "pdf"; "jpg"; "jpeg"; "png"; "gif" ] *) -(* todo - terms_matrix: - ext X lang *) +let supported_extensions_mimetype_assoc = + [ + ("txt", ("text", "plain")); ("html", ("text", "html")) + ; ("htm", ("text", "html")); ("pdf", ("application", "pdf")) + ; ("jpg", ("image", "jpeg")); ("jpeg", ("image", "jpeg")) + ; ("png", ("image", "png")); ("gif", ("image", "gif")) + ] + +let terms_assoc, privacy_assoc = + let open Syntax in + let get_ok res = + match res with + | Error (`Msg s) -> Fmt.failwith "static file error: `%s`" s + | Ok l -> l + in + let l = Assets.file_list in + List.iter (Fmt.pr "file: %s@.") l; + let l = get_ok (list_map (fun s -> Fpath.of_string s) l) in + let () = + (* check that Assets only contains supported extensions *) + let supported_extensions, _ = + List.split supported_extensions_mimetype_assoc + in + get_ok + @@ list_iter + (fun file -> + match Fpath.mem_ext supported_extensions file with + | true -> Ok () + | false -> + Fmt.error_msg "Assets contains ussuported file `%s`" + (Fpath.to_string file)) + l + in + let mk base_dir = + let file_l = + List.filter_map (fun file -> Fpath.rem_prefix base_dir file) l + in + List.fold_left + (fun acc (ext, mime) -> + let lang_l = + List.filter (Fpath.has_ext ext) file_l + |> List.map Fpath.split_base + |> List.map fst + |> List.map Fpath.to_string + in + if List.is_empty lang_l then acc else (mime, (ext, lang_l)) :: acc) + [] supported_extensions_mimetype_assoc + in + let terms_assoc = mk terms_dir in + let privacy_assoc = mk privacy_dir in + (terms_assoc, privacy_assoc) + +(* TODO rewrite as one find_opt *) +(* assumes l ordered by preferrence *) +(* O(n^2) ok because supported length is small *) +let preferred_lang ~supported l = + assert (List.length supported > 0); + assert (List.length l > 0); + let default_lang = List.nth supported 0 in + let l = + List.map (fun s -> if String.equal s "*" then default_lang else s) l + in + let l = List.filter (fun s -> List.mem s supported) l in + List.nth_opt l 0 + +(* + get_terms accept accept_language = + | ok v + | error: `No_mime | `No_lang | `Bad_headers? + *) diff --git a/src/dune b/src/dune index 78b22c32..397a7942 100644 --- a/src/dune +++ b/src/dune @@ -1,8 +1,8 @@ (executable (public_name mte) (name mte) - (modules assets mte config) - (libraries vif fmt jsont)) + (modules assets mte config syntax) + (libraries vif fmt jsont cohttp)) (rule (target assets.ml) diff --git a/src/mte.ml b/src/mte.ml index 74d7cd63..a0a6b262 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -4,35 +4,64 @@ module Assets = struct match Assets.read path with | None -> Fmt.failwith "asset loading failure `%s`" path | Some data -> data - - let terms = - get Fpath.((Config.terms_dir / "en" / Config.terms_etag) + ".html") - - let privacy = - get Fpath.((Config.privacy_dir / "en" / Config.privacy_etag) + ".html") end -let static kind req _server _env = +let static _kind req _server _env = let open Vif.Response.Syntax in - let extension = .. in - if not @@ extension is supported then - error mimetype not supported - else - - let base_dir, etag = - let open Config in - match kind with - | `Terms -> terms_dir, terms_etag - | `Privacy -> privacy_dir, privacy_etag + 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 accepted_lang_l = .. in - - - (* add headers ... *) - - - 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 @@ -43,8 +72,8 @@ let routes = let open Vif.Route in (*let open Vif.Type in*) [ - get (rel / "terms" /?? nil) --> static Assets.terms - ; get (rel / "privacy" /?? nil) --> static Assets.privacy + get (rel / "terms" /?? nil) --> static `Terms + ; get (rel / "privacy" /?? nil) --> static `Privacy ] let () = diff --git a/src/syntax.ml b/src/syntax.ml new file mode 100644 index 00000000..53b7cb66 --- /dev/null +++ b/src/syntax.ml @@ -0,0 +1,37 @@ +let ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e +let ( let+ ) o f = match o with Ok v -> Ok (f v) | Error _ as e -> e + +let list_iter f l = + let err = ref None in + try + List.iter + (fun v -> + match f v with + | Error _e as e -> + err := Some e; + raise Exit + | Ok () -> ()) + l; + Ok () + with Exit -> ( match !err with None -> assert false | Some v -> v) + +let list_map f l = + let err = ref None in + try + Ok + (List.map + (fun v -> + match f v with + | Error _e as e -> + err := Some e; + raise Exit + | Ok v -> v) + l) + with Exit -> ( match !err with None -> assert false | Some v -> v) + +let list_fold_left f acc l = + List.fold_left + (fun acc v -> + let* acc = acc in + f acc v) + (Ok acc) l