forked from ocurrent/obuilder
-
Notifications
You must be signed in to change notification settings - Fork 0
/
main.ml
240 lines (208 loc) · 7.64 KB
/
main.ml
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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
open Lwt.Infix
let ( / ) = Filename.concat
module Native_sandbox = Obuilder.Native_sandbox
module Docker_sandbox = Obuilder.Docker_sandbox
module Docker_store = Obuilder.Docker_store
module Docker_extract = Obuilder.Docker_extract
module Archive_extract = Obuilder.Archive_extract
module Store_spec = Obuilder.Store_spec
type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder
let log tag msg =
match tag with
| `Heading -> Fmt.pr "%a@." Fmt.(styled (`Fg (`Hi `Blue)) string) msg
| `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg
| `Output -> output_string stdout msg; flush stdout
let create_builder env store_spec conf =
let (module Fetcher) =
Obuilder.Container_image_extract.make_fetcher
~progress:true
~fs:(Eio.Stdenv.fs env)
~net:(Eio.Stdenv.net env)
(Eio.Stdenv.domain_mgr env)
in
store_spec >>= fun (Store_spec.Store ((module Store), store)) ->
let module Builder = Obuilder.Builder (Store) (Native_sandbox) (Fetcher) in
Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox ->
let builder = Builder.v ~store ~sandbox in
Builder ((module Builder), builder)
let create_docker_builder store_spec conf =
store_spec >>= fun (Store_spec.Store ((module Store), store)) ->
let module Builder = Obuilder.Docker_builder (Store) in
Docker_sandbox.create conf >|= fun sandbox ->
let builder = Builder.v ~store ~sandbox in
Builder ((module Builder), builder)
let read_whole_file path =
let ic = open_in_bin path in
Fun.protect ~finally:(fun () -> close_in ic) @@ fun () ->
let len = in_channel_length ic in
really_input_string ic len
let select_backend env (sandbox, store_spec) native_conf docker_conf =
match sandbox with
| `Native -> create_builder env store_spec native_conf
| `Docker -> create_docker_builder store_spec docker_conf
let build env () store spec native_conf docker_conf src_dir secrets =
Lwt_main.run begin
select_backend env store native_conf docker_conf
>>= fun (Builder ((module Builder), builder)) ->
Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
let spec =
try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec)
with Failure msg ->
print_endline msg;
exit 1
in
let secrets = List.map (fun (id, path) -> id, read_whole_file path) secrets in
let context = Obuilder.Context.v ~log ~src_dir ~secrets () in
Builder.build builder context spec >>= function
| Ok x ->
Fmt.pr "Got: %S@." (x :> string);
Lwt.return_unit
| Error `Cancelled ->
Fmt.epr "Cancelled at user's request@.";
exit 1
| Error (`Msg m) ->
Fmt.epr "Build step failed: %s@." m;
exit 1
end
let run env () (_, store) conf id =
Lwt_main.run begin
create_builder env store conf >>= fun (Builder ((module Builder), builder)) ->
Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
let _, v = Builder.shell builder id in
v >>= fun v -> match v with
| Ok _ -> Lwt.return_unit
| Error `Cancelled ->
Fmt.epr "Cancelled at user's request@.";
exit 1
| Error (`Msg m) ->
Fmt.epr "Build step failed: %s@." m;
exit 1
end
let healthcheck env () store native_conf docker_conf =
Lwt_main.run begin
select_backend env store native_conf docker_conf
>>= fun (Builder ((module Builder), builder)) ->
Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
Builder.healthcheck builder >|= function
| Error (`Msg m) ->
Fmt.epr "Healthcheck failed: %s@." m;
exit 1
| Ok () ->
Fmt.pr "Healthcheck passed@."
end
let delete env () store native_conf docker_conf id =
Lwt_main.run begin
select_backend env store native_conf docker_conf
>>= fun (Builder ((module Builder), builder)) ->
Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id)
end
let clean env () store native_conf docker_conf =
Lwt_main.run begin
select_backend env store native_conf docker_conf
>>= fun (Builder ((module Builder), builder)) ->
Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ begin fun () ->
let now = Unix.(gmtime (gettimeofday ())) in
Builder.prune builder ~before:now max_int ~log:(fun id -> Fmt.pr "Removing %s@." id)
end >|= fun n ->
Fmt.pr "Removed %d items@." n
end
let dockerfile () buildkit escape spec =
Sexplib.Sexp.load_sexp spec
|> Obuilder_spec.t_of_sexp
|> Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:escape
|> print_endline
open Cmdliner
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.Src.set_level Obuilder.log_src level;
Logs.set_reporter (Logs_fmt.reporter ());
()
let setup_log =
let docs = Manpage.s_common_options in
Term.(const setup_log $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ())
let spec_file =
Arg.required @@
Arg.opt Arg.(some file) None @@
Arg.info
~doc:"Path of build spec file."
~docv:"FILE"
["f"]
let src_dir =
Arg.required @@
Arg.pos 0 Arg.(some dir) None @@
Arg.info
~doc:"Directory containing the source files."
~docv:"DIR"
[]
let store = Store_spec.cmdliner
let id =
Arg.required @@
Arg.pos 0 Arg.(some string) None @@
Arg.info
~doc:"The $(i,ID) of a build within the store."
~docv:"ID"
[]
let secrets =
(Arg.value @@
Arg.(opt_all (pair ~sep:':' string file)) [] @@
Arg.info
~doc:"Provide a secret under the form $(b,id:file)."
~docv:"SECRET"
["secret"])
let build env =
let doc = "Build a spec file." in
let info = Cmd.info "build" ~doc in
Cmd.v info
Term.(const (build env) $ setup_log $ store $ spec_file $ Native_sandbox.cmdliner
$ Docker_sandbox.cmdliner $ src_dir $ secrets)
let delete env =
let doc = "Recursively delete a cached build result." in
let info = Cmd.info "delete" ~doc in
Cmd.v info
Term.(const (delete env) $ setup_log $ store $ Native_sandbox.cmdliner
$ Docker_sandbox.cmdliner $ id)
let clean env =
let doc = "Clean all cached build results." in
let info = Cmd.info "clean" ~doc in
Cmd.v info
Term.(const (clean env) $ setup_log $ store $ Native_sandbox.cmdliner
$ Docker_sandbox.cmdliner)
let buildkit =
Arg.value @@
Arg.flag @@
Arg.info
~doc:"Output extended BuildKit syntax."
["buildkit"]
let escape =
let styles = [("unix", `Unix); ("windows", `Windows)] in
let doc = Arg.doc_alts_enum styles |> Printf.sprintf "Dockerfile escape style, must be %s." in
Arg.value @@
Arg.opt Arg.(enum styles) (if Sys.unix then `Unix else `Windows) @@
Arg.info ~doc
~docv:"STYLE"
["escape"]
let dockerfile =
let doc = "Convert a spec to Dockerfile format." in
let info = Cmd.info ~doc "dockerfile" in
Cmd.v info
Term.(const dockerfile $ setup_log $ buildkit $ escape $ spec_file)
let healthcheck env =
let doc = "Perform a self-test" in
let info = Cmd.info "healthcheck" ~doc in
Cmd.v info
Term.(const (healthcheck env) $ setup_log $ store $ Native_sandbox.cmdliner
$ Docker_sandbox.cmdliner)
let run env =
let doc = "Run a shell inside a container" in
let info = Cmd.info "run" ~doc in
Cmd.v info
Term.(const (run env) $ setup_log $ store $ Native_sandbox.cmdliner $ id)
let cmds env = [build env; run env; delete env; clean env; dockerfile; healthcheck env]
let () =
Eio_main.run @@ fun env ->
Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
let doc = "a command-line interface for OBuilder" in
let info = Cmd.info ~doc "obuilder" in
exit (Cmd.eval @@ Cmd.group info (cmds env))