jon.recoil.org
A fork of mtelver's day10 project
Network handling plus improved hardlink copy
+23
-8
bin/main.ml
+23
-8
bin/main.ml
···
10
package : string;
11
directory : string option;
12
md : string option;
13
}
14
15
let hostname = "builder"
16
-
let network = "35b0b92b-d2a7-429b-92ad-4671880d25f2"
17
18
let env =
19
[
···
109
let mounts_json = Os.path [ temp_dir; "mounts.json" ] in
110
let _ = Os.retry_exec ~stdout:mounts_json [ "ctr"; "snapshot"; "prepare"; "--mounts"; Filename.basename temp_dir; "sha256:6f75278129ccaff6084617218cb8a28e8acc1748beeaae2946dfa92c5ca425ee" ] in
111
let layers = Json_layers.read_layers mounts_json in
112
-
let config = Json_config.make_ctr ~layers ~cwd:"c:\\" ~argv ~hostname ~uid:0 ~gid:0 ~env:win_env ~mounts ~network in
113
let config_json = Os.path [ temp_dir; "config.json" ] in
114
let () = Os.write_to_file config_json (Yojson.Safe.pretty_to_string config) in
115
let result = Os.exec ~stdout:build_log ~stderr:build_log [ "ctr"; "run"; "--cni"; "--rm"; "--config"; config_json; Filename.basename temp_dir ] in
116
let _ = Os.rm (Os.path [ rootfs; "repo"; "state-33BF9E46.cache" ] ) in
117
-
let _ = Os.rm (Os.path [ rootfs; "default"; ".opam-switch"; "lock" ] ) in
118
let () = Os.write_to_file (Os.path [ temp_dir; "status" ]) (string_of_int result) in
119
let _ = Os.exec [ "ctr"; "snapshot"; "rm"; Filename.basename temp_dir ] in
120
Unix.rename temp_dir target_dir
···
372
let mounts_json = Os.path [ temp_dir; "mounts.json" ] in
373
let _ = Os.retry_exec ~stdout:mounts_json [ "ctr"; "snapshot"; "prepare"; "--mounts"; Filename.basename temp_dir; "sha256:6f75278129ccaff6084617218cb8a28e8acc1748beeaae2946dfa92c5ca425ee" ] in
374
let layers = Json_layers.read_layers mounts_json in
375
-
let config = Json_config.make_ctr ~layers ~cwd:"c:\\" ~argv ~hostname ~uid:0 ~gid:0 ~env:win_env ~mounts ~network in
376
let config_json = Os.path [ temp_dir; "config.json" ] in
377
let () = Os.write_to_file config_json (Yojson.Safe.pretty_to_string config) in
378
let result = Os.exec ~stdout:build_log ~stderr:build_log [ "ctr"; "run"; "--cni"; "--rm"; "--config"; config_json; Filename.basename temp_dir ] in
···
405
406
let build config ocaml_version package =
407
let solution = solve config ocaml_version package in
408
-
let _ = Dot_solution.save ((OpamPackage.to_string package) ^ ".dot") solution in
409
if OpamPackage.Map.is_empty solution then
410
[ No_solution ]
411
else
412
let ordered_installation = topological_sort solution in
413
let dependencies = pkg_deps solution ordered_installation in
414
let solution = reduce dependencies solution in
415
-
let _ = Dot_solution.save ((OpamPackage.to_string package) ^ ".reduced.dot") solution in
416
List.fold_left
417
(fun lst pkg ->
418
match lst with
···
467
let run_ci config =
468
init config;
469
let package = OpamPackage.of_string (config.package ^ ".dev") in
470
let results = build config ocaml_version package in
471
output config results
472
473
let run_health_check config =
474
init config;
475
let package = OpamPackage.of_string config.package in
476
let results = build config ocaml_version package in
477
output config results
478
479
let cache_dir_term =
···
501
in
502
let ci_term =
503
Term.(
504
-
const (fun dir opam_repository directory md -> run_ci { dir; opam_repository; package = List.hd (find_opam_files directory); directory = Some directory; md })
505
$ cache_dir_term $ opam_repository_term $ directory_arg $ md_term)
506
in
507
let ci_info = Cmd.info "ci" ~doc:"Run CI tests on a directory" in
···
514
in
515
let health_check_term =
516
Term.(
517
-
const (fun dir opam_repository package md -> run_health_check { dir; opam_repository; package; directory = None; md })
518
$ cache_dir_term $ opam_repository_term $ package_arg $ md_term)
519
in
520
let health_check_info = Cmd.info "health-check" ~doc:"Run health check on a package" in
···
10
package : string;
11
directory : string option;
12
md : string option;
13
+
network : string option;
14
}
15
16
let hostname = "builder"
17
+
18
+
let create_network () = match Sys.win32 with
19
+
| true -> Os.run "hcn-namespace create" |> String.trim
20
+
| false -> ""
21
+
22
+
let delete_network = function
23
+
| Some n -> Os.exec ["hcn-namespace"; "delete"; n]
24
+
| None -> 0
25
26
let env =
27
[
···
117
let mounts_json = Os.path [ temp_dir; "mounts.json" ] in
118
let _ = Os.retry_exec ~stdout:mounts_json [ "ctr"; "snapshot"; "prepare"; "--mounts"; Filename.basename temp_dir; "sha256:6f75278129ccaff6084617218cb8a28e8acc1748beeaae2946dfa92c5ca425ee" ] in
119
let layers = Json_layers.read_layers mounts_json in
120
+
let config = Json_config.make_ctr ~layers ~cwd:"c:\\" ~argv ~hostname ~uid:0 ~gid:0 ~env:win_env ~mounts ~network:(Option.value ~default:"" config.network) in
121
let config_json = Os.path [ temp_dir; "config.json" ] in
122
let () = Os.write_to_file config_json (Yojson.Safe.pretty_to_string config) in
123
let result = Os.exec ~stdout:build_log ~stderr:build_log [ "ctr"; "run"; "--cni"; "--rm"; "--config"; config_json; Filename.basename temp_dir ] in
124
+
let _ = Os.rm (Os.path [ rootfs; "lock" ] ) in
125
+
let _ = Os.rm (Os.path [ rootfs; "conf.lock" ] ) in
126
+
let _ = Os.rm (Os.path [ rootfs; "default"; ".opam-switch"; "lock" ] ) in
127
let _ = Os.rm (Os.path [ rootfs; "repo"; "state-33BF9E46.cache" ] ) in
128
+
let _ = Os.rm (Os.path [ rootfs; "repo"; "conf.lock" ] ) in
129
let () = Os.write_to_file (Os.path [ temp_dir; "status" ]) (string_of_int result) in
130
let _ = Os.exec [ "ctr"; "snapshot"; "rm"; Filename.basename temp_dir ] in
131
Unix.rename temp_dir target_dir
···
383
let mounts_json = Os.path [ temp_dir; "mounts.json" ] in
384
let _ = Os.retry_exec ~stdout:mounts_json [ "ctr"; "snapshot"; "prepare"; "--mounts"; Filename.basename temp_dir; "sha256:6f75278129ccaff6084617218cb8a28e8acc1748beeaae2946dfa92c5ca425ee" ] in
385
let layers = Json_layers.read_layers mounts_json in
386
+
let config = Json_config.make_ctr ~layers ~cwd:"c:\\" ~argv ~hostname ~uid:0 ~gid:0 ~env:win_env ~mounts ~network:(Option.value ~default:"" config.network) in
387
let config_json = Os.path [ temp_dir; "config.json" ] in
388
let () = Os.write_to_file config_json (Yojson.Safe.pretty_to_string config) in
389
let result = Os.exec ~stdout:build_log ~stderr:build_log [ "ctr"; "run"; "--cni"; "--rm"; "--config"; config_json; Filename.basename temp_dir ] in
···
416
417
let build config ocaml_version package =
418
let solution = solve config ocaml_version package in
419
+
(* let _ = Dot_solution.save ((OpamPackage.to_string package) ^ ".dot") solution in *)
420
if OpamPackage.Map.is_empty solution then
421
[ No_solution ]
422
else
423
let ordered_installation = topological_sort solution in
424
let dependencies = pkg_deps solution ordered_installation in
425
let solution = reduce dependencies solution in
426
+
(* let _ = Dot_solution.save ((OpamPackage.to_string package) ^ ".reduced.dot") solution in *)
427
List.fold_left
428
(fun lst pkg ->
429
match lst with
···
478
let run_ci config =
479
init config;
480
let package = OpamPackage.of_string (config.package ^ ".dev") in
481
+
let config = { config with network = Some (create_network ()) } in
482
let results = build config ocaml_version package in
483
+
let _ = delete_network config.network in
484
output config results
485
486
let run_health_check config =
487
init config;
488
let package = OpamPackage.of_string config.package in
489
+
let config = { config with network = Some (create_network ()) } in
490
let results = build config ocaml_version package in
491
+
let _ = delete_network config.network in
492
output config results
493
494
let cache_dir_term =
···
516
in
517
let ci_term =
518
Term.(
519
+
const (fun dir opam_repository directory md -> run_ci { dir; opam_repository; package = List.hd (find_opam_files directory); directory = Some directory; md; network = None })
520
$ cache_dir_term $ opam_repository_term $ directory_arg $ md_term)
521
in
522
let ci_info = Cmd.info "ci" ~doc:"Run CI tests on a directory" in
···
529
in
530
let health_check_term =
531
Term.(
532
+
const (fun dir opam_repository package md -> run_health_check { dir; opam_repository; package; directory = None; md; network = None })
533
$ cache_dir_term $ opam_repository_term $ package_arg $ md_term)
534
in
535
let health_check_info = Cmd.info "health-check" ~doc:"Run health check on a package" in
+63
-5
bin/os.ml
+63
-5
bin/os.ml
···
90
try Unix.unlink lock_file with
91
| _ -> ()
92
93
let hardlink_tree ~source ~target =
94
let rec process_directory current_source current_target =
95
let entries = Sys.readdir current_source in
···
97
let source = Filename.concat current_source entry in
98
let target = Filename.concat current_target entry in
99
try
100
-
let stat = Unix.stat source in
101
match stat.st_kind with
102
-
| Unix.S_LNK
103
| Unix.S_REG ->
104
if not (Sys.file_exists target) then
105
Unix.link source target
106
| Unix.S_DIR ->
107
mkdir target;
108
process_directory source target
109
-
| _ ->
110
()
111
with
112
-
| Unix.Unix_error _ ->
113
-
()
114
) entries
115
in
116
process_directory source target
···
90
try Unix.unlink lock_file with
91
| _ -> ()
92
93
+
exception Copy_error of string
94
+
95
+
let cp ?(buffer_size = 65536) ?(preserve_permissions = true) ?(preserve_times = true) src dst =
96
+
let safe_close fd = try Unix.close fd with _ -> () in
97
+
let src_stats =
98
+
try Unix.stat src
99
+
with Unix.Unix_error (err, _, _) ->
100
+
raise (Copy_error (Printf.sprintf "Cannot stat source file '%s': %s" src (Unix.error_message err)))
101
+
in
102
+
if src_stats.st_kind <> S_REG then
103
+
raise (Copy_error (Printf.sprintf "Source '%s' is not a regular file" src));
104
+
let src_fd =
105
+
try Unix.openfile src [O_RDONLY] 0
106
+
with Unix.Unix_error (err, _, _) ->
107
+
raise (Copy_error (Printf.sprintf "Cannot open source file '%s': %s" src (Unix.error_message err)))
108
+
in
109
+
let dst_fd =
110
+
try Unix.openfile dst [O_WRONLY; O_CREAT; O_TRUNC] src_stats.st_perm
111
+
with Unix.Unix_error (err, _, _) ->
112
+
safe_close src_fd;
113
+
raise (Copy_error (Printf.sprintf "Cannot open destination file '%s': %s" dst (Unix.error_message err)))
114
+
in
115
+
let buffer = Bytes.create buffer_size in
116
+
let rec copy_loop () =
117
+
try
118
+
match (Unix.read src_fd buffer 0 buffer_size) with
119
+
| 0 -> ()
120
+
| bytes_read ->
121
+
let rec write_all pos remaining =
122
+
if remaining > 0 then
123
+
let bytes_written = Unix.write dst_fd buffer pos remaining in
124
+
write_all (pos + bytes_written) (remaining - bytes_written)
125
+
in
126
+
write_all 0 bytes_read;
127
+
copy_loop ()
128
+
with Unix.Unix_error (err, _, _) ->
129
+
safe_close src_fd;
130
+
safe_close dst_fd;
131
+
raise (Copy_error (Printf.sprintf "Error during copy: %s" (Unix.error_message err)))
132
+
in
133
+
copy_loop ();
134
+
safe_close src_fd;
135
+
safe_close dst_fd;
136
+
if preserve_permissions then begin
137
+
try Unix.chmod dst src_stats.st_perm
138
+
with Unix.Unix_error (err, _, _) ->
139
+
Printf.eprintf "Warning: Could not preserve permissions: %s\n" (Unix.error_message err)
140
+
end;
141
+
if preserve_times then begin
142
+
try Unix.utimes dst src_stats.st_atime src_stats.st_mtime
143
+
with Unix.Unix_error (err, _, _) ->
144
+
Printf.eprintf "Warning: Could not preserve timestamps: %s\n" (Unix.error_message err)
145
+
end
146
+
147
let hardlink_tree ~source ~target =
148
let rec process_directory current_source current_target =
149
let entries = Sys.readdir current_source in
···
151
let source = Filename.concat current_source entry in
152
let target = Filename.concat current_target entry in
153
try
154
+
let stat = Unix.lstat source in
155
match stat.st_kind with
156
+
| Unix.S_LNK ->
157
+
if not (Sys.file_exists target) then
158
+
Unix.symlink (Unix.readlink source) target
159
| Unix.S_REG ->
160
if not (Sys.file_exists target) then
161
Unix.link source target
162
| Unix.S_DIR ->
163
mkdir target;
164
process_directory source target
165
+
| S_CHR | S_BLK | S_FIFO | S_SOCK ->
166
()
167
with
168
+
| Unix.Unix_error (Unix.EMLINK, _, _) ->
169
+
cp source target
170
+
| Unix.Unix_error (err, _, _) ->
171
+
Printf.eprintf "Warning: %s -> %s = %s\n" source target (Unix.error_message err);
172
) entries
173
in
174
process_directory source target