Generate srcset images for a variety of resolutions from OCaml
Initial import
+508
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.27.0
+18
LICENSE.md
+18
LICENSE.md
···
1
+
(*
2
+
* ISC License
3
+
*
4
+
* Copyright (c) 2024 Anil Madhavapeddy <anil@recoil.org>
5
+
*
6
+
* Permission to use, copy, modify, and distribute this software for any
7
+
* purpose with or without fee is hereby granted, provided that the above
8
+
* copyright notice and this permission notice appear in all copies.
9
+
*
10
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
+
*
18
+
*)
+5
bin/dune
+5
bin/dune
+91
bin/srcsetter.ml
+91
bin/srcsetter.ml
···
1
+
module SC = Srcsetter_cmd
2
+
3
+
let min_interval = Some (Mtime.Span.of_uint64_ns 1000L)
4
+
5
+
let stage1 { SC.img_exts; src_dir; _ } =
6
+
let filter f = List.exists (Filename.check_suffix ("." ^ f)) img_exts in
7
+
let fs = SC.file_seq ~filter src_dir in
8
+
let total = Seq.length fs in
9
+
Format.printf "[1/3] Scanned %d images from %a.\n%!" total Eio.Path.pp src_dir;
10
+
fs
11
+
12
+
let stage2 ({ SC.max_fibers; dst_dir; _ } as cfg) fs =
13
+
let display =
14
+
Progress.Display.start
15
+
~config:(Progress.Config.v ~persistent:false ~min_interval ())
16
+
(SC.main_bar_heading "[2/3] Processing images..." (Seq.length fs))
17
+
in
18
+
let [ _; main_rep ] = Progress.Display.reporters display in
19
+
let ents = ref [] in
20
+
SC.iter_seq_p ~max_fibers
21
+
(fun src ->
22
+
let ent = SC.process_file cfg (display, main_rep) src in
23
+
ents := ent :: !ents)
24
+
fs;
25
+
Progress.Display.finalise display;
26
+
Format.printf "[2/3] Processed %d images to %a.\n%!" (List.length !ents)
27
+
Eio.Path.pp dst_dir;
28
+
!ents
29
+
30
+
let stage3 ({ SC.dst_dir; max_fibers; _ } as cfg) ents =
31
+
let ents_seq = List.to_seq ents in
32
+
let oents = ref [] in
33
+
let display =
34
+
Progress.Display.start
35
+
~config:(Progress.Config.v ~persistent:false ~min_interval ())
36
+
(SC.main_bar_heading "[3/3] Verifying images..." (List.length ents))
37
+
in
38
+
let [ _; rep ] = Progress.Display.reporters display in
39
+
SC.iter_seq_p ~max_fibers
40
+
(fun ent ->
41
+
let w, h = SC.dims cfg Eio.Path.(dst_dir / Srcsetter.name ent) in
42
+
let variants =
43
+
Srcsetter.MS.bindings ent.variants
44
+
|> List.map (fun (k, _) -> (k, SC.dims cfg Eio.Path.(dst_dir / k)))
45
+
|> Srcsetter.MS.of_list
46
+
in
47
+
rep 1;
48
+
oents := { ent with Srcsetter.dims = (w, h); variants } :: !oents)
49
+
ents_seq;
50
+
Progress.Display.finalise display;
51
+
Printf.printf "[3/3] Verified %d generated image sizes.\n%!"
52
+
(List.length ents);
53
+
!oents
54
+
55
+
let _ =
56
+
(* TODO cmdliner *)
57
+
Eio_main.run @@ fun env ->
58
+
Eio.Switch.run @@ fun _ ->
59
+
let path_env p =
60
+
if String.starts_with ~prefix:"/" p then Eio.(Path.(Stdenv.fs env / p))
61
+
else Eio.(Path.(Stdenv.cwd env / p))
62
+
in
63
+
let src_dir = path_env "bushel/images" in
64
+
let dst_dir = path_env "site/images" in
65
+
let proc_mgr = Eio.Stdenv.process_mgr env in
66
+
let idx_file = "index.json" in
67
+
let img_widths =
68
+
[ 320; 480; 640; 768; 1024; 1280; 1440; 1600; 1920; 2560; 3840 ]
69
+
in
70
+
let img_exts = [ "png"; "webp"; "jpeg"; "jpg"; "bmp"; "heic"; "gif" ] in
71
+
let img_widths = List.sort (fun a b -> compare b a) img_widths in
72
+
let max_fibers = 8 in
73
+
let cfg =
74
+
{
75
+
Srcsetter_cmd.dummy = false;
76
+
preserve = true;
77
+
proc_mgr;
78
+
src_dir;
79
+
dst_dir;
80
+
idx_file;
81
+
img_widths;
82
+
img_exts;
83
+
max_fibers;
84
+
}
85
+
in
86
+
let fs = stage1 cfg in
87
+
let ents = stage2 cfg fs in
88
+
let oents = stage3 cfg ents in
89
+
let j = Srcsetter.list_to_json oents |> Result.get_ok in
90
+
let idx = Eio.Path.(dst_dir / idx_file) in
91
+
Eio.Path.save ~append:false ~create:(`Or_truncate 0o644) idx j
+21
dune-project
+21
dune-project
···
1
+
(lang dune 3.17)
2
+
(name srcsetter)
3
+
4
+
(generate_opam_files true)
5
+
6
+
(source (github avsm/srcsetter))
7
+
(license ISC)
8
+
(authors "Anil Madhavapeddy")
9
+
(maintainers "anil@recoil.org")
10
+
11
+
(package
12
+
(name srcsetter)
13
+
(description "Srcsetter is a library that allows for handling a directory of responsive images suitable for embedding as `<img srcset` tags in a website. It uses the ImageMagick CLI tool to handle the actual processing of images, and the `srcsetter-cmd` package to generate the input to this library.")
14
+
(synopsis "Image srcset library for webp images")
15
+
(depends jsont bytesrw pro))
16
+
17
+
(package
18
+
(name srcsetter-cmd)
19
+
(synopsis "Image processing tool to generate responsive images")
20
+
(description "Srcsetter is a CLI tool that processes a directory of images and outputs a directory of responsive images suitable for embedding as `<img srcset` tags in a website. It uses the ImageMagick CLI tool to handle the actual processing of images.")
21
+
(depends srcsetter fpath progress eio))
+11
lib/dune
+11
lib/dune
+37
lib/srcsetter.ml
+37
lib/srcsetter.ml
···
1
+
module MS = Map.Make (String)
2
+
3
+
type t = {
4
+
name : string;
5
+
slug : string;
6
+
origin : string;
7
+
dims : int * int;
8
+
variants : (int * int) MS.t;
9
+
}
10
+
11
+
let v name slug origin variants dims = { name; slug; origin; variants; dims }
12
+
let origin { origin; _ } = origin
13
+
let slug { slug; _ } = slug
14
+
let name { name; _ } = name
15
+
let dims { dims; _ } = dims
16
+
let variants { variants; _ } = variants
17
+
18
+
let dims_json_t =
19
+
let open Jsont in
20
+
let dec x y = (x, y) in
21
+
let enc (w, h) = function 0 -> w | _ -> h in
22
+
t2 ~dec ~enc uint16
23
+
24
+
let json_t =
25
+
let open Jsont in
26
+
let open Jsont.Object in
27
+
map ~kind:"Entry" v
28
+
|> mem "name" string ~enc:name
29
+
|> mem "slug" string ~enc:slug
30
+
|> mem "origin" string ~enc:origin
31
+
|> mem "variants" (as_string_map dims_json_t) ~enc:variants
32
+
|> mem "dims" dims_json_t ~enc:dims
33
+
|> finish
34
+
35
+
let list = Jsont.list json_t
36
+
let list_to_json es = Jsont_bytesrw.encode_string list ~format:Jsont.Indent es
37
+
let list_of_json = Jsont_bytesrw.decode_string list
+19
lib/srcsetter.mli
+19
lib/srcsetter.mli
···
1
+
module MS : Map.S with type key = string
2
+
3
+
type t = {
4
+
name : string;
5
+
slug : string;
6
+
origin : string;
7
+
dims : int * int;
8
+
variants : (int * int) MS.t;
9
+
}
10
+
11
+
val v : string -> string -> string -> (int * int) MS.t -> int * int -> t
12
+
val origin : t -> string
13
+
val name : t -> string
14
+
val dims : t -> int * int
15
+
val variants : t -> (int * int) MS.t
16
+
val list_to_json : t list -> (string, string) result
17
+
val list_of_json : string -> (t list, string) result
18
+
val json_t : t Jsont.t
19
+
val list : t list Jsont.t
+238
lib/srcsetter_cmd.ml
+238
lib/srcsetter_cmd.ml
···
1
+
open Eio
2
+
3
+
type ('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
+
15
+
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) ->
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
+
31
+
let 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
+
45
+
let 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
+
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))
57
+
58
+
let run { dummy; proc_mgr; _ } args =
59
+
if not dummy then Process.run proc_mgr args
60
+
61
+
let 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
+
90
+
let 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
+
113
+
let needed_sizes ~img_widths ~w = List.filter (fun tw -> tw <= w) img_widths
114
+
115
+
let 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
+
128
+
let 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
+
155
+
let 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
+
165
+
let main_bar_heading head total =
166
+
let open Progress.Multi in
167
+
line (Progress.Line.const head) ++ line (main_bar total) ++ blank
168
+
169
+
let 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
+
187
+
let 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
+33
srcsetter-cmd.opam
+33
srcsetter-cmd.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Image processing tool to generate responsive images"
4
+
description:
5
+
"Srcsetter is a CLI tool that processes a directory of images and outputs a directory of responsive images suitable for embedding as `<img srcset` tags in a website. It uses the ImageMagick CLI tool to handle the actual processing of images."
6
+
maintainer: ["anil@recoil.org"]
7
+
authors: ["Anil Madhavapeddy"]
8
+
license: "ISC"
9
+
homepage: "https://github.com/avsm/srcsetter"
10
+
bug-reports: "https://github.com/avsm/srcsetter/issues"
11
+
depends: [
12
+
"dune" {>= "3.17"}
13
+
"srcsetter"
14
+
"fpath"
15
+
"progress"
16
+
"eio"
17
+
"odoc" {with-doc}
18
+
]
19
+
build: [
20
+
["dune" "subst"] {dev}
21
+
[
22
+
"dune"
23
+
"build"
24
+
"-p"
25
+
name
26
+
"-j"
27
+
jobs
28
+
"@install"
29
+
"@runtest" {with-test}
30
+
"@doc" {with-doc}
31
+
]
32
+
]
33
+
dev-repo: "git+https://github.com/avsm/srcsetter.git"
+32
srcsetter.opam
+32
srcsetter.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Image srcset library for webp images"
4
+
description:
5
+
"Srcsetter is a library that allows for handling a directory of responsive images suitable for embedding as `<img srcset` tags in a website. It uses the ImageMagick CLI tool to handle the actual processing of images, and the `srcsetter-cmd` package to generate the input to this library."
6
+
maintainer: ["anil@recoil.org"]
7
+
authors: ["Anil Madhavapeddy"]
8
+
license: "ISC"
9
+
homepage: "https://github.com/avsm/srcsetter"
10
+
bug-reports: "https://github.com/avsm/srcsetter/issues"
11
+
depends: [
12
+
"dune" {>= "3.17"}
13
+
"jsont"
14
+
"bytesrw"
15
+
"pro"
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "git+https://github.com/avsm/srcsetter.git"