+ wip content negotation

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?
+   *)

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)

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 () =

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