zapashcanon/jb
1
0
Fork 1
Code Issues 10 Pull Requests Actions Projects Releases Wiki Activity

use prelude

Browse Source
This commit is contained in:
zapashcanon 2025-01-03 20:49:15 +01:00
parent fbb5444f21
commit 25f3578bd9
Signed by: zapashcanon
GPG Key ID: 8981C3C62D1D28F1
9 changed files with 92 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/app.ml
View File

@ -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

2
src/dune
View File

@ -17,6 +17,8 @@
sitemap
slider
template)
(flags
(:standard -open Prelude))
(libraries prelude scfg drame))
(rule

87
src/jb.ml
View File

@ -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

4
src/lang.ml
View File

@ -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

12
src/projects.ml
View File

@ -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

3
src/set_lang.ml
View File

@ -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;

12
src/sitemap.ml
View File

@ -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

9
src/slider.ml
View File

@ -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" ]
]
[]

17
src/template.ml
View File

@ -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