1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
type ctx = {
user : Spec.user;
}
let default_ctx = {
user = Spec.root;
}
let pp_pair f (k, v) =
Fmt.pf f "%s=%s" k v
let pp_wrap =
Fmt.using (String.split_on_char '\n')
Fmt.(list ~sep:(unit " \\@\n ") (using String.trim string))
let pp_cache ~ctx f { Cache.id; target; buildkit_options } =
let buildkit_options =
("--mount=type", "cache") ::
("id", id) ::
("target", target) ::
("uid", string_of_int ctx.user.uid) ::
buildkit_options
in
Fmt.pf f "%a" Fmt.(list ~sep:(unit ",") pp_pair) buildkit_options
let pp_run ~ctx f { Spec.cache; shell; network = _ } =
Fmt.pf f "RUN %a%a" Fmt.(list (pp_cache ~ctx ++ const string " ")) cache pp_wrap shell
let pp_copy ~ctx f { Spec.from; src; dst; exclude = _ } =
let from = match from with
| `Build name -> Some name
| `Context -> None
in
let chown =
if ctx.user = Spec.root then None
else (
let { Spec.uid; gid } = ctx.user in
Some (Printf.sprintf "%d:%d" uid gid)
)
in
Fmt.pf f "COPY %a%a%a %s"
Fmt.(option (fmt "--chown=%s ")) chown
Fmt.(option (fmt "--from=%s ")) from
Fmt.(list ~sep:sp string) src
dst
let pp_op ~buildkit ctx f : Spec.op -> ctx = function
| `Comment x -> Fmt.pf f "# %s" x; ctx
| `Workdir x -> Fmt.pf f "WORKDIR %s" x; ctx
| `Shell xs -> Fmt.pf f "SHELL [ %a ]" Fmt.(list ~sep:comma (quote string)) xs; ctx
| `Run x when buildkit -> pp_run ~ctx f x; ctx
| `Run x -> pp_run ~ctx f { x with cache = [] }; ctx
| `Copy x -> pp_copy ~ctx f x; ctx
| `User ({ uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u }
| `Env (k, v) -> Fmt.pf f "ENV %s %s" k v; ctx
let rec convert ~buildkit f (name, { Spec.child_builds; from; ops }) =
child_builds |> List.iter (fun (name, spec) ->
convert ~buildkit f (Some name, spec);
Format.pp_print_newline f ();
);
Fmt.pf f "@[<h>FROM %s%a@]@." from Fmt.(option (const string " as " ++ string)) name;
let (_ : ctx) = List.fold_left (fun ctx op ->
Format.pp_open_hbox f ();
let ctx = pp_op ~buildkit ctx f op in
Format.pp_close_box f ();
Format.pp_print_newline f ();
ctx
) default_ctx ops
in ()
let dockerfile_of_spec ~buildkit t =
Fmt.strf "%a" (convert ~buildkit) (None, t)