anil.recoil.org
Generate srcset images for a variety of resolutions from OCaml
1open Eio
2
3type ('a, 'b) config = {
4 dummy : bool;
5 preserve : bool;
6 proc_mgr : 'a Eio.Process.mgr;
7 src_dir : 'b Path.t;
8 dst_dir : 'b Path.t;
9 img_widths : int list;
10 img_exts : string list;
11 idx_file : string;
12 max_fibers : int;
13}
14
15let 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) ->
26 Seq.append (List.to_seq files)
27 (Seq.flat_map
28 (fun f -> file_seq ~filter Path.(path / f))
29 (List.to_seq dirs))
30
31let iter_seq_p ?max_fibers fn seq =
32 Eio.Switch.run ~name:"iter_seq_p" @@ fun sw ->
33 match max_fibers with
34 | 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"
36 | Some mf ->
37 let s = Semaphore.make mf in
38 Seq.iter
39 (fun v ->
40 Semaphore.acquire s;
41 Fiber.fork ~sw @@ fun () ->
42 Fun.protect ~finally:(fun () -> Semaphore.release s) @@ fun () -> fn v)
43 seq
44
45let relativize_path dir path =
46 let dir = Path.native_exn dir in
47 let path = Path.native_exn path in
48 match Fpath.(rem_prefix (v dir) (v path)) with
49 | None -> failwith "bad path prefix"
50 | Some v -> Fpath.to_string v
51
52let 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))
57
58let run { dummy; proc_mgr; _ } args =
59 if not dummy then Process.run proc_mgr args
60
61let convert ({ src_dir; dst_dir; dummy; _ } as cfg) (src, dst, size) =
62 if dummy then () (* TODO log skip *)
63 else
64 let dir =
65 if Filename.dirname dst = "." then dst_dir
66 else Path.(dst_dir / Filename.dirname dst)
67 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
71 let sz = Printf.sprintf "%dx" size in
72 let args =
73 [
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;
86 ]
87 in
88 run cfg args
89
90let convert_pdf cfg ~size ~dst ~src =
91 let src = Path.native_exn src in
92 let dst = Path.native_exn dst in
93 let sz = Printf.sprintf "%sx" size in
94 let args =
95 [
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;
109 ]
110 in
111 run cfg args
112
113let needed_sizes ~img_widths ~w = List.filter (fun tw -> tw <= w) img_widths
114
115let translate { src_dir; dst_dir; preserve; _ } ?w src =
116 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
122 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)
127
128let calc_needed { src_dir; dst_dir; preserve; _ } ~img_widths ~w src =
129 let ent_of_dst fname tw =
130 let dst = Path.(dst_dir / fname) in
131 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
136 in
137 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
142 let variants =
143 List.filter_map
144 (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)
150 else None)
151 img_widths
152 in
153 (base, variants)
154
155let main_bar total =
156 let style =
157 let open Progress.Line.Bar_style in
158 let open Progress.Color in
159 let bars = ("|", "|") in
160 v ~delims:bars ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ]
161 in
162 let open Progress.Line in
163 list [ bar ~style:(`Custom style) total; ticker_to total ]
164
165let main_bar_heading head total =
166 let open Progress.Multi in
167 line (Progress.Line.const head) ++ line (main_bar total) ++ blank
168
169let one_bar total =
170 let style =
171 let open Progress.Line.Bar_style in
172 let open Progress.Color in
173 v ~delims:("{", "}") ~color:(ansi `blue) [ "="; ">"; " " ]
174 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
186
187let process_file cfg (display, main_rep) src =
188 let w, h = dims cfg src in
189 let needed_w = needed_sizes ~img_widths:cfg.img_widths ~w in
190 let ((base_src, base_dst, _, _) as base) = translate cfg src in
191 let needed = List.map (fun w -> translate cfg ~w src) needed_w in
192 let variants =
193 List.map (fun (_, dst, _, _) -> (dst, (0, 0))) needed
194 |> Srcsetter.MS.of_list
195 in
196 let slug = Filename.basename base_dst |> Filename.chop_extension in
197 (* TODO avsm check for clashing slugs *)
198 let ent = Srcsetter.v base_dst slug base_src variants (w, h) in
199 let todo =
200 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)
204 (base :: needed)
205 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)
226 in
227 rep 0;
228 List.iter
229 (fun ((_, _, sz) as a) ->
230 rep sz;
231 convert cfg a)
232 todo;
233 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);
238 ent