Docker & Windows prerequisites

.github/workflows/main.yml

@@ -93,3 +93,27 @@ jobs:
           sudo wget https://github.com/opencontainers/runc/releases/download/$RUNC_VERSION/runc.amd64 -O /usr/local/bin/runc
 
       - run: ./.run-gha-tests.sh rsync
+
+  windows:
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - windows-latest
+        ocaml-compiler:
+          - 4.14.x
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v3
+
+      - name: Use OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v2
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+
+      - run: opam install . --deps-only --with-test
+
+      - run: opam exec -- dune build

dune-project

@@ -23,13 +23,11 @@
   sexplib
   ppx_deriving
   ppx_sexp_conv
-  sha
+  (sha (>= 1.15.1))
   sqlite3
   (obuilder-spec (= :version))
-  (ocaml (>= 4.10.0))
-  (alcotest-lwt :with-test))
- (conflicts
-  (result (< "1.5"))))
+  (ocaml (>= 4.14.0))
+  (alcotest-lwt :with-test)))
 (package
  (name obuilder-spec)
  (synopsis "Build specification format")

example.spec

@@ -7,11 +7,11 @@
 ; The result can then be found in /tank/HASH/rootfs/ (where HASH is displayed at the end of the build).
 
 ((build dev
-	((from ocaml/opam@sha256:5b9de826b22c77a0654519d0959536f93a6ffd7020712a8b1c3437445e031e04)
+	((from ocaml/opam@sha256:00f4d3f38bbde3a7a28b1b4b8994eded60fb5ee78822082f425662b7f9463178)
 	 (workdir /src)
 	 (user (uid 1000) (gid 1000))                           ; Build as the "opam" user
 	 (run (shell "sudo chown opam /src"))
-	 (env OPAM_HASH "97da9a1b68b824a65a09e5f7d071fcf2da35bd1b") ; Fix the version of opam-repository we want
+	 (env OPAM_HASH "3a3d0c18daa25274d5ab6a2e343c99023b3b07aa") ; Fix the version of opam-repository we want
 	 (run
 	  (network host)
 	  (shell "sudo apt-get --allow-releaseinfo-change update"))

lib/build.ml

@@ -78,11 +78,11 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
              cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } ->
                  Store.cache ~user t.store id >|= fun (src, release) ->
                  to_release := release :: !to_release;
-                 { Config.Mount.src; dst = target }
+                 { Config.Mount.src; dst = target; readonly = false }
                )
              >>= fun mounts ->
              let argv = shell @ [cmd] in
-             let config = Config.v ~cwd:workdir ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network in
+             let config = Config.v ~cwd:workdir ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network () in
              Os.with_pipe_to_child @@ fun ~r:stdin ~w:close_me ->
              Lwt_unix.close close_me >>= fun () ->
              Sandbox.run ~cancelled ~stdin ~log t.sandbox config result_tmp
@@ -150,6 +150,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
               ~mount_secrets:[]
               ~mounts:[]
               ~network:[]
+              ()
           in
           Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar ->
           let proc = Sandbox.run ~cancelled ~stdin:from_us ~log t.sandbox config result_tmp in
@@ -304,4 +305,8 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
   let v ~store ~sandbox =
     let store = Store.wrap store in
     { store; sandbox }
+
+  let finish t =
+    Store.unwrap t.store;
+    Lwt.return_unit
 end

lib/config.ml

@@ -9,6 +9,7 @@ module Mount = struct
   type t = { (* TODO: options *)
     src : string;              (* In host namespace *)
     dst : string;              (* In container namespace *)
+    readonly : bool;
   }
 end
 
@@ -28,7 +29,8 @@ type t = {
   mounts : Mount.t list;
   network : string list;
   mount_secrets : Secret.t list;
+  entrypoint : string option;
 }
 
-let v ~cwd ~argv ~hostname ~user ~env ~mounts ~network ~mount_secrets =
-  { cwd; argv; hostname; user; env; mounts; network; mount_secrets }
+let v ~cwd ~argv ~hostname ~user ~env ~mounts ~network ~mount_secrets ?entrypoint () =
+  { cwd; argv; hostname; user; env; mounts; network; mount_secrets; entrypoint; }

lib/dao.ml

@@ -25,9 +25,9 @@ let create db =
                        rc       INTEGER NOT NULL,
                        parent   TEXT,
                        FOREIGN KEY (parent) REFERENCES builds (id) ON DELETE RESTRICT
-                     ) |} |> Db.or_fail ~cmd:"create builds";
+                     ) |} |> Db.or_fail db ~cmd:"create builds";
   Sqlite3.exec db {| CREATE INDEX IF NOT EXISTS lru
-                     ON builds (rc, used) |} |> Db.or_fail ~cmd:"create lru index";
+                     ON builds (rc, used) |} |> Db.or_fail db ~cmd:"create lru index";
   let begin_transaction = Sqlite3.prepare db "BEGIN TRANSACTION" in
   let commit = Sqlite3.prepare db "COMMIT" in
   let rollback = Sqlite3.prepare db {| ROLLBACK |} in
@@ -44,30 +44,30 @@ let create db =
   { db; begin_transaction; commit; rollback; add; set_used; update_rc; exists; children; delete; lru; parent }
 
 let with_transaction t fn =
-  Db.exec t.begin_transaction [];
+  Db.exec t.db t.begin_transaction [];
   match fn () with
-  | x -> Db.exec t.commit []; x
-  | exception ex -> Db.exec t.rollback []; raise ex
+  | x -> Db.exec t.db t.commit []; x
+  | exception ex -> Db.exec t.db t.rollback []; raise ex
 
 let add ?parent ~id ~now t =
   let now = format_timestamp now in
   match parent with
-  | None -> Db.exec t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; NULL ];
+  | None -> Db.exec t.db t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; NULL ];
   | Some parent ->
     with_transaction t (fun () ->
-        Db.exec t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; TEXT parent ];
-        Db.exec t.update_rc Sqlite3.Data.[ INT 1L; TEXT parent ];
+        Db.exec t.db t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; TEXT parent ];
+        Db.exec t.db t.update_rc Sqlite3.Data.[ INT 1L; TEXT parent ];
       )
 
 let set_used ~id ~now t =
   let now = format_timestamp now in
-  Db.exec t.set_used Sqlite3.Data.[ TEXT now; TEXT id ]
+  Db.exec t.db t.set_used Sqlite3.Data.[ TEXT now; TEXT id ]
 
 let children t id =
-  match Db.query_one t.exists Sqlite3.Data.[ TEXT id ] with
+  match Db.query_one t.db t.exists Sqlite3.Data.[ TEXT id ] with
   | [ INT 0L ] -> Error `No_such_id
   | [ INT 1L ] ->
-    Db.query t.children Sqlite3.Data.[ TEXT id ] |> List.map (function
+    Db.query t.db t.children Sqlite3.Data.[ TEXT id ] |> List.map (function
         | Sqlite3.Data.[ TEXT dep ] -> dep
         | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x
       )
@@ -76,17 +76,31 @@ let children t id =
 
 let delete t id =
   with_transaction t (fun () ->
-      match Db.query_one t.parent Sqlite3.Data.[ TEXT id ] with
+      match Db.query_one t.db t.parent Sqlite3.Data.[ TEXT id ] with
       | [ TEXT parent ] ->
-        Db.exec t.delete Sqlite3.Data.[ TEXT id ];
-        Db.exec t.update_rc Sqlite3.Data.[ INT (-1L); TEXT parent ]
+        Db.exec t.db t.delete Sqlite3.Data.[ TEXT id ];
+        Db.exec t.db t.update_rc Sqlite3.Data.[ INT (-1L); TEXT parent ]
       | [ NULL ] ->
-        Db.exec t.delete Sqlite3.Data.[ TEXT id ]
+        Db.exec t.db t.delete Sqlite3.Data.[ TEXT id ]
       | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x
     )
 
 let lru t ~before n =
-  Db.query t.lru Sqlite3.Data.[ TEXT (format_timestamp before); INT (Int64.of_int n) ]
+  Db.query t.db t.lru Sqlite3.Data.[ TEXT (format_timestamp before); INT (Int64.of_int n) ]
   |> List.map @@ function
   | Sqlite3.Data.[ TEXT id ] -> id
   | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x
+
+let close t =
+  Sqlite3.finalize t.begin_transaction |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.commit |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.rollback |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.add |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.set_used |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.update_rc |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.exists |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.children |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.delete |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.lru |> Db.or_fail t.db ~cmd:"finalize";
+  Sqlite3.finalize t.parent |> Db.or_fail t.db ~cmd:"finalize";
+  Db.close t.db

lib/db.ml

@@ -1,52 +1,52 @@
 type t = Sqlite3.db
 
-let or_fail ~cmd x =
+let or_fail db ~cmd x =
   match x with
   | Sqlite3.Rc.OK -> ()
-  | err -> Fmt.failwith "Sqlite3: %s (executing %S)" (Sqlite3.Rc.to_string err) cmd
+  | err -> Fmt.failwith "Sqlite3: [%s] %s (executing %S)" (Sqlite3.Rc.to_string err) (Sqlite3.errmsg db) cmd
 
 let no_callback _ = failwith "[exec] used with a query!"
 
-let exec_stmt ?(cb=no_callback) stmt =
+let exec_stmt db ?(cb=no_callback) stmt =
   let rec loop () =
     match Sqlite3.step stmt with
     | Sqlite3.Rc.DONE -> ()
     | Sqlite3.Rc.ROW ->
       let cols = Sqlite3.data_count stmt in
       cb @@ List.init cols (fun i -> Sqlite3.column stmt i);
       loop ()
-    | x -> Fmt.failwith "Sqlite3 exec error: %s" (Sqlite3.Rc.to_string x)
+    | x -> Fmt.failwith "Sqlite3 exec error: [%s] %s" (Sqlite3.Rc.to_string x) (Sqlite3.errmsg db)
   in
   loop ()
 
 let exec_literal db sql =
-  Sqlite3.exec db sql |> or_fail ~cmd:sql
+  Sqlite3.exec db sql |> or_fail db ~cmd:sql
 
-let bind stmt values =
-  Sqlite3.reset stmt |> or_fail ~cmd:"reset";
-  List.iteri (fun i v -> Sqlite3.bind stmt (i + 1) v |> or_fail ~cmd:"bind") values
+let bind db stmt values =
+  Sqlite3.reset stmt |> or_fail db ~cmd:"reset";
+  List.iteri (fun i v -> Sqlite3.bind stmt (i + 1) v |> or_fail db ~cmd:"bind") values
 
-let exec stmt values =
-  bind stmt values;
-  exec_stmt stmt
+let exec db stmt values =
+  bind db stmt values;
+  exec_stmt db stmt
 
-let query stmt values =
-  bind stmt values;
+let query db stmt values =
+  bind db stmt values;
   let results = ref [] in
   let cb row =
     results := row :: !results
   in
-  exec_stmt ~cb stmt;
+  exec_stmt db ~cb stmt;
   List.rev !results
 
-let query_one stmt values =
-  match query stmt values with
+let query_one db stmt values =
+  match query db stmt values with
   | [row] -> row
   | [] -> failwith "No results from SQL query!"
   | _ -> failwith "Multiple results from SQL query!"
 
-let query_some stmt values =
-  match query stmt values with
+let query_some db stmt values =
+  match query db stmt values with
   | [] -> None
   | [row] -> Some row
   | _ -> failwith "Multiple results from SQL query!"
@@ -60,3 +60,7 @@ let of_dir path =
 
 let dump_item = Fmt.of_to_string Sqlite3.Data.to_string_debug
 let dump_row = Fmt.(Dump.list dump_item)
+
+let close db =
+  if not (Sqlite3.db_close db) then
+    Fmt.failwith "Could not close database! It is busy."

lib/db_store.ml

@@ -173,4 +173,7 @@ module Make (Raw : S.STORE) = struct
     let db = Db.of_dir (db_dir / "db.sqlite") in
     let dao = Dao.create db in
     { raw; dao; in_progress = Builds.empty }
+
+  let unwrap t =
+    Dao.close t.dao
 end

lib/db_store.mli

@@ -27,4 +27,6 @@ module Make (Raw : S.STORE) : sig
     (string * (unit -> unit Lwt.t)) Lwt.t
 
   val wrap : Raw.t -> t
+
+  val unwrap : t -> unit
 end

lib/os.ml

@@ -25,7 +25,9 @@ let pp_signal f x =
   else if x = sigterm then Fmt.string f "term"
   else Fmt.int f x
 
-let pp_cmd = Fmt.box Fmt.(list ~sep:sp (quote string))
+let pp_cmd f (cmd, argv) =
+  let argv = if cmd = "" then argv else cmd :: argv in
+  Fmt.hbox Fmt.(list ~sep:sp (quote string)) f argv
 
 let redirection = function
   | `FD_move_safely x -> `FD_copy x.raw
@@ -43,20 +45,24 @@ let default_exec ?cwd ?stdin ?stdout ?stderr ~pp argv =
     let stdin  = Option.map redirection stdin in
     let stdout = Option.map redirection stdout in
     let stderr = Option.map redirection stderr in
-    Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv
+    try Lwt_result.ok (Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv)
+    with e -> Lwt_result.fail e
   in
   Option.iter close_redirection stdin;
   Option.iter close_redirection stdout;
   Option.iter close_redirection stderr;
-  proc >|= function
-  | Unix.WEXITED n -> Ok n
-  | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %d" pp x
-  | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp pp_signal x
+  proc >|= fun proc ->
+  Result.fold ~ok:(function
+      | Unix.WEXITED n -> Ok n
+      | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %d" pp x
+      | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp pp_signal x)
+    ~error:(fun e ->
+        Fmt.error_msg "%t raised %s\n%s" pp (Printexc.to_string e) (Printexc.get_backtrace ())) proc
 
 (* Similar to default_exec except using open_process_none in order to get the
    pid of the forked process. On macOS this allows for cleaner job cancellations *)
 let open_process ?cwd ?stdin ?stdout ?stderr ?pp:_ argv =
-  Logs.info (fun f -> f "Fork exec %a" pp_cmd argv);
+  Logs.info (fun f -> f "Fork exec %a" pp_cmd ("", argv));
   let proc =
     let stdin  = Option.map redirection stdin in
     let stdout = Option.map redirection stdout in
@@ -82,29 +88,29 @@ let process_result ~pp proc =
 (* Overridden in unit-tests *)
 let lwt_process_exec = ref default_exec
 
-let exec_result ?cwd ?stdin ?stdout ?stderr ~pp argv =
-  Logs.info (fun f -> f "Exec %a" pp_cmd argv);
-  !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp ("", Array.of_list argv) >>= function
-  | Ok 0 -> Lwt_result.return ()
+let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="") argv =
+  Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
+  !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
+  | Ok n when is_success n -> Lwt_result.ok Lwt.return_unit
   | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n
   | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string])
 
-let exec ?cwd ?stdin ?stdout ?stderr argv =
-  Logs.info (fun f -> f "Exec %a" pp_cmd argv);
-  let pp f = pp_cmd f argv in
-  !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp ("", Array.of_list argv) >>= function
-  | Ok 0 -> Lwt.return_unit
+let exec ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv =
+  Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
+  let pp f = pp_cmd f (cmd, argv) in
+  !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
+  | Ok n when is_success n -> Lwt.return_unit
   | Ok n -> Lwt.fail_with (Fmt.str "%t failed with exit status %d" pp n)
   | Error (`Msg m) -> Lwt.fail (Failure m)
 
 let running_as_root = not (Sys.unix) || Unix.getuid () = 0
 
 let sudo ?stdin args =
-  let args = if running_as_root then args else "sudo" :: args in
+  let args = if running_as_root then args else "sudo" :: "--" :: args in
   exec ?stdin args
 
 let sudo_result ?cwd ?stdin ?stdout ?stderr ~pp args =
-  let args = if running_as_root then args else "sudo" :: args in
+  let args = if running_as_root then args else "sudo" :: "--" :: args in
   exec_result ?cwd ?stdin ?stdout ?stderr ~pp args
 
 let rec write_all fd buf ofs len =
@@ -173,3 +179,12 @@ let ensure_dir path =
   match check_dir path with
   | `Present -> ()
   | `Missing -> Unix.mkdir path 0o777
+
+let copy ?(superuser=false) ~src dst =
+  if Sys.win32 then
+    exec ["robocopy"; src; dst; "/MIR"; "/NFL"; "/NDL"; "/NJH"; "/NJS"; "/NC"; "/NS"; "/NP"]
+      ~is_success:(fun n -> n = 0 || n = 1)
+  else if superuser then
+    sudo ["cp"; "-a"; "--"; src; dst ]
+  else
+    exec ["cp"; "-a"; "--"; src; dst ]

lib/s.ml

@@ -93,6 +93,10 @@ module type BUILDER = sig
     Obuilder_spec.t ->
     (id, [> `Cancelled | `Msg of string]) Lwt_result.t
 
+  val finish : t -> unit Lwt.t
+  (** [finish builder] close allocated resources and store state (e.g., sqlite3
+      databases). *)
+
   val delete : ?log:(id -> unit) -> t -> id -> unit Lwt.t
   (** [delete ?log t id] removes [id] from the store, along with all of its dependencies.
       This is for testing. Note that is not safe to perform builds while deleting: