Generate srcset images for a variety of resolutions from OCaml

tidy

+247 -161
+21 -21
lib/srcsetter.ml
··· 1 1 (* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org> 2 2 3 - Permission to use, copy, modify, and/or distribute this software for 4 - any purpose with or without fee is hereby granted, provided that the 5 - above copyright notice and this permission notice appear in all 6 - copies. 3 + Permission to use, copy, modify, and/or distribute this software for 4 + any purpose with or without fee is hereby granted, provided that the 5 + above copyright notice and this permission notice appear in all 6 + copies. 7 7 8 - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 9 - WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 10 - WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 11 - AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 12 - DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 13 - OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 - TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 - PERFORMANCE OF THIS SOFTWARE. 16 - *) 8 + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 9 + WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 10 + WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 11 + AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 12 + DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 13 + OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 + TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 + PERFORMANCE OF THIS SOFTWARE. *) 17 16 18 17 module MS = Map.Make (String) 19 18 ··· 26 25 } 27 26 28 27 let v name slug origin variants dims = { name; slug; origin; variants; dims } 29 - let origin { origin; _ } = origin 30 - let slug { slug; _ } = slug 31 - let name { name; _ } = name 32 - let dims { dims; _ } = dims 33 - let variants { variants; _ } = variants 28 + let name t = t.name 29 + let slug t = t.slug 30 + let origin t = t.origin 31 + let dims t = t.dims 32 + let variants t = t.variants 34 33 34 + (** JSON codec for dimension pairs, encoded as a 2-element array. *) 35 35 let dims_json_t = 36 36 let open Jsont in 37 - let dec x y = (x, y) in 38 - let enc (w, h) = function 0 -> w | _ -> h in 37 + let dec w h = (w, h) in 38 + let enc (w, h) i = if i = 0 then w else h in 39 39 t2 ~dec ~enc uint16 40 40 41 41 let json_t = ··· 50 50 |> finish 51 51 52 52 let list = Jsont.list json_t 53 - let list_to_json es = Jsont_bytesrw.encode_string list ~format:Jsont.Indent es 53 + let list_to_json entries = Jsont_bytesrw.encode_string list ~format:Jsont.Indent entries 54 54 let list_of_json = Jsont_bytesrw.decode_string list
+56 -3
lib/srcsetter.mli
··· 1 + (** Image entry management for responsive image generation. 2 + 3 + This module provides types and functions for managing image entries 4 + that contain metadata about responsive images including their dimensions 5 + and size variants. *) 6 + 7 + (** {1 Types} *) 8 + 9 + (** String map for storing image variants keyed by filename. *) 1 10 module MS : Map.S with type key = string 2 11 12 + (** An image entry representing a source image and its generated variants. 13 + 14 + Each entry tracks: 15 + - The output filename ([name]) 16 + - A URL-safe identifier ([slug]) 17 + - The original source path ([origin]) 18 + - Image dimensions as [(width, height)] 19 + - A map of variant filenames to their dimensions *) 3 20 type t = { 4 21 name : string; 5 22 slug : string; ··· 7 24 dims : int * int; 8 25 variants : (int * int) MS.t; 9 26 } 27 + 28 + (** {1 Constructors} *) 10 29 11 30 val v : string -> string -> string -> (int * int) MS.t -> int * int -> t 31 + (** [v name slug origin variants dims] creates a new image entry. 32 + 33 + @param name The output filename (e.g., ["photo.webp"]) 34 + @param slug A URL-safe identifier derived from the filename 35 + @param origin The original source file path 36 + @param variants Map of variant filenames to their [(width, height)] dimensions 37 + @param dims The base image dimensions as [(width, height)] *) 38 + 39 + (** {1 Accessors} *) 40 + 41 + val name : t -> string 42 + (** [name entry] returns the output filename. *) 43 + 44 + val slug : t -> string 45 + (** [slug entry] returns the URL-safe identifier. *) 46 + 12 47 val origin : t -> string 13 - val name : t -> string 48 + (** [origin entry] returns the original source file path. *) 49 + 14 50 val dims : t -> int * int 51 + (** [dims entry] returns the base image dimensions as [(width, height)]. *) 52 + 15 53 val variants : t -> (int * int) MS.t 54 + (** [variants entry] returns the map of variant filenames to dimensions. *) 55 + 56 + (** {1 JSON Serialization} *) 57 + 58 + val json_t : t Jsont.t 59 + (** JSON codec for a single image entry. *) 60 + 61 + val list : t list Jsont.t 62 + (** JSON codec for a list of image entries. *) 63 + 16 64 val list_to_json : t list -> (string, string) result 65 + (** [list_to_json entries] serializes a list of entries to a JSON string. 66 + 67 + Returns [Ok json_string] on success, or [Error message] if encoding fails. *) 68 + 17 69 val list_of_json : string -> (t list, string) result 18 - val json_t : t Jsont.t 19 - val list : t list Jsont.t 70 + (** [list_of_json json_string] parses a JSON string into a list of entries. 71 + 72 + Returns [Ok entries] on success, or [Error message] if parsing fails. *)
+170 -137
lib/srcsetter_cmd.ml
··· 1 + (* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org> 2 + 3 + Permission to use, copy, modify, and/or distribute this software for 4 + any purpose with or without fee is hereby granted, provided that the 5 + above copyright notice and this permission notice appear in all 6 + copies. 7 + 8 + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 9 + WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 10 + WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 11 + AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 12 + DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 13 + OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 + TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 + PERFORMANCE OF THIS SOFTWARE. *) 16 + 17 + (** Command-line image processing operations for srcsetter. 18 + 19 + This module provides the core image processing pipeline including 20 + file discovery, image conversion, and progress reporting. *) 21 + 1 22 open Eio 2 23 24 + (** Configuration for the image processing pipeline. 25 + 26 + @param dummy When true, skip actual image conversion (dry run) 27 + @param preserve When true, skip conversion if destination exists 28 + @param proc_mgr Eio process manager for running ImageMagick 29 + @param src_dir Source directory containing original images 30 + @param dst_dir Destination directory for generated images 31 + @param img_widths List of target widths for responsive variants 32 + @param img_exts File extensions to process (e.g., ["jpg"; "png"]) 33 + @param idx_file Name of the JSON index file to generate 34 + @param max_fibers Maximum concurrent conversion operations *) 3 35 type ('a, 'b) config = { 4 36 dummy : bool; 5 37 preserve : bool; ··· 12 44 max_fibers : int; 13 45 } 14 46 47 + (** [file_seq ~filter path] recursively enumerates files in [path]. 48 + 49 + Returns a sequence of file paths where [filter filename] is true. 50 + Directories are traversed depth-first. *) 15 51 let rec file_seq ~filter path = 16 - Path.with_open_dir path Path.read_dir 17 - |> List.fold_left 18 - (fun (dirs, files) f -> 19 - let fp = Path.(path / f) in 20 - match Path.kind ~follow:false fp with 21 - | `Regular_file when filter f -> (dirs, fp :: files) 22 - | `Directory -> (f :: dirs, files) 23 - | _ -> (dirs, files)) 24 - ([], []) 25 - |> fun (dirs, files) -> 52 + let dirs, files = 53 + Path.with_open_dir path Path.read_dir 54 + |> List.fold_left 55 + (fun (dirs, files) f -> 56 + let fp = Path.(path / f) in 57 + match Path.kind ~follow:false fp with 58 + | `Regular_file when filter f -> (dirs, fp :: files) 59 + | `Directory -> (f :: dirs, files) 60 + | _ -> (dirs, files)) 61 + ([], []) 62 + in 26 63 Seq.append (List.to_seq files) 27 - (Seq.flat_map 28 - (fun f -> file_seq ~filter Path.(path / f)) 29 - (List.to_seq dirs)) 64 + (Seq.flat_map (fun f -> file_seq ~filter Path.(path / f)) (List.to_seq dirs)) 65 + 66 + (** [iter_seq_p ?max_fibers fn seq] iterates [fn] over [seq] in parallel. 30 67 68 + @param max_fibers Optional limit on concurrent fibers. Must be positive. 69 + @raise Invalid_argument if [max_fibers] is not positive. *) 31 70 let iter_seq_p ?max_fibers fn seq = 32 71 Eio.Switch.run ~name:"iter_seq_p" @@ fun sw -> 33 72 match max_fibers with 34 73 | None -> Seq.iter (fun v -> Fiber.fork ~sw @@ fun () -> fn v) seq 35 - | Some mf when mf <= 0 -> invalid_arg "iter_seq_p max_fibers" 74 + | Some mf when mf <= 0 -> invalid_arg "iter_seq_p: max_fibers must be positive" 36 75 | Some mf -> 37 - let s = Semaphore.make mf in 76 + let sem = Semaphore.make mf in 38 77 Seq.iter 39 78 (fun v -> 40 - Semaphore.acquire s; 79 + Semaphore.acquire sem; 41 80 Fiber.fork ~sw @@ fun () -> 42 - Fun.protect ~finally:(fun () -> Semaphore.release s) @@ fun () -> fn v) 81 + Fun.protect ~finally:(fun () -> Semaphore.release sem) @@ fun () -> 82 + fn v) 43 83 seq 44 84 85 + (** [relativize_path dir path] returns [path] relative to [dir]. 86 + 87 + @raise Failure if [path] is not under [dir]. *) 45 88 let relativize_path dir path = 46 89 let dir = Path.native_exn dir in 47 90 let path = Path.native_exn path in 48 91 match Fpath.(rem_prefix (v dir) (v path)) with 49 - | None -> failwith "bad path prefix" 50 - | Some v -> Fpath.to_string v 92 + | None -> failwith "relativize_path: path is not under directory" 93 + | Some rel -> Fpath.to_string rel 51 94 52 - let dims { proc_mgr; _ } fl = 53 - let fl = Path.native_exn fl in 54 - let args = [ "identify"; "-ping"; "-format"; "%w %h"; fl ] in 55 - let l = Process.parse_out proc_mgr Buf_read.take_all args in 56 - Scanf.sscanf l "%d %d" (fun w h -> (w, h)) 95 + (** [dims cfg path] returns the [(width, height)] dimensions of an image. 57 96 97 + Uses ImageMagick's [identify] command to read image metadata. *) 98 + let dims { proc_mgr; _ } path = 99 + let path = Path.native_exn path in 100 + let args = [ "identify"; "-ping"; "-format"; "%w %h"; path ] in 101 + let output = Process.parse_out proc_mgr Buf_read.take_all args in 102 + Scanf.sscanf output "%d %d" (fun w h -> (w, h)) 103 + 104 + (** [run cfg args] executes a shell command unless in dummy mode. *) 58 105 let run { dummy; proc_mgr; _ } args = 59 106 if not dummy then Process.run proc_mgr args 60 107 108 + (** [convert cfg (src, dst, size)] converts an image to WebP format. 109 + 110 + Creates the destination directory if needed, then uses ImageMagick 111 + to resize and convert the image with auto-orientation. *) 61 112 let convert ({ src_dir; dst_dir; dummy; _ } as cfg) (src, dst, size) = 62 - if dummy then () (* TODO log skip *) 63 - else 113 + if dummy then () 114 + else begin 64 115 let dir = 65 116 if Filename.dirname dst = "." then dst_dir 66 117 else Path.(dst_dir / Filename.dirname dst) 67 118 in 68 - Path.(mkdirs ~exists_ok:true ~perm:0o755 dir); 69 - let src = Path.(native_exn (src_dir / src)) in 70 - let dst = Path.(native_exn (dst_dir / dst)) in 119 + Path.mkdirs ~exists_ok:true ~perm:0o755 dir; 120 + let src_path = Path.(native_exn (src_dir / src)) in 121 + let dst_path = Path.(native_exn (dst_dir / dst)) in 71 122 let sz = Printf.sprintf "%dx" size in 72 - let args = 123 + run cfg 73 124 [ 74 - "magick"; 75 - src; 76 - "-auto-orient"; 77 - "-thumbnail"; 78 - sz; 79 - "-quality"; 80 - "100"; 81 - "-gravity"; 82 - "center"; 83 - "-extent"; 84 - sz; 85 - dst; 125 + "magick"; src_path; 126 + "-auto-orient"; "-thumbnail"; sz; 127 + "-quality"; "100"; 128 + "-gravity"; "center"; "-extent"; sz; 129 + dst_path; 86 130 ] 87 - in 88 - run cfg args 131 + end 132 + 133 + (** [convert_pdf cfg ~size ~dst ~src] converts a PDF's first page to an image. 89 134 135 + Renders at 300 DPI, crops the top half, and resizes to the target width. *) 90 136 let convert_pdf cfg ~size ~dst ~src = 91 - let src = Path.native_exn src in 92 - let dst = Path.native_exn dst in 137 + let src_path = Path.native_exn src in 138 + let dst_path = Path.native_exn dst in 93 139 let sz = Printf.sprintf "%sx" size in 94 - let args = 140 + run cfg 95 141 [ 96 - "magick"; 97 - "-density"; 98 - "300"; 99 - "-quality"; 100 - "100"; 101 - src ^ "[0]"; 102 - "-gravity"; 103 - "North"; 104 - "-crop"; 105 - "100%x50%+0+0"; 106 - "-resize"; 107 - sz; 108 - dst; 142 + "magick"; "-density"; "300"; "-quality"; "100"; 143 + src_path ^ "[0]"; 144 + "-gravity"; "North"; "-crop"; "100%x50%+0+0"; 145 + "-resize"; sz; 146 + dst_path; 109 147 ] 110 - in 111 - run cfg args 112 148 149 + (** [needed_sizes ~img_widths ~w] returns widths from [img_widths] that are <= [w]. *) 113 150 let needed_sizes ~img_widths ~w = List.filter (fun tw -> tw <= w) img_widths 114 151 152 + (** [needs_conversion ~preserve dst] returns true if [dst] should be generated. 153 + 154 + When [preserve] is true, existing files are skipped. *) 155 + let needs_conversion ~preserve dst = 156 + not (preserve && Path.is_file dst) 157 + 158 + (** [translate cfg ?w src] computes source and destination paths for conversion. 159 + 160 + Returns [(src_file, dst_file, width_opt, needs_work)] where [needs_work] 161 + indicates whether the conversion should be performed. *) 115 162 let translate { src_dir; dst_dir; preserve; _ } ?w src = 116 163 let src_file = relativize_path src_dir src in 117 - let dst_file = 118 - Printf.sprintf "%s%s.webp" 119 - (Filename.chop_extension src_file) 120 - (match w with None -> "" | Some w -> "." ^ string_of_int w) 121 - in 164 + let width_suffix = Option.fold ~none:"" ~some:(fun w -> "." ^ string_of_int w) w in 165 + let dst_file = Printf.sprintf "%s%s.webp" (Filename.chop_extension src_file) width_suffix in 122 166 let dst = Path.(dst_dir / dst_file) in 123 - match (preserve, Path.is_file dst) with 124 - | true, true -> (src_file, dst_file, w, false) 125 - | _, false -> (src_file, dst_file, w, true) 126 - | false, true -> (src_file, dst_file, w, true) 167 + (src_file, dst_file, w, needs_conversion ~preserve dst) 168 + 169 + (** [calc_needed cfg ~img_widths ~w src] computes which conversions are needed. 127 170 171 + Returns [(base, variants)] where each is tagged with [`Exists] or [`Todo]. *) 128 172 let calc_needed { src_dir; dst_dir; preserve; _ } ~img_widths ~w src = 129 - let ent_of_dst fname tw = 173 + let check_dst fname tw = 130 174 let dst = Path.(dst_dir / fname) in 131 175 let ent = (src, dst, tw) in 132 - match (preserve, Path.is_file dst) with 133 - | true, true -> `Exists ent 134 - | _, false -> `Todo ent 135 - | false, true -> `Todo ent 176 + if preserve && Path.is_file dst then `Exists ent else `Todo ent 136 177 in 137 178 let file = relativize_path src_dir src in 138 - let base = 139 - let fname = Printf.sprintf "%s.webp" (Filename.chop_extension file) in 140 - ent_of_dst fname w 141 - in 179 + let base_name = Filename.chop_extension file in 180 + let base = check_dst (Printf.sprintf "%s.webp" base_name) w in 142 181 let variants = 143 182 List.filter_map 144 183 (fun tw -> 145 - if tw <= w then 146 - let fname = 147 - Printf.sprintf "%s.%d.webp" (Filename.chop_extension file) tw 148 - in 149 - Some (ent_of_dst fname tw) 184 + if tw <= w then Some (check_dst (Printf.sprintf "%s.%d.webp" base_name tw) tw) 150 185 else None) 151 186 img_widths 152 187 in 153 188 (base, variants) 154 189 190 + (** {1 Progress Bar Rendering} *) 191 + 192 + (** [main_bar total] creates a progress bar for [total] items. *) 155 193 let main_bar total = 194 + let open Progress.Line in 156 195 let style = 157 - let open Progress.Line.Bar_style in 196 + let open Bar_style in 158 197 let open Progress.Color in 159 - let bars = ("|", "|") in 160 - v ~delims:bars ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ] 198 + v ~delims:("|", "|") ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ] 161 199 in 162 - let open Progress.Line in 163 200 list [ bar ~style:(`Custom style) total; ticker_to total ] 164 201 202 + (** [main_bar_heading head total] creates a labeled progress display. *) 165 203 let main_bar_heading head total = 166 204 let open Progress.Multi in 167 205 line (Progress.Line.const head) ++ line (main_bar total) ++ blank 168 206 207 + (** [one_bar total] creates a compact progress bar for individual file processing. *) 169 208 let one_bar total = 209 + let open Progress.Line in 170 210 let style = 171 - let open Progress.Line.Bar_style in 211 + let open Bar_style in 172 212 let open Progress.Color in 173 213 v ~delims:("{", "}") ~color:(ansi `blue) [ "="; ">"; " " ] 174 214 in 175 - let open Progress.Line in 176 - let a = 177 - list 178 - [ 179 - spinner (); 180 - bar ~style:(`Custom style) ~width:(`Fixed 12) total; 181 - const " "; 182 - ] 183 - in 184 - let b = string in 185 - pair a b 215 + let left = list [ spinner (); bar ~style:(`Custom style) ~width:(`Fixed 12) total; const " " ] in 216 + pair left string 217 + 218 + (** {1 Image Processing} *) 219 + 220 + (** [truncate_string str max_len] truncates [str] to [max_len] chars with ellipsis. *) 221 + let truncate_string str max_len = 222 + if String.length str <= max_len then str 223 + else if max_len <= 3 then String.sub "..." 0 max_len 224 + else String.sub str 0 (max_len - 3) ^ "..." 225 + 226 + (** [process_file cfg (display, main_rep) src] processes a single source image. 227 + 228 + Converts the image to WebP format at multiple responsive sizes. 229 + Shows a nested progress bar for files requiring many conversions. 186 230 231 + @return An {!Srcsetter.t} entry with metadata about the generated images. *) 187 232 let process_file cfg (display, main_rep) src = 188 233 let w, h = dims cfg src in 189 234 let needed_w = needed_sizes ~img_widths:cfg.img_widths ~w in 190 - let ((base_src, base_dst, _, _) as base) = translate cfg src in 235 + let base_src, base_dst, _, _ as base = translate cfg src in 191 236 let needed = List.map (fun w -> translate cfg ~w src) needed_w in 192 237 let variants = 193 - List.map (fun (_, dst, _, _) -> (dst, (0, 0))) needed 238 + needed 239 + |> List.map (fun (_, dst, _, _) -> (dst, (0, 0))) 194 240 |> Srcsetter.MS.of_list 195 241 in 196 242 let slug = Filename.basename base_dst |> Filename.chop_extension in 197 - (* TODO avsm check for clashing slugs *) 198 243 let ent = Srcsetter.v base_dst slug base_src variants (w, h) in 199 244 let todo = 200 245 List.filter_map 201 - (fun (src, dst, sz, n) -> 202 - let sz = match sz with None -> w | Some w -> w in 203 - if n then Some (src, dst, sz) else None) 246 + (fun (src, dst, sz, needs_work) -> 247 + if needs_work then Some (src, dst, Option.value sz ~default:w) else None) 204 248 (base :: needed) 205 249 in 206 - if List.length todo > 3 then ( 207 - let l = one_bar (List.length todo) in 208 - let r = Progress.Display.add_line display l in 209 - let fin = ref [] in 210 - let rep sz = 211 - if sz > 0 then fin := sz :: !fin; 212 - let la = String.concat "," @@ List.map string_of_int !fin in 213 - let flb = 214 - Filename.basename (Path.native_exn src) |> Filename.chop_extension 215 - in 216 - let trim_string str max_length = 217 - if String.length str <= max_length then str 218 - else if max_length <= 3 then String.sub "..." 0 max_length 219 - else 220 - let trimmed_length = max_length - 3 in 221 - let prefix = String.sub str 0 trimmed_length in 222 - prefix ^ "..." 223 - in 224 - let label = Printf.sprintf "%25s -> %s" (trim_string flb 25) la in 225 - Progress.Reporter.report r (1, label) 250 + let num_todo = List.length todo in 251 + if num_todo > 3 then begin 252 + let line = one_bar num_todo in 253 + let reporter = Progress.Display.add_line display line in 254 + let completed = ref [] in 255 + let report_progress sz = 256 + if sz > 0 then completed := sz :: !completed; 257 + let sizes_str = String.concat "," (List.map string_of_int !completed) in 258 + let basename = Path.native_exn src |> Filename.basename |> Filename.chop_extension in 259 + let label = Printf.sprintf "%25s -> %s" (truncate_string basename 25) sizes_str in 260 + Progress.Reporter.report reporter (1, label) 226 261 in 227 - rep 0; 228 - List.iter 229 - (fun ((_, _, sz) as a) -> 230 - rep sz; 231 - convert cfg a) 232 - todo; 262 + report_progress 0; 263 + List.iter (fun (_, _, sz as job) -> report_progress sz; convert cfg job) todo; 233 264 main_rep 1; 234 - Progress.Display.remove_line display r) 235 - else ( 236 - List.iter (fun a -> convert cfg a) todo; 237 - main_rep 1); 265 + Progress.Display.remove_line display reporter 266 + end 267 + else begin 268 + List.iter (convert cfg) todo; 269 + main_rep 1 270 + end; 238 271 ent