···11(* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org>
2233- Permission to use, copy, modify, and/or distribute this software for
44- any purpose with or without fee is hereby granted, provided that the
55- above copyright notice and this permission notice appear in all
66- copies.
33+ Permission to use, copy, modify, and/or distribute this software for
44+ any purpose with or without fee is hereby granted, provided that the
55+ above copyright notice and this permission notice appear in all
66+ copies.
7788- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
99- WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
1010- WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
1111- AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
1212- DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
1313- OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
1414- TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
1515- PERFORMANCE OF THIS SOFTWARE.
1616- *)
88+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
99+ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
1010+ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
1111+ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
1212+ DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
1313+ OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
1414+ TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
1515+ PERFORMANCE OF THIS SOFTWARE. *)
17161817module MS = Map.Make (String)
1918···2625}
27262827let v name slug origin variants dims = { name; slug; origin; variants; dims }
2929-let origin { origin; _ } = origin
3030-let slug { slug; _ } = slug
3131-let name { name; _ } = name
3232-let dims { dims; _ } = dims
3333-let variants { variants; _ } = variants
2828+let name t = t.name
2929+let slug t = t.slug
3030+let origin t = t.origin
3131+let dims t = t.dims
3232+let variants t = t.variants
34333434+(** JSON codec for dimension pairs, encoded as a 2-element array. *)
3535let dims_json_t =
3636 let open Jsont in
3737- let dec x y = (x, y) in
3838- let enc (w, h) = function 0 -> w | _ -> h in
3737+ let dec w h = (w, h) in
3838+ let enc (w, h) i = if i = 0 then w else h in
3939 t2 ~dec ~enc uint16
40404141let json_t =
···5050 |> finish
51515252let list = Jsont.list json_t
5353-let list_to_json es = Jsont_bytesrw.encode_string list ~format:Jsont.Indent es
5353+let list_to_json entries = Jsont_bytesrw.encode_string list ~format:Jsont.Indent entries
5454let list_of_json = Jsont_bytesrw.decode_string list
+56-3
lib/srcsetter.mli
···11+(** Image entry management for responsive image generation.
22+33+ This module provides types and functions for managing image entries
44+ that contain metadata about responsive images including their dimensions
55+ and size variants. *)
66+77+(** {1 Types} *)
88+99+(** String map for storing image variants keyed by filename. *)
110module MS : Map.S with type key = string
2111212+(** An image entry representing a source image and its generated variants.
1313+1414+ Each entry tracks:
1515+ - The output filename ([name])
1616+ - A URL-safe identifier ([slug])
1717+ - The original source path ([origin])
1818+ - Image dimensions as [(width, height)]
1919+ - A map of variant filenames to their dimensions *)
320type t = {
421 name : string;
522 slug : string;
···724 dims : int * int;
825 variants : (int * int) MS.t;
926}
2727+2828+(** {1 Constructors} *)
10291130val v : string -> string -> string -> (int * int) MS.t -> int * int -> t
3131+(** [v name slug origin variants dims] creates a new image entry.
3232+3333+ @param name The output filename (e.g., ["photo.webp"])
3434+ @param slug A URL-safe identifier derived from the filename
3535+ @param origin The original source file path
3636+ @param variants Map of variant filenames to their [(width, height)] dimensions
3737+ @param dims The base image dimensions as [(width, height)] *)
3838+3939+(** {1 Accessors} *)
4040+4141+val name : t -> string
4242+(** [name entry] returns the output filename. *)
4343+4444+val slug : t -> string
4545+(** [slug entry] returns the URL-safe identifier. *)
4646+1247val origin : t -> string
1313-val name : t -> string
4848+(** [origin entry] returns the original source file path. *)
4949+1450val dims : t -> int * int
5151+(** [dims entry] returns the base image dimensions as [(width, height)]. *)
5252+1553val variants : t -> (int * int) MS.t
5454+(** [variants entry] returns the map of variant filenames to dimensions. *)
5555+5656+(** {1 JSON Serialization} *)
5757+5858+val json_t : t Jsont.t
5959+(** JSON codec for a single image entry. *)
6060+6161+val list : t list Jsont.t
6262+(** JSON codec for a list of image entries. *)
6363+1664val list_to_json : t list -> (string, string) result
6565+(** [list_to_json entries] serializes a list of entries to a JSON string.
6666+6767+ Returns [Ok json_string] on success, or [Error message] if encoding fails. *)
6868+1769val list_of_json : string -> (t list, string) result
1818-val json_t : t Jsont.t
1919-val list : t list Jsont.t
7070+(** [list_of_json json_string] parses a JSON string into a list of entries.
7171+7272+ Returns [Ok entries] on success, or [Error message] if parsing fails. *)
+170-137
lib/srcsetter_cmd.ml
···11+(* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org>
22+33+ Permission to use, copy, modify, and/or distribute this software for
44+ any purpose with or without fee is hereby granted, provided that the
55+ above copyright notice and this permission notice appear in all
66+ copies.
77+88+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
99+ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
1010+ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
1111+ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
1212+ DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
1313+ OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
1414+ TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
1515+ PERFORMANCE OF THIS SOFTWARE. *)
1616+1717+(** Command-line image processing operations for srcsetter.
1818+1919+ This module provides the core image processing pipeline including
2020+ file discovery, image conversion, and progress reporting. *)
2121+122open Eio
2232424+(** Configuration for the image processing pipeline.
2525+2626+ @param dummy When true, skip actual image conversion (dry run)
2727+ @param preserve When true, skip conversion if destination exists
2828+ @param proc_mgr Eio process manager for running ImageMagick
2929+ @param src_dir Source directory containing original images
3030+ @param dst_dir Destination directory for generated images
3131+ @param img_widths List of target widths for responsive variants
3232+ @param img_exts File extensions to process (e.g., ["jpg"; "png"])
3333+ @param idx_file Name of the JSON index file to generate
3434+ @param max_fibers Maximum concurrent conversion operations *)
335type ('a, 'b) config = {
436 dummy : bool;
537 preserve : bool;
···1244 max_fibers : int;
1345}
14464747+(** [file_seq ~filter path] recursively enumerates files in [path].
4848+4949+ Returns a sequence of file paths where [filter filename] is true.
5050+ Directories are traversed depth-first. *)
1551let rec file_seq ~filter path =
1616- Path.with_open_dir path Path.read_dir
1717- |> List.fold_left
1818- (fun (dirs, files) f ->
1919- let fp = Path.(path / f) in
2020- match Path.kind ~follow:false fp with
2121- | `Regular_file when filter f -> (dirs, fp :: files)
2222- | `Directory -> (f :: dirs, files)
2323- | _ -> (dirs, files))
2424- ([], [])
2525- |> fun (dirs, files) ->
5252+ let dirs, files =
5353+ Path.with_open_dir path Path.read_dir
5454+ |> List.fold_left
5555+ (fun (dirs, files) f ->
5656+ let fp = Path.(path / f) in
5757+ match Path.kind ~follow:false fp with
5858+ | `Regular_file when filter f -> (dirs, fp :: files)
5959+ | `Directory -> (f :: dirs, files)
6060+ | _ -> (dirs, files))
6161+ ([], [])
6262+ in
2663 Seq.append (List.to_seq files)
2727- (Seq.flat_map
2828- (fun f -> file_seq ~filter Path.(path / f))
2929- (List.to_seq dirs))
6464+ (Seq.flat_map (fun f -> file_seq ~filter Path.(path / f)) (List.to_seq dirs))
6565+6666+(** [iter_seq_p ?max_fibers fn seq] iterates [fn] over [seq] in parallel.
30676868+ @param max_fibers Optional limit on concurrent fibers. Must be positive.
6969+ @raise Invalid_argument if [max_fibers] is not positive. *)
3170let iter_seq_p ?max_fibers fn seq =
3271 Eio.Switch.run ~name:"iter_seq_p" @@ fun sw ->
3372 match max_fibers with
3473 | None -> Seq.iter (fun v -> Fiber.fork ~sw @@ fun () -> fn v) seq
3535- | Some mf when mf <= 0 -> invalid_arg "iter_seq_p max_fibers"
7474+ | Some mf when mf <= 0 -> invalid_arg "iter_seq_p: max_fibers must be positive"
3675 | Some mf ->
3737- let s = Semaphore.make mf in
7676+ let sem = Semaphore.make mf in
3877 Seq.iter
3978 (fun v ->
4040- Semaphore.acquire s;
7979+ Semaphore.acquire sem;
4180 Fiber.fork ~sw @@ fun () ->
4242- Fun.protect ~finally:(fun () -> Semaphore.release s) @@ fun () -> fn v)
8181+ Fun.protect ~finally:(fun () -> Semaphore.release sem) @@ fun () ->
8282+ fn v)
4383 seq
44848585+(** [relativize_path dir path] returns [path] relative to [dir].
8686+8787+ @raise Failure if [path] is not under [dir]. *)
4588let relativize_path dir path =
4689 let dir = Path.native_exn dir in
4790 let path = Path.native_exn path in
4891 match Fpath.(rem_prefix (v dir) (v path)) with
4949- | None -> failwith "bad path prefix"
5050- | Some v -> Fpath.to_string v
9292+ | None -> failwith "relativize_path: path is not under directory"
9393+ | Some rel -> Fpath.to_string rel
51945252-let dims { proc_mgr; _ } fl =
5353- let fl = Path.native_exn fl in
5454- let args = [ "identify"; "-ping"; "-format"; "%w %h"; fl ] in
5555- let l = Process.parse_out proc_mgr Buf_read.take_all args in
5656- Scanf.sscanf l "%d %d" (fun w h -> (w, h))
9595+(** [dims cfg path] returns the [(width, height)] dimensions of an image.
57969797+ Uses ImageMagick's [identify] command to read image metadata. *)
9898+let dims { proc_mgr; _ } path =
9999+ let path = Path.native_exn path in
100100+ let args = [ "identify"; "-ping"; "-format"; "%w %h"; path ] in
101101+ let output = Process.parse_out proc_mgr Buf_read.take_all args in
102102+ Scanf.sscanf output "%d %d" (fun w h -> (w, h))
103103+104104+(** [run cfg args] executes a shell command unless in dummy mode. *)
58105let run { dummy; proc_mgr; _ } args =
59106 if not dummy then Process.run proc_mgr args
60107108108+(** [convert cfg (src, dst, size)] converts an image to WebP format.
109109+110110+ Creates the destination directory if needed, then uses ImageMagick
111111+ to resize and convert the image with auto-orientation. *)
61112let convert ({ src_dir; dst_dir; dummy; _ } as cfg) (src, dst, size) =
6262- if dummy then () (* TODO log skip *)
6363- else
113113+ if dummy then ()
114114+ else begin
64115 let dir =
65116 if Filename.dirname dst = "." then dst_dir
66117 else Path.(dst_dir / Filename.dirname dst)
67118 in
6868- Path.(mkdirs ~exists_ok:true ~perm:0o755 dir);
6969- let src = Path.(native_exn (src_dir / src)) in
7070- let dst = Path.(native_exn (dst_dir / dst)) in
119119+ Path.mkdirs ~exists_ok:true ~perm:0o755 dir;
120120+ let src_path = Path.(native_exn (src_dir / src)) in
121121+ let dst_path = Path.(native_exn (dst_dir / dst)) in
71122 let sz = Printf.sprintf "%dx" size in
7272- let args =
123123+ run cfg
73124 [
7474- "magick";
7575- src;
7676- "-auto-orient";
7777- "-thumbnail";
7878- sz;
7979- "-quality";
8080- "100";
8181- "-gravity";
8282- "center";
8383- "-extent";
8484- sz;
8585- dst;
125125+ "magick"; src_path;
126126+ "-auto-orient"; "-thumbnail"; sz;
127127+ "-quality"; "100";
128128+ "-gravity"; "center"; "-extent"; sz;
129129+ dst_path;
86130 ]
8787- in
8888- run cfg args
131131+ end
132132+133133+(** [convert_pdf cfg ~size ~dst ~src] converts a PDF's first page to an image.
89134135135+ Renders at 300 DPI, crops the top half, and resizes to the target width. *)
90136let convert_pdf cfg ~size ~dst ~src =
9191- let src = Path.native_exn src in
9292- let dst = Path.native_exn dst in
137137+ let src_path = Path.native_exn src in
138138+ let dst_path = Path.native_exn dst in
93139 let sz = Printf.sprintf "%sx" size in
9494- let args =
140140+ run cfg
95141 [
9696- "magick";
9797- "-density";
9898- "300";
9999- "-quality";
100100- "100";
101101- src ^ "[0]";
102102- "-gravity";
103103- "North";
104104- "-crop";
105105- "100%x50%+0+0";
106106- "-resize";
107107- sz;
108108- dst;
142142+ "magick"; "-density"; "300"; "-quality"; "100";
143143+ src_path ^ "[0]";
144144+ "-gravity"; "North"; "-crop"; "100%x50%+0+0";
145145+ "-resize"; sz;
146146+ dst_path;
109147 ]
110110- in
111111- run cfg args
112148149149+(** [needed_sizes ~img_widths ~w] returns widths from [img_widths] that are <= [w]. *)
113150let needed_sizes ~img_widths ~w = List.filter (fun tw -> tw <= w) img_widths
114151152152+(** [needs_conversion ~preserve dst] returns true if [dst] should be generated.
153153+154154+ When [preserve] is true, existing files are skipped. *)
155155+let needs_conversion ~preserve dst =
156156+ not (preserve && Path.is_file dst)
157157+158158+(** [translate cfg ?w src] computes source and destination paths for conversion.
159159+160160+ Returns [(src_file, dst_file, width_opt, needs_work)] where [needs_work]
161161+ indicates whether the conversion should be performed. *)
115162let translate { src_dir; dst_dir; preserve; _ } ?w src =
116163 let src_file = relativize_path src_dir src in
117117- let dst_file =
118118- Printf.sprintf "%s%s.webp"
119119- (Filename.chop_extension src_file)
120120- (match w with None -> "" | Some w -> "." ^ string_of_int w)
121121- in
164164+ let width_suffix = Option.fold ~none:"" ~some:(fun w -> "." ^ string_of_int w) w in
165165+ let dst_file = Printf.sprintf "%s%s.webp" (Filename.chop_extension src_file) width_suffix in
122166 let dst = Path.(dst_dir / dst_file) in
123123- match (preserve, Path.is_file dst) with
124124- | true, true -> (src_file, dst_file, w, false)
125125- | _, false -> (src_file, dst_file, w, true)
126126- | false, true -> (src_file, dst_file, w, true)
167167+ (src_file, dst_file, w, needs_conversion ~preserve dst)
168168+169169+(** [calc_needed cfg ~img_widths ~w src] computes which conversions are needed.
127170171171+ Returns [(base, variants)] where each is tagged with [`Exists] or [`Todo]. *)
128172let calc_needed { src_dir; dst_dir; preserve; _ } ~img_widths ~w src =
129129- let ent_of_dst fname tw =
173173+ let check_dst fname tw =
130174 let dst = Path.(dst_dir / fname) in
131175 let ent = (src, dst, tw) in
132132- match (preserve, Path.is_file dst) with
133133- | true, true -> `Exists ent
134134- | _, false -> `Todo ent
135135- | false, true -> `Todo ent
176176+ if preserve && Path.is_file dst then `Exists ent else `Todo ent
136177 in
137178 let file = relativize_path src_dir src in
138138- let base =
139139- let fname = Printf.sprintf "%s.webp" (Filename.chop_extension file) in
140140- ent_of_dst fname w
141141- in
179179+ let base_name = Filename.chop_extension file in
180180+ let base = check_dst (Printf.sprintf "%s.webp" base_name) w in
142181 let variants =
143182 List.filter_map
144183 (fun tw ->
145145- if tw <= w then
146146- let fname =
147147- Printf.sprintf "%s.%d.webp" (Filename.chop_extension file) tw
148148- in
149149- Some (ent_of_dst fname tw)
184184+ if tw <= w then Some (check_dst (Printf.sprintf "%s.%d.webp" base_name tw) tw)
150185 else None)
151186 img_widths
152187 in
153188 (base, variants)
154189190190+(** {1 Progress Bar Rendering} *)
191191+192192+(** [main_bar total] creates a progress bar for [total] items. *)
155193let main_bar total =
194194+ let open Progress.Line in
156195 let style =
157157- let open Progress.Line.Bar_style in
196196+ let open Bar_style in
158197 let open Progress.Color in
159159- let bars = ("|", "|") in
160160- v ~delims:bars ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ]
198198+ v ~delims:("|", "|") ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ]
161199 in
162162- let open Progress.Line in
163200 list [ bar ~style:(`Custom style) total; ticker_to total ]
164201202202+(** [main_bar_heading head total] creates a labeled progress display. *)
165203let main_bar_heading head total =
166204 let open Progress.Multi in
167205 line (Progress.Line.const head) ++ line (main_bar total) ++ blank
168206207207+(** [one_bar total] creates a compact progress bar for individual file processing. *)
169208let one_bar total =
209209+ let open Progress.Line in
170210 let style =
171171- let open Progress.Line.Bar_style in
211211+ let open Bar_style in
172212 let open Progress.Color in
173213 v ~delims:("{", "}") ~color:(ansi `blue) [ "="; ">"; " " ]
174214 in
175175- let open Progress.Line in
176176- let a =
177177- list
178178- [
179179- spinner ();
180180- bar ~style:(`Custom style) ~width:(`Fixed 12) total;
181181- const " ";
182182- ]
183183- in
184184- let b = string in
185185- pair a b
215215+ let left = list [ spinner (); bar ~style:(`Custom style) ~width:(`Fixed 12) total; const " " ] in
216216+ pair left string
217217+218218+(** {1 Image Processing} *)
219219+220220+(** [truncate_string str max_len] truncates [str] to [max_len] chars with ellipsis. *)
221221+let truncate_string str max_len =
222222+ if String.length str <= max_len then str
223223+ else if max_len <= 3 then String.sub "..." 0 max_len
224224+ else String.sub str 0 (max_len - 3) ^ "..."
225225+226226+(** [process_file cfg (display, main_rep) src] processes a single source image.
227227+228228+ Converts the image to WebP format at multiple responsive sizes.
229229+ Shows a nested progress bar for files requiring many conversions.
186230231231+ @return An {!Srcsetter.t} entry with metadata about the generated images. *)
187232let process_file cfg (display, main_rep) src =
188233 let w, h = dims cfg src in
189234 let needed_w = needed_sizes ~img_widths:cfg.img_widths ~w in
190190- let ((base_src, base_dst, _, _) as base) = translate cfg src in
235235+ let base_src, base_dst, _, _ as base = translate cfg src in
191236 let needed = List.map (fun w -> translate cfg ~w src) needed_w in
192237 let variants =
193193- List.map (fun (_, dst, _, _) -> (dst, (0, 0))) needed
238238+ needed
239239+ |> List.map (fun (_, dst, _, _) -> (dst, (0, 0)))
194240 |> Srcsetter.MS.of_list
195241 in
196242 let slug = Filename.basename base_dst |> Filename.chop_extension in
197197- (* TODO avsm check for clashing slugs *)
198243 let ent = Srcsetter.v base_dst slug base_src variants (w, h) in
199244 let todo =
200245 List.filter_map
201201- (fun (src, dst, sz, n) ->
202202- let sz = match sz with None -> w | Some w -> w in
203203- if n then Some (src, dst, sz) else None)
246246+ (fun (src, dst, sz, needs_work) ->
247247+ if needs_work then Some (src, dst, Option.value sz ~default:w) else None)
204248 (base :: needed)
205249 in
206206- if List.length todo > 3 then (
207207- let l = one_bar (List.length todo) in
208208- let r = Progress.Display.add_line display l in
209209- let fin = ref [] in
210210- let rep sz =
211211- if sz > 0 then fin := sz :: !fin;
212212- let la = String.concat "," @@ List.map string_of_int !fin in
213213- let flb =
214214- Filename.basename (Path.native_exn src) |> Filename.chop_extension
215215- in
216216- let trim_string str max_length =
217217- if String.length str <= max_length then str
218218- else if max_length <= 3 then String.sub "..." 0 max_length
219219- else
220220- let trimmed_length = max_length - 3 in
221221- let prefix = String.sub str 0 trimmed_length in
222222- prefix ^ "..."
223223- in
224224- let label = Printf.sprintf "%25s -> %s" (trim_string flb 25) la in
225225- Progress.Reporter.report r (1, label)
250250+ let num_todo = List.length todo in
251251+ if num_todo > 3 then begin
252252+ let line = one_bar num_todo in
253253+ let reporter = Progress.Display.add_line display line in
254254+ let completed = ref [] in
255255+ let report_progress sz =
256256+ if sz > 0 then completed := sz :: !completed;
257257+ let sizes_str = String.concat "," (List.map string_of_int !completed) in
258258+ let basename = Path.native_exn src |> Filename.basename |> Filename.chop_extension in
259259+ let label = Printf.sprintf "%25s -> %s" (truncate_string basename 25) sizes_str in
260260+ Progress.Reporter.report reporter (1, label)
226261 in
227227- rep 0;
228228- List.iter
229229- (fun ((_, _, sz) as a) ->
230230- rep sz;
231231- convert cfg a)
232232- todo;
262262+ report_progress 0;
263263+ List.iter (fun (_, _, sz as job) -> report_progress sz; convert cfg job) todo;
233264 main_rep 1;
234234- Progress.Display.remove_line display r)
235235- else (
236236- List.iter (fun a -> convert cfg a) todo;
237237- main_rep 1);
265265+ Progress.Display.remove_line display reporter
266266+ end
267267+ else begin
268268+ List.iter (convert cfg) todo;
269269+ main_rep 1
270270+ end;
238271 ent