From 0bf635a3fe6a4abab51df99d82e3dc92d5e489ad Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Fri, 27 Dec 2024 19:47:32 +0100 Subject: [PATCH] use prelude --- .ocamlformat | 2 +- example/dune | 2 +- example/main.ml | 3 +-- src/cookie.ml | 11 +++++------ src/dune | 5 ++++- src/form.ml | 7 ++++++- src/html_doc.ml | 3 +-- src/mimetype.ml | 4 ++-- src/mimetype.mli | 2 +- src/request.ml | 12 +++++------- src/route.ml | 8 +++----- src/route.mli | 2 +- src/server.ml | 17 ++++++++--------- src/session.ml | 12 ++++++------ src/session.mli | 2 +- 15 files changed, 46 insertions(+), 46 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index f146225..c365faf 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.26.2 +version=0.27.0 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/example/dune b/example/dune index bf7da88..c82299b 100644 --- a/example/dune +++ b/example/dune @@ -1,4 +1,4 @@ (executable (name main) (modules main) - (libraries drame scfg)) + (libraries drame prelude scfg)) diff --git a/example/main.ml b/example/main.ml index 27861b4..0b2f3f2 100644 --- a/example/main.ml +++ b/example/main.ml @@ -16,8 +16,7 @@ let template_html (_request : Request.t) ~title ~body = let styles = List.map (fun s -> - link ~rel:[ `Stylesheet ] ~href:(Format.sprintf "/assets/css/%s" s) () - ) + link ~rel:[ `Stylesheet ] ~href:(Format.sprintf "/assets/css/%s" s) () ) [ "style.css" ] in let head = head (Html.title title) styles in diff --git a/src/cookie.ml b/src/cookie.ml index 247195a..de31fbb 100644 --- a/src/cookie.ml +++ b/src/cookie.ml @@ -19,7 +19,7 @@ let get ~decrypt:_ request id = | _, true -> "__Secure-" | _, _ -> "" in - let name = Format.sprintf "%s%s" cookie_prefix id in + let name = Fmt.str "%s%s" cookie_prefix id in let cookies = all_cookies request in let v = List.find_opt (fun (name', _) -> String.equal name name') cookies in Option.map snd v @@ -28,19 +28,18 @@ let to_set_cookie ~max_age ~path name value = let max_age = match max_age with | None -> "" - | Some seconds -> Printf.sprintf "; Max-Age=%.0f" (floor seconds) + | Some seconds -> Fmt.str "; Max-Age=%.0f" (floor seconds) in let path = - match path with None -> "" | Some path -> Printf.sprintf "; Path=%s" path + match path with None -> "" | Some path -> Fmt.str "; Path=%s" path in let secure = "; Secure" in let http_only = "; HttpOnly" in let same_site = "; SameSite=Lax" in - Printf.sprintf "%s=%s%s%s%s%s%s" name value max_age path secure http_only - same_site + Fmt.str "%s=%s%s%s%s%s%s" name value max_age path secure http_only same_site let make_set_headers ~encrypt:(_ : bool) ~max_age ~key ~value = let path = Some "/" in @@ -51,7 +50,7 @@ let make_set_headers ~encrypt:(_ : bool) ~max_age ~key ~value = | _, true -> "__Secure-" | _, _ -> "" in - let name = Format.sprintf "%s%s" cookie_prefix key in + let name = Fmt.str "%s%s" cookie_prefix key in let set_cookie = to_set_cookie ~max_age ~path name value in [ ("Set-Cookie", set_cookie) ] diff --git a/src/dune b/src/dune index c309edc..9514fc9 100644 --- a/src/dune +++ b/src/dune @@ -25,6 +25,7 @@ (re_export js_of_ocaml-compiler) miou miou.unix + prelude ptime ptime.clock.os (re_export scfg) @@ -33,4 +34,6 @@ htmlit unix uri - uuidm)) + uuidm) + (flags + (:standard -open Prelude))) diff --git a/src/form.ml b/src/form.ml index 78686bd..e764d4d 100644 --- a/src/form.ml +++ b/src/form.ml @@ -9,5 +9,10 @@ let form request = let form = List.map (fun (name, values) -> (name, String.concat "," values)) query in - Ok (List.sort compare form) + Ok + (List.sort + (fun (name1, values1) (name2, values2) -> + let cmp_names = String.compare name1 name2 in + if cmp_names = 0 then String.compare values1 values2 else cmp_names ) + form ) | _content_type -> Error "wrong content type" ) diff --git a/src/html_doc.ml b/src/html_doc.ml index 3d947df..3059671 100644 --- a/src/html_doc.ml +++ b/src/html_doc.ml @@ -4,7 +4,6 @@ let to_string = Fun.id let of_tyxml doc = let indent = false in - let content = Format.asprintf "%a@\n" (Tyxml.Html.pp ~indent ()) doc in - content + Fmt.str "%a@\n" (Tyxml.Html.pp ~indent ()) doc let of_htmlit doc = Htmlit.El.to_string ~doctype:true doc diff --git a/src/mimetype.ml b/src/mimetype.ml index 668c737..13ae549 100644 --- a/src/mimetype.ml +++ b/src/mimetype.ml @@ -32,7 +32,7 @@ type t = | Video_webm let pp fmt mimetype = - Format.pp_print_string fmt + Fmt.string fmt ( match mimetype with | Audio_aac -> "audio/aac" | Audio_midi -> "audio/midi" @@ -68,4 +68,4 @@ let pp fmt mimetype = | Video_mp4 -> "video/mp4" | Video_webm -> "video/webm" ) -let to_string mimetype = Format.asprintf "%a" pp mimetype +let to_string mimetype = Fmt.str "%a" pp mimetype diff --git a/src/mimetype.mli b/src/mimetype.mli index 47f928c..932dc71 100644 --- a/src/mimetype.mli +++ b/src/mimetype.mli @@ -32,6 +32,6 @@ type t = | Video_mp4 | Video_webm -val pp : Format.formatter -> t -> unit +val pp : Fmt.formatter -> t -> unit val to_string : t -> string diff --git a/src/request.ml b/src/request.ml index 7338452..924d9fa 100644 --- a/src/request.ml +++ b/src/request.ml @@ -10,13 +10,11 @@ type t = ; get_body : unit -> string } -let pp_comma fmt () = Format.pp_print_char fmt ',' +let pp_comma fmt () = Fmt.char fmt ',' -let pp_comma_sep_string_list = - Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string +let pp_comma_sep_string_list = Fmt.list ~sep:pp_comma Fmt.string -let query_values_to_string query = - Format.asprintf "%a" pp_comma_sep_string_list query +let query_values_to_string query = Fmt.str "%a" pp_comma_sep_string_list query let query { query; _ } name : string option = let query = List.assoc_opt name query in @@ -85,11 +83,11 @@ let get_body reqd = | `V1 reqd -> let body_reader = H1.Reqd.request_body reqd in aux (H1.Body.Reader.schedule_read body_reader) (fun () -> - H1.Body.Reader.close body_reader ) + H1.Body.Reader.close body_reader ) | `V2 reqd -> let body_reader = H2.Reqd.request_body reqd in aux (H2.Body.Reader.schedule_read body_reader) (fun () -> - H2.Body.Reader.close body_reader ) + H2.Body.Reader.close body_reader ) let of_reqd reqd = let { Httpcats.Server.target; meth; headers; _ } = diff --git a/src/route.ml b/src/route.ml index bae779e..759de4a 100644 --- a/src/route.ml +++ b/src/route.ml @@ -1,13 +1,11 @@ type t = string array let pp fmt route = - Format.fprintf fmt "/%a" - (Format.pp_print_array - ~pp_sep:(fun fmt () -> Format.pp_print_char fmt '/') - Format.pp_print_string ) + Fmt.pf fmt "/%a" + (Fmt.array ~sep:(fun fmt () -> Fmt.char fmt '/') Fmt.string) route let of_string s = let ss = String.split_on_char '/' s in - let ss = List.filter (fun s -> s <> "") ss in + let ss = List.filter (fun s -> not (String.equal "" s)) ss in Array.of_list ss diff --git a/src/route.mli b/src/route.mli index 8bd415d..be95008 100644 --- a/src/route.mli +++ b/src/route.mli @@ -1,5 +1,5 @@ type t = string array -val pp : Format.formatter -> t -> unit +val pp : Fmt.formatter -> t -> unit val of_string : string -> t diff --git a/src/server.ml b/src/server.ml index b4a8ec1..5efefa7 100644 --- a/src/server.ml +++ b/src/server.ml @@ -11,8 +11,7 @@ struct let force_dir d name = match d with - | None -> - Format.ksprintf failwith "can not compute %s directory path" name + | None -> Fmt.failwith "can not compute %s directory path" name | Some dir -> dir let cache_dir = force_dir cache_dir "cache" @@ -31,9 +30,9 @@ struct end let config = - let filename = Filename.concat Project.config_dir "config.scfg" in - match Scfg.Parse.from_file filename with - | (exception Sys_error msg) | Error msg -> failwith msg + let filename = Fpath.(v Project.config_dir / "config.scfg") in + match Scfg.Parse.from_file (Fpath.to_string filename) with + | (exception Sys_error msg) | Error msg -> Fmt.failwith "%s" msg | Ok config -> config open Scfg.Query @@ -41,10 +40,10 @@ struct let port = let directive = get_dir "port" config in match directive with - | None -> failwith "configuration file is missing a port directive" + | None -> Fmt.failwith "configuration file is missing a port directive" | Some directive -> ( let param = get_param_int 0 directive in - match param with Error msg -> failwith msg | Ok port -> port ) + match param with Error msg -> Fmt.failwith "%s" msg | Ok port -> port ) let listen () = let inet_addr = Unix.inet_addr_loopback in @@ -57,14 +56,14 @@ struct let content_type = Content.to_mimetype content |> Mimetype.to_string in let content = match content with - | Content.Css sheet -> Format.asprintf "%a@\n" Css.pp_string_css sheet + | Content.Css sheet -> Fmt.str "%a@\n" Css.pp_string_css sheet | Html doc -> Html_doc.to_string doc | JavaScript program -> let open Js_of_ocaml_compiler in let accept_unnamed_var = true in let buffer = Buffer.create 4096 in let pp = Pretty_print.to_buffer buffer in - let _source_map : Source_map.t option = + let _source_map : Source_map.info = Js_output.program ~accept_unnamed_var pp program in (* setting a charset is invalid for JavaScript ! *) diff --git a/src/session.ml b/src/session.ml index 6007c0b..05ebd00 100644 --- a/src/session.ml +++ b/src/session.ml @@ -142,10 +142,10 @@ let make_send_headers session = let pp fmt request = let { id; expires_at; payload } = load request in - Format.fprintf fmt "id = %a ; expires_at = %a ; payload:@\n @[" Id.pp id - Ptime.pp expires_at; - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_string fmt "@\n") - (fun fmt (k, v) -> Format.fprintf fmt "%s = %s" k v) + Fmt.pf fmt "id = %a ; expires_at = %a ; payload:@\n @[" Id.pp id Ptime.pp + expires_at; + Fmt.list + ~sep:(fun fmt () -> Fmt.string fmt "@\n") + (fun fmt (k, v) -> Fmt.pf fmt "%s = %s" k v) fmt payload; - Format.fprintf fmt "@]" + Fmt.pf fmt "@]" diff --git a/src/session.mli b/src/session.mli index d62ec1d..33abdeb 100644 --- a/src/session.mli +++ b/src/session.mli @@ -10,7 +10,7 @@ val set : Request.t -> string -> string -> unit val drop : Request.t -> string -> unit -val pp : Format.formatter -> Request.t -> unit +val pp : Fmt.formatter -> Request.t -> unit (* Internal *) val make_send_headers : t -> (string * string) list