From 25f3578bd920906bab3150a984f786831d409510 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Fri, 3 Jan 2025 20:49:15 +0100 Subject: [PATCH] use prelude --- src/app.ml | 18 ++++++---- src/dune | 2 ++ src/jb.ml | 87 +++++++++++++++++++++++++++++-------------------- src/lang.ml | 4 +-- src/projects.ml | 12 ++++--- src/set_lang.ml | 3 +- src/sitemap.ml | 12 +++---- src/slider.ml | 9 ++--- src/template.ml | 17 +++++----- 9 files changed, 92 insertions(+), 72 deletions(-) diff --git a/src/app.ml b/src/app.ml index d65cd1a..f8cf454 100644 --- a/src/app.ml +++ b/src/app.ml @@ -10,15 +10,20 @@ include Drame.Server.Make (App_id) let path_to_images = match Scfg.Query.get_dir "path_to_images" config with - | None -> failwith "missing path_to_images in configuration" - | Some dir -> Scfg.Query.get_param_exn 0 dir + | None -> Fmt.failwith "missing path_to_images in configuration" + | Some dir -> ( + match Fpath.of_string @@ Scfg.Query.get_param_exn 0 dir with + | Error (`Msg s) -> Fmt.failwith "%s" s + | Ok v -> v ) (* check existence of image files at startup *) let () = let f_s s = - let file = Filename.concat path_to_images s in - if not @@ Sys.file_exists file then - failwith (Format.sprintf "Image file: %s not found." s) + let file = Fpath.(path_to_images / s) in + match Bos.OS.File.exists file with + | Error (`Msg s) -> Fmt.failwith "%s" s + | Ok false -> Fmt.failwith "Image file: %s not found." s + | Ok true -> () in let f img = f_s img.Lang.name in (* projects *) @@ -26,8 +31,7 @@ let () = (fun Projects.{ home_logo; main_img; more_img; _ } -> f main_img; Option.iter f home_logo; - List.iter f more_img; - () ) + List.iter f more_img ) Projects.projects; (* services *) List.iter diff --git a/src/dune b/src/dune index 3142f2f..9cb701c 100644 --- a/src/dune +++ b/src/dune @@ -17,6 +17,8 @@ sitemap slider template) + (flags + (:standard -open Prelude)) (libraries prelude scfg drame)) (rule diff --git a/src/jb.ml b/src/jb.ml index ef782c0..446a36b 100644 --- a/src/jb.ml +++ b/src/jb.ml @@ -4,56 +4,54 @@ open Lang let get_img = let forbidden_characters = let tbl = Hashtbl.create 16 in - Array.iter (fun c -> Hashtbl.add tbl c ()) [| '.'; '/'; '\\' |]; + Array.iter (fun c -> Hashtbl.replace tbl c ()) [| '.'; '/'; '\\' |]; tbl in let allowed_extensions = let tbl = Hashtbl.create 16 in - Array.iter (fun e -> Hashtbl.add tbl e ()) [| ".jpeg"; ".png"; ".gif" |]; + Array.iter (fun e -> Hashtbl.replace tbl e ()) [| ".jpeg"; ".png"; ".gif" |]; tbl in - fun ~filename request -> - let extension = Filename.extension filename in - let without_extension = Filename.chop_extension filename in + fun ~fname request -> + let without_extension, extension = Fpath.split_ext fname in if - String.exists (Hashtbl.mem forbidden_characters) without_extension + String.exists + (Hashtbl.mem forbidden_characters) + (Fpath.to_string without_extension) || (not @@ Hashtbl.mem allowed_extensions extension) then - let fr = Format.sprintf "Nom de fichier invalide: %s." filename in - let en = Format.sprintf "Invalid filename: %s." filename in + let fr = Fmt.str "Nom de fichier invalide: %a." Fpath.pp fname in + let en = Fmt.str "Invalid filename: %a." Fpath.pp fname in let h1 = { en = "Bad request"; fr = "Requête invalid" } in let doc = Template.render request ~h1 (Lang.txt request ~en ~fr) in Error (Status.Bad_request, doc) else - let path = Filename.concat App.path_to_images filename in - let chan = open_in_bin path in - let len = in_channel_length chan in - let s = Bytes.create len in - Fun.protect - ~finally:(fun () -> close_in chan) - (fun () -> - assert (len <= Sys.max_string_length); - really_input chan s 0 len ); - let content = Bytes.unsafe_to_string s in - let mimetype = - match extension with - | ".jpeg" -> Mimetype.Image_jpeg - | ".png" -> Mimetype.Image_png - | ".gif" -> Mimetype.Image_gif - | _ -> assert false - in - Ok (Content.Unsafe { content; mimetype }) + let path = Fpath.(App.path_to_images // fname) in + match Bos.OS.File.read path with + | Error (`Msg e) -> + let h1 = { en = e; fr = e } in + let doc = Template.render request ~h1 (Lang.txt_anylang e) in + Error (Status.Internal_server_error, doc) + | Ok content -> + let mimetype = + match extension with + | ".jpeg" -> Mimetype.Image_jpeg + | ".png" -> Mimetype.Image_png + | ".gif" -> Mimetype.Image_gif + | _ -> assert false + in + Ok (Content.Unsafe { content; mimetype }) let get_asset ~filename request = - match Assets.read filename with + match Assets.read (Fpath.to_string filename) with | None -> - let fr = Format.sprintf "Nom de fichier invalide: %s." filename in - let en = Format.sprintf "Invalid filename: %s." filename in + let fr = Fmt.str "Nom de fichier invalide: %a." Fpath.pp filename in + let en = Fmt.str "Invalid filename: %a." Fpath.pp filename in let h1 = { fr = "Requête invalide"; en = "Bad request" } in let doc = Template.render request ~h1 (Lang.txt request ~en ~fr) in Error (Status.Bad_request, doc) | Some content -> ( - let extension = Filename.extension filename in + let extension = Fpath.get_ext filename in match extension with | ".css" -> Ok (Content.Unsafe { mimetype = Mimetype.Text_css; content }) | ".ttf" -> Ok (Content.Unsafe { mimetype = Mimetype.Font_ttf; content }) @@ -70,11 +68,30 @@ let get_favicon request = let handler = function | [||] -> Home.get - | [| "assets"; "css"; filename |] -> - get_asset ~filename:(Format.sprintf "css/%s" filename) - | [| "assets"; "fonts"; filename |] -> - get_asset ~filename:(Format.sprintf "fonts/%s" filename) - | [| "assets"; "img"; filename |] -> get_img ~filename + | [| "assets"; "css"; fname |] -> ( + fun request -> + match Fpath.of_string fname with + | Error (`Msg e) -> + let h1 = { en = e; fr = e } in + let doc = Template.render request ~h1 (Lang.txt_anylang e) in + Error (Status.Internal_server_error, doc) + | Ok fname -> get_asset request ~filename:Fpath.(v "css" // fname) ) + | [| "assets"; "fonts"; fname |] -> ( + fun request -> + match Fpath.of_string fname with + | Error (`Msg e) -> + let h1 = { en = e; fr = e } in + let doc = Template.render request ~h1 (Lang.txt_anylang e) in + Error (Status.Internal_server_error, doc) + | Ok fname -> get_asset request ~filename:Fpath.(v "fonts" // fname) ) + | [| "assets"; "img"; fname |] -> ( + fun request -> + match Fpath.of_string fname with + | Error (`Msg e) -> + let h1 = { en = e; fr = e } in + let doc = Template.render request ~h1 (Lang.txt_anylang e) in + Error (Status.Internal_server_error, doc) + | Ok fname -> get_img request ~fname ) | [| "favicon.ico" |] -> get_favicon | [| "about" |] -> About.get | [| "contact" |] -> Contact.get diff --git a/src/lang.ml b/src/lang.ml index ceca1f6..c22d8c8 100644 --- a/src/lang.ml +++ b/src/lang.ml @@ -19,8 +19,8 @@ let default = French let session_param_name = "lang" let pp fmt = function - | French -> Format.pp_print_string fmt "fr" - | English -> Format.pp_print_string fmt "en" + | French -> Fmt.string fmt "fr" + | English -> Fmt.string fmt "en" let of_string = function | "fr" -> Some French diff --git a/src/projects.ml b/src/projects.ml index 3e65fa5..01cd358 100644 --- a/src/projects.ml +++ b/src/projects.ml @@ -58,12 +58,12 @@ let of_dir dir = let projects = let cfg = match Data.read "projects.scfg" with - | None -> failwith "can't load projects" + | None -> Fmt.failwith "can't load projects" | Some projects -> Scfg.Parse.from_string projects in let dirs = match cfg with - | Error (`Msg msg) -> failwith msg + | Error (`Msg msg) -> Fmt.failwith "%s" msg | Ok dirs -> get_dirs "project" dirs in let dirs = @@ -106,7 +106,7 @@ let get request = ; txt_choice request localisation ; txt_anylang "" ; br () - ; Format.ksprintf txt_anylang "%d" year + ; Fmt.kstr txt_anylang "%d" year ] ) ) [ Lang.img request ~a:[] ~src:(Sitemap.img main_img.name) @@ -124,7 +124,9 @@ let get request = Ok (Content.Html doc) let get_one ~id request = - let project = List.find_opt (fun { url_id; _ } -> url_id = id) projects in + let project = + List.find (fun { url_id; _ } -> String.equal url_id id) projects + in match project with | None -> let content = @@ -170,7 +172,7 @@ let get_one ~id request = [ txt_choice request kind ] ; h3 ~a:[ a_class [ "project-one-subtitle" ] ] - [ Format.ksprintf txt_anylang "%d" year ] + [ Fmt.kstr txt_anylang "%d" year ] ; p ~a: [ a_class diff --git a/src/set_lang.ml b/src/set_lang.ml index 60d062a..8144d65 100644 --- a/src/set_lang.ml +++ b/src/set_lang.ml @@ -2,8 +2,7 @@ open Drame open Lang let set_session request lang = - Session.set request Lang.session_param_name - (Format.asprintf "%a" Lang.pp lang) + Session.set request Lang.session_param_name (Fmt.str "%a" Lang.pp lang) let to_value lang request = set_session request lang; diff --git a/src/sitemap.ml b/src/sitemap.ml index de0e666..f51b498 100644 --- a/src/sitemap.ml +++ b/src/sitemap.ml @@ -1,8 +1,8 @@ -let img name = Format.sprintf "/assets/img/%s" name +let img name = Fmt.str "/assets/img/%s" name -let script name = Format.sprintf "/assets/js/%s" name +let script name = Fmt.str "/assets/js/%s" name -let style name = Format.sprintf "/assets/css/%s" name +let style name = Fmt.str "/assets/css/%s" name let me = img "me.png" @@ -16,7 +16,7 @@ let home = "/" let projects = "/projects" -let projects_one name = Format.sprintf "/projects/%s" name +let projects_one name = Fmt.str "/projects/%s" name let services = "/services" @@ -24,9 +24,9 @@ let services = "/services" let set_lang lang current_page = match current_page with - | None -> Format.asprintf "/lang/%a" Lang.pp lang + | None -> Fmt.str "/lang/%a" Lang.pp lang | Some current_page -> - Format.asprintf "/lang/%a?redirect=%s" Lang.pp lang current_page + Fmt.str "/lang/%a?redirect=%s" Lang.pp lang current_page let set_english = set_lang Lang.English diff --git a/src/slider.ml b/src/slider.ml index c1bf3d3..a7b29f9 100644 --- a/src/slider.ml +++ b/src/slider.ml @@ -11,10 +11,7 @@ let make request ~is_home (vs : input list) = List.mapi (fun i _p -> let a = - [ a_input_type `Radio - ; a_name "slides" - ; a_id (Format.sprintf "slides-%d" i) - ] + [ a_input_type `Radio; a_name "slides"; a_id (Fmt.str "slides-%d" i) ] in let a = if i = 0 then a_checked () :: a else a in input ~a () ) @@ -36,7 +33,7 @@ let make request ~is_home (vs : input list) = in let slides_labels = List.mapi - (fun i _v -> label ~a:[ a_label_for (Format.sprintf "slides-%d" i) ] []) + (fun i _v -> label ~a:[ a_label_for (Fmt.str "slides-%d" i) ] []) vs in let slides_arrows = @@ -44,7 +41,7 @@ let make request ~is_home (vs : input list) = @ [ label ~a:[ a_label_for "slides-0"; a_class [ "goto-first" ] ] [] ; label ~a: - [ a_label_for (Format.sprintf "slides_%d" (List.length vs - 1)) + [ a_label_for (Fmt.str "slides_%d" (List.length vs - 1)) ; a_class [ "goto-last" ] ] [] diff --git a/src/template.ml b/src/template.ml index 0be9191..b61602a 100644 --- a/src/template.ml +++ b/src/template.ml @@ -7,13 +7,12 @@ let simple_ul l = ul (List.map (fun o -> li [ o ]) l) let mk_nav_a request page ~en ~fr = let is_current_page = - let current_route = - request.Request.route |> Format.asprintf "%a" Route.pp - in + let current_route = request.Request.route |> Fmt.str "%a" Route.pp in (* TODO improve this/make "breadcrumb navigation" *) (* this is to mark the link in the nav as .current even if we are in a sub-page *) - current_route = page - || (Array.length request.route > 0 && "/" ^ request.route.(0) = page) + String.equal current_route page + || Array.length request.route > 0 + && String.equal (Fmt.str "/%s" request.route.(0)) page in let a_class = a_class (if is_current_page then [ "current" ] else []) in a ~a:(a_class :: [ a_href page ]) [ txt request ~fr ~en ] @@ -26,8 +25,8 @@ let render request ?title:title_txt ?(scripts = []) ?(styles = []) ~h1 content = ; fr = "Joanna Barreiro - Architecte" } ~some:(fun { en; fr } -> - { en = Format.sprintf "%s - Joanna Barreiro - Architect" en - ; fr = Format.sprintf "%s - Joanna Barreiro - Architecte" fr + { en = Fmt.str "%s - Joanna Barreiro - Architect" en + ; fr = Fmt.str "%s - Joanna Barreiro - Architecte" fr } ) title_txt in @@ -85,7 +84,7 @@ let render request ?title:title_txt ?(scripts = []) ?(styles = []) ~h1 content = (title (txt_choice request title_txt)) (favicon @ meta @ styles @ scripts) in - let current_page = Some (request.route |> Format.asprintf "%a" Route.pp) in + let current_page = Some (request.route |> Fmt.str "%a" Route.pp) in let lang_choice = let href = ( match Lang.of_request request with @@ -144,7 +143,7 @@ let render request ?title:title_txt ?(scripts = []) ?(styles = []) ~h1 content = ] in - let lang = Format.asprintf "%a" Lang.pp (Lang.of_request request) in + let lang = Fmt.str "%a" Lang.pp (Lang.of_request request) in let doc = html