diff --git a/src/linuxkit_build.ml b/src/linuxkit_build.ml index 4276823..8f18331 100644 --- a/src/linuxkit_build.ml +++ b/src/linuxkit_build.ml @@ -2,6 +2,9 @@ open Datakit_ci open Lwt.Infix open! Astring +let src = Logs.Src.create "linuxkit-build" ~doc:"LinuxKit CI builder" +module Log = (val Logs.src_log src : Logs.LOG) + let builder_ssh_key = "/run/secrets/builder-ssh" type error_pattern = { @@ -130,6 +133,41 @@ end = struct | Some (_, msg) -> Some msg end +let rec copy_to_transaction ~trans ~dir srcdir = + let ( / ) = Datakit_path.Infix.( / ) in + Utils.ls srcdir + >>= Lwt_list.iter_s (function + | "." | ".." -> Lwt.return () + | item -> + let dk_path = dir / item in + let path = Filename.concat srcdir item in + Lwt_unix.lstat path >>= fun info -> + match info.Lwt_unix.st_kind with + | Lwt_unix.S_REG -> + Log.debug (fun f -> f "Copying %S to results..." item); + Lwt_io.with_file ~mode:Lwt_io.input path (fun ch -> Lwt_io.read ch) >>= fun data -> + DK.Transaction.create_file trans dk_path (Cstruct.of_string data) >>*= Lwt.return + | Lwt_unix.S_DIR -> + DK.Transaction.create_dir trans dk_path >>*= fun () -> + let open! Datakit_path.Infix in + copy_to_transaction ~trans ~dir:dk_path (Filename.concat srcdir item) + | _ -> + Log.warn (fun f -> f "Ignoring non-file entry %S" item); + Lwt.return () + ) + +let storing_logs ~log ~tmpdir ~trans fn () = + Lwt.finalize fn + (fun () -> + let results_dir = tmpdir / "_results" in + if Sys.is_directory results_dir then + copy_to_transaction ~trans ~dir:Cache.Path.value results_dir + else ( + Live_log.log log "Results directory %S not found, so not saving" results_dir; + Lwt.return_unit + ) + ) + module Builder = struct module Key = struct type t = { @@ -165,7 +203,8 @@ module Builder = struct Live_log.log log "Created new VM %a" Gcp.pp_vm vm; f ip - let build_in_vm ~switch ~log ~ip ~src ~output ~best_error = + let build_in_vm ~switch ~log ~ip ~tmpdir ~output ~best_error = + let src = tmpdir / "src" in let to_ssh, from_tar = Unix.pipe () in let tar_cmd = ("", [| "git"; "archive"; "--format=tar"; "HEAD" |]) in Lwt_mutex.with_lock Datakit_ci.Utils.chdir_lock (fun () -> @@ -181,30 +220,52 @@ module Builder = struct (* StrictHostKeyChecking=no isn't ideal, but this appears to be what "gcloud ssh" does anyway. *) let cmd = ("", [| "ssh"; "-i"; builder_ssh_key; "-o"; "StrictHostKeyChecking=no"; "root@" ^ ip; "/usr/local/bin/test.sh" |]) in - Datakit_ci.Process.run ~switch ~log ~stdin ~output cmd >|= fun () -> - Error_finder.reset best_error + Lwt.catch + (fun () -> + Datakit_ci.Process.run ~switch ~log ~stdin ~output cmd >|= fun () -> + Error_finder.reset best_error; + Ok () + ) + (fun ex -> Lwt.return (Error ex)) ) (fun () -> tar#terminate; tar#status >|= Datakit_ci.Process.check_status tar_cmd ) - >>= fun () -> + >>= fun status -> + let targets = + Fmt.strf "root@%s:/tmp/build/test/_results" ip :: + ( + match status with + | Ok () -> [Fmt.strf "root@%s:/tmp/build/artifacts" ip] + | Error _ -> [] + ) + in let cmd = [ "scp"; "-r"; "-i"; builder_ssh_key; - "-o"; "StrictHostKeyChecking=no"; - Fmt.strf "root@%s:/tmp/build/artifacts" ip; + "-o"; "StrictHostKeyChecking=no" + ] @ targets @ [ "." ] in Live_log.log log "Fetching results"; let output = Live_log.write log in Lwt.catch - (fun () -> Process.run ~cwd:src ~log ~switch ~output ("", Array.of_list cmd)) + (fun () -> + Process.run ~cwd:tmpdir ~log ~switch ~output ("", Array.of_list cmd) >>= fun () -> + match status with + | Ok () -> Lwt.return () + | Error ex -> Lwt.fail ex + ) (fun ex -> Live_log.log log "Error fetching results: %a" Fmt.exn ex; - Utils.failf "Failed to fetch %a" - Fmt.(list ~sep:(const string ",") string) outputs + match status with + | Ok () -> + Utils.failf "Failed to fetch %a" + Fmt.(list ~sep:(const string ",") string) outputs + | Error ex -> + Lwt.fail ex ) let generate t ~switch ~log trans job_id key = @@ -231,11 +292,11 @@ module Builder = struct Live_log.write log x in Lwt.catch - (fun () -> + (storing_logs ~log ~tmpdir ~trans (fun () -> Utils.with_timeout ~switch build_timeout @@ fun switch -> match target with | `PR _ -> - with_vm t.vms ~switch ~log (fun ip -> build_in_vm ~switch ~log ~ip ~src:src_dir ~output ~best_error) + with_vm t.vms ~switch ~log (fun ip -> build_in_vm ~switch ~log ~ip ~tmpdir ~output ~best_error) | `Ref _ -> let make_target, tag_name = make_target target in let extra_args = @@ -248,16 +309,18 @@ module Builder = struct with_child_switch switch (fun switch -> Gcp.allocate_vm_name ~log ~switch t.vms >>= fun test_vm -> let cmd = "make" :: make_target :: ("CLOUDSDK_IMAGE_NAME=" ^ test_vm.Gcp.name) :: extra_args in - Process.run ~cwd:src_dir ~log ~switch ~output ("", Array.of_list cmd) + Process.run ~cwd:src_dir ~log ~switch ~output ("", Array.of_list cmd) >|= fun () -> + Unix.rename (src_dir / "artifacts") (tmpdir / "artifacts"); + Unix.rename (src_dir / "test/_results") (tmpdir / "_results"); ) - ) + )) (fun ex -> match Error_finder.best best_error with | None -> Lwt.fail ex | Some msg -> Lwt.fail_with msg ) >>= fun () -> - let artifacts_dir = src_dir / "artifacts" in + let artifacts_dir = tmpdir / "artifacts" in let results = ref String.Map.empty in outputs |> Lwt_list.iter_s (fun output_name -> Disk_cache.add t.results (artifacts_dir / output_name) >|= fun hash ->