Add support for FreeBSD

dune-project

@@ -1,44 +1,3 @@
 (lang dune 3.3)
 (name obuilder)
 (formatting disabled)
-(generate_opam_files true)
-(source (github ocurrent/obuilder))
-(authors "talex5@gmail.com")
-(maintainers "talex5@gmail.com")
-(license "Apache-2.0")
-(documentation "https://ocurrent.github.io/obuilder/")
-(package
- (name obuilder)
- (synopsis "Run build scripts for CI")
- (description
-  "OBuilder takes a build script (similar to a Dockerfile) and performs the steps in it in a sandboxed environment.")
- (depends
-  (lwt (>= 5.6.1))
-  astring
-  (fmt (>= 0.8.9))
-  logs
-  (cmdliner (>= 1.1.0))
-  (tar-unix (>= 2.0.0))
-  (yojson (>= "1.6.0"))
-  sexplib
-  ppx_deriving
-  ppx_sexp_conv
-  sha
-  sqlite3
-  (obuilder-spec (= :version))
-  (ocaml (>= 4.10.0))
-  (alcotest-lwt :with-test))
- (conflicts
-  (result (< "1.5"))))
-(package
- (name obuilder-spec)
- (synopsis "Build specification format")
- (description
-  "A library for constructing, reading and writing OBuilder build specification files.")
- (depends
-  (fmt (>= 0.8.9))
-  sexplib
-  astring
-  ppx_deriving
-  ppx_sexp_conv
-  (ocaml (>= 4.10.0))))

lib/build.ml

@@ -269,15 +269,6 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
     | `Output -> Buffer.add_string buffer x
 
   let healthcheck ?(timeout=30.0) t =
-    Os.with_pipe_from_child (fun ~r ~w ->
-        let pp f = Fmt.string f "docker version" in
-        let result = Os.exec_result ~pp ~stdout:`Dev_null ~stderr:(`FD_move_safely w) ["docker"; "version"] in
-        let r = Lwt_io.(of_fd ~mode:input) r ~close:Lwt.return in
-        Lwt_io.read r >>= fun err ->
-        result >>= function
-        | Ok () -> Lwt_result.return ()
-        | Error (`Msg m) -> Lwt_result.fail (`Msg (Fmt.str "%s@.%s" m (String.trim err)))
-      ) >>!= fun () ->
     let buffer = Buffer.create 1024 in
     let log = log_to buffer in
     (* Get the base image first, before starting the timer. *)

lib/docker.ml

@@ -1,37 +1,48 @@
 open Lwt.Infix
 
-let export_env base : Config.env Lwt.t =
-  Os.pread ["docker"; "image"; "inspect";
-            "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|};
-            "--"; base] >|= fun env ->
-  String.split_on_char '\x00' env
-  |> List.filter_map (function
-      | "\n" -> None
-      | kv ->
-        match Astring.String.cut ~sep:"=" kv with
-        | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv
-        | Some _ as pair -> pair
-    )
+let export_env config : Config.env =
+  Docker_hub.Config.env config |>
+  List.filter_map (fun kv ->
+    match Astring.String.cut ~sep:"=" kv with
+    | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv
+    | Some _ as pair -> pair
+  )
 
-let with_container ~log base fn =
-  Os.with_pipe_from_child (fun ~r ~w ->
-      (* We might need to do a pull here, so log the output to show progress. *)
-      let copy = Build_log.copy ~src:r ~dst:log in
-      Os.pread ~stderr:(`FD_move_safely w) ["docker"; "create"; "--"; base] >>= fun cid ->
-      copy >|= fun () ->
-      String.trim cid
-    ) >>= fun cid ->
-  Lwt.finalize
-    (fun () -> fn cid)
-    (fun () -> Os.exec ~stdout:`Dev_null ["docker"; "rm"; "--"; cid])
+let handle_errors = function
+  | Ok x -> Lwt.return x
+  | Error _ -> (* TODO: pretty print the errors *)
+      Lwt.fail_with "TODO"
 
+let with_container manifest token fn =
+  Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-docker-hub-" @@ fun output_file ->
+  Docker_hub.fetch_rootfs ~output_file:(Fpath.v output_file) manifest token >>=
+  handle_errors >>= fun () ->
+  fn output_file
 
-let fetch ~log ~rootfs base =
-  with_container ~log base (fun cid ->
+let fetch ~log:_ ~rootfs base =
+  let name, tag, digest = Docker_hub.Image.from_string base in
+  Docker_hub.Token.fetch name >>= handle_errors >>= fun token ->
+  begin match digest with
+  | None ->
+      Docker_hub.Manifests.fetch tag token >>= handle_errors >>= fun manifests ->
+      let elements = Docker_hub.Manifests.elements manifests in
+      let current_platform = Docker_hub.Platform.current in
+      let {Docker_hub.Manifests.digest; _} =
+        List.find (fun {Docker_hub.Manifests.platform; _} ->
+          Docker_hub.Platform.equal platform current_platform
+        ) elements
+      in
+      Docker_hub.Manifest.fetch digest token
+  | Some digest ->
+      Docker_hub.Manifest.fetch digest token
+  end >>= handle_errors >>= fun manifest ->
+  Docker_hub.Config.fetch manifest token >>= handle_errors >>= fun config ->
+  with_container manifest token (fun output_file ->
     Os.with_pipe_between_children @@ fun ~r ~w ->
-    let exporter = Os.exec ~stdout:(`FD_move_safely w) ["docker"; "export"; "--"; cid] in
+    let exporter = Os.exec ~stdout:(`FD_move_safely w) ["cat"; output_file] in
     let tar = Os.sudo ~stdin:(`FD_move_safely r) ["tar"; "-C"; rootfs; "-xf"; "-"] in
+    Os_specific_utils.chflags ~dir:rootfs >>= fun () -> (* Needed to be able to delete the directory on FreeBSD *)
     exporter >>= fun () ->
     tar
-  ) >>= fun () ->
-  export_env base
+  ) >|= fun () ->
+  export_env config

lib/dune

@@ -2,4 +2,41 @@
   (name obuilder)
   (public_name obuilder)
   (preprocess (pps ppx_sexp_conv))
-  (libraries lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner))
+  (libraries
+    lwt
+    lwt.unix
+    fmt
+    yojson
+    tar-unix
+    sexplib
+    sqlite3
+    astring
+    logs
+    sha
+    obuilder-spec
+    cmdliner
+    docker_hub))
+
+(rule
+ (deps sandbox.runc.ml)
+ (target sandbox.ml)
+ (enabled_if (= %{system} linux))
+ (action (copy# %{deps} %{target})))
+
+(rule
+ (deps sandbox.runj.ml)
+ (target sandbox.ml)
+ (enabled_if (= %{system} freebsd))
+ (action (copy# %{deps} %{target})))
+
+(rule
+ (deps os_specific_utils.linux.ml)
+ (target os_specific_utils.ml)
+ (enabled_if (= %{system} linux))
+ (action (copy# %{deps} %{target})))
+
+(rule
+ (deps os_specific_utils.freebsd.ml)
+ (target os_specific_utils.ml)
+ (enabled_if (= %{system} freebsd))
+ (action (copy# %{deps} %{target})))

lib/obuilder.ml

@@ -19,7 +19,7 @@ module Docker = Docker
 (** {2 Sandboxes} *)
 
 module Config = Config
-module Runc_sandbox = Runc_sandbox
+module Sandbox = Sandbox
 
 (** {2 Builders} *)
 

lib/os_specific_utils.freebsd.ml

@@ -0,0 +1,2 @@
+let chflags ~dir =
+  Os.sudo ["chflags"; "-R"; "0"; dir]

lib/os_specific_utils.linux.ml

@@ -0,0 +1,2 @@
+let chflags ~dir:_ =
+  Lwt.return ()

lib/os_specific_utils.mli

@@ -0,0 +1 @@
+val chflags : dir:string -> unit Lwt.t

lib/runc_sandbox.mli → lib/sandbox.mli

@@ -1,4 +1,4 @@
-(** Sandbox builds using runc Linux containers. *)
+(** Sandbox builds. *)
 
 include S.SANDBOX
 

lib/sandbox.runj.ml

@@ -0,0 +1,119 @@
+open Lwt.Infix
+open Sexplib.Conv
+
+let ( / ) = Filename.concat
+let ( >>!= ) = Lwt_result.Infix.( >>= )
+
+type t = {
+  runj_state_dir : string;
+}
+
+type config = unit [@@deriving sexp]
+
+module Json_config = struct
+  let mount ?(options=[]) ~ty ~src dst =
+    `Assoc [
+      "destination", `String dst;
+      "type", `String ty;
+      "source", `String src;
+      "options", `List (List.map (fun x -> `String x) options);
+    ]
+
+  let strings xs = `List ( List.map (fun x -> `String x) xs)
+
+  let make {Config.cwd; argv; hostname; user = _; env; mounts = _; network = _; mount_secrets = _} _t ~config_dir:_ ~results_dir : Yojson.Safe.t =
+    (* TODO: runj does not support the "user" field yet *)
+    (* TODO: FreeBSD does not support mounts of regular files / directories *)
+    let argv =
+      (* TODO: runj does not support the "cwd" field yet but we can hack around it *)
+      ["/bin/sh";"-c";Printf.sprintf "cd %S && %s" cwd (String.concat " " argv)]
+    in
+    `Assoc [
+      "ociVersion", `String "1.0.2-runj-dev";
+      "process", `Assoc [
+        "terminal", `Bool false;
+        "args", strings argv;
+        "env", strings (List.map (fun (k, v)  -> Printf.sprintf "%s=%s" k v) env);
+      ];
+      "root", `Assoc [
+        "path", `String (results_dir / "rootfs");
+      ];
+      "hostname", `String hostname;
+      "mounts", `List [
+        mount "/dev"
+         ~ty:"devfs"
+         ~src:"devfs"
+         ~options:[
+           "ruleset=4"
+         ];
+      ];
+      "freebsd", `Assoc [
+        (* TODO: Add support for non-host network using the runj extension: https://github.com/samuelkarp/runj/pull/32 *)
+        "network", `Assoc [
+          "ipv4", `Assoc [
+            "mode", `String "inherit";
+          ];
+        ];
+      ];
+    ]
+end
+
+let next_id = ref 0
+
+let run ~cancelled ?stdin:stdin ~log t config results_dir =
+  Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-runj-" @@ fun tmp ->
+  let json_config = Json_config.make config ~config_dir:tmp ~results_dir t in
+  Os.write_file ~path:(tmp / "config.json") (Yojson.Safe.pretty_to_string json_config ^ "\n") >>= fun () ->
+  Os.write_file ~path:(results_dir / "rootfs" / "etc" / "hosts") "127.0.0.1 localhost builder" >>= fun () ->
+  Os.write_file ~path:(results_dir / "rootfs" / "etc" / "resolv.conf") "nameserver 8.8.8.8" >>= fun () ->
+  let id = string_of_int !next_id in
+  incr next_id;
+  Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w ->
+  let copy_log = Build_log.copy ~src:out_r ~dst:log in
+  let proc =
+    let cmd1 = ["runj"; "create"; "-b"; t.runj_state_dir; id] in
+    let cmd2 = ["runj"; "start"; id] in
+    let stdout = `FD_move_safely out_w in
+    let stderr = stdout in
+    let stdin = Option.map (fun x -> `FD_move_safely x) stdin in
+    let pp f = Os.pp_cmd f config.argv in
+    Os.sudo_result ~cwd:tmp ?stdin ~stdout ~stderr ~pp cmd1 >>!= fun () ->
+    Os.sudo_result ~cwd:tmp ?stdin ~stdout ~stderr ~pp cmd2
+  in
+  Lwt.on_termination cancelled (fun () ->
+      let rec aux () =
+        if Lwt.is_sleeping proc then (
+          let pp f = Fmt.pf f "runj kill %S" id in
+          Os.sudo_result ~cwd:tmp ["runj"; "kill"; id; "KILL"] ~pp >>= function
+          | Ok () -> Lwt.return_unit
+          | Error (`Msg m) ->
+            (* This might be because it hasn't been created yet, so retry. *)
+            Log.warn (fun f -> f "kill failed: %s (will retry in 10s)" m);
+            Lwt_unix.sleep 10.0 >>= aux
+        ) else Lwt.return_unit  (* Process has already finished *)
+      in
+      Lwt.async aux
+    );
+  proc >>= fun r ->
+  copy_log >>= fun () ->
+  if Lwt.is_sleeping cancelled then Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result)
+  else Lwt_result.fail `Cancelled
+
+let clean_runj dir =
+  Sys.readdir dir
+  |> Array.to_list
+  |> Lwt_list.iter_s (fun item ->
+      Log.warn (fun f -> f "Removing left-over runj container %S" item);
+      Os.sudo ["runj"; "delete"; item]
+    )
+
+let create ~state_dir (() : config) =
+  Os.ensure_dir state_dir;
+  clean_runj state_dir >|= fun () ->
+  { runj_state_dir = state_dir }
+
+module Term = Cmdliner.Term
+
+let cmdliner : config Term.t =
+  let make = () in
+  Term.(const make)

main.ml

@@ -2,7 +2,7 @@ open Lwt.Infix
 
 let ( / ) = Filename.concat
 
-module Sandbox = Obuilder.Runc_sandbox
+module Sandbox = Obuilder.Sandbox
 module Fetcher = Obuilder.Docker
 module Store_spec = Obuilder.Store_spec
 

obuilder-spec.opam

@@ -1,4 +1,3 @@
-# This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
 synopsis: "Build specification format"
 description:

obuilder.opam

@@ -1,4 +1,3 @@
-# This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
 synopsis: "Run build scripts for CI"
 description:
@@ -15,6 +14,7 @@ depends: [
   "astring"
   "fmt" {>= "0.8.9"}
   "logs"
+  "docker_hub" {>= "0.2.0"}
   "cmdliner" {>= "1.1.0"}
   "tar-unix" {>= "2.0.0"}
   "yojson" {>= "1.6.0"}
@@ -31,6 +31,7 @@ depends: [
 conflicts: [
   "result" {< "1.5"}
 ]
+available: os = "linux" | os = "freebsd"
 build: [
   ["dune" "subst"] {dev}
   [

stress/stress.ml

@@ -16,7 +16,7 @@ let assert_str expected got =
     exit 1
   )
 
-module Sandbox = Runc_sandbox
+module Sandbox = Sandbox
 module Fetcher = Docker
 
 module Test(Store : S.STORE) = struct