add assets.ml

src/mte.ml

@@ -14,82 +14,87 @@
     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 =
+module Header_util = struct
+  let parse_accept_header =
+   fun headers ->
     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 =
+    |>
+    (* TODO check that its not in reverse order *)
+    Cohttp.Accept.qsort
+    |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m)
+
+  let parse_accept_language_header headers =
     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
+    |> List.map (function
+         | Cohttp.Accept.AnyLanguage -> Config.default_lang
+         | Language language_range -> (
+             (* ignore language subtags (e.g. "en-US" -> "en") *)
+             match language_range with
+             | [] -> assert false
+             | primary_tag :: _ -> primary_tag))
+end
+
+module Static = struct
+  (* TODO handle errors:
+   - bad headers
+   - see what to do if usupported lang or ext *)
+  (* assumes accept_ext_l and accept_lang_l to be sorted by preference *)
+  let select_file ~accept_lang_l ~accept_ext_l kind =
+    let open Syntax in
+    let* () =
+      if List.is_empty accept_ext_l then Fmt.error "empty accept header"
+      else Ok ()
+    in
+    let* () =
+      if List.is_empty accept_lang_l then
+        Fmt.error "empty accept language header"
+      else Ok ()
+    in
+    let* ext =
+      accept_ext_l
+      |> List.find_opt Assets.is_supported_ext
+      |> Option.to_result ~none:"no acceptable mimetype"
+    in
+    let* lang =
+      accept_lang_l
+      |> List.find_opt Assets.is_supported_lang
+      |> Option.to_result ~none:"no acceptable language"
+    in
+    let content = Assets.get_content ~lang ~ext kind in
+    content
+
+  (* TODO add headers, handle errors etc
+   think on how to (not) mix error and vif monade well *)
+  let static kind req _server _env =
+    let open Vif.Response.Syntax in
+    let headers = Vif.Request.headers req in
+    let accept_ext_l = Header_util.parse_accept_header headers in
+    let accept_lang_l = Header_util.parse_accept_language_header headers in
+    let data =
+      match select_file ~accept_lang_l ~accept_ext_l kind with
+      | Error e -> Fmt.failwith "%s" e
+      | Ok content -> content
+    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 terms = static Assets.Terms
+  let privacy = static Assets.Privacy
+end
 
 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
+    get (rel / "terms" /?? nil) --> Static.terms
+  ; get (rel / "privacy" /?? nil) --> Static.privacy
   ]
 
 let () =