Skip to content

Commit

Permalink
Add terminal support and ROM mounts
Browse files Browse the repository at this point in the history
  • Loading branch information
@patricoferris
patricoferris committed Mar 20, 2024
1 parent c0eb046 commit ea2f7b8
Show file tree
Hide file tree
Showing 18 changed files with 342 additions and 89 deletions.
164 changes: 128 additions & 36 deletions lib/build.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,8 +10,8 @@ let hostname = "builder"
let healthcheck_base () =
if Sys.win32 then
Docker_sandbox.servercore () >>= fun (`Docker_image servercore) ->
Lwt.return servercore
else Lwt.return "busybox"
Lwt.return (`Image servercore)
else Lwt.return (`Image "busybox")

let healthcheck_ops =
let open Obuilder_spec in
Expand Down Expand Up @@ -71,7 +71,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
mount_secrets : Config.Secret.t list;
} [@@deriving sexp_of]

let run t ~switch ~log ~cache run_input =
let run t ~switch ~log ~cache ~(rom:Obuilder_spec.Rom.t list) run_input =
let id =
sexp_of_run_input run_input
|> Sexplib.Sexp.to_string_mach
Expand All @@ -89,17 +89,69 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
{ Config.Mount.ty = `Bind; src; dst = target; readonly = false }
)
>>= fun mounts ->
let argv = shell @ [cmd] in
Lwt_list.map_p (fun v ->
match v.Obuilder_spec.Rom.kind with
| `Build (hash, dir) ->
Store.result t.store hash >|= fun path ->
let path = Option.get path in
let src = path / "rootfs" / dir in
{ Config.Mount.src; ty = `Bind; dst = v.target; readonly = true }
) rom >>= fun rom_mounts ->
let argv = `Run (shell @ [cmd]) in
let mounts = mounts @ rom_mounts 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 () ->
let roms = List.map Obuilder_spec.Rom.sexp_of_t rom in
let roms = Sexplib.Sexp.List roms |> Sexplib.Sexp.to_string in
Os.write_file ~path:(result_tmp / "rom") roms >>= fun () ->
Sandbox.run ~cancelled ~stdin ~log t.sandbox config result_tmp
)
(fun () ->
!to_release |> Lwt_list.iter_s (fun f -> f ())
)
)

let run_shell t ?unix_sock ~shell_established ~switch:_ ~cache ~(rom:Obuilder_spec.Rom.t list) ?stdin id run_input =
let { base=_; workdir; user; env=_; cmd=_; shell=_; network; mount_secrets } = run_input in
Store.with_temp t.store id (fun result_tmp ->
let to_release = ref [] in
let cancelled, _ = Lwt.wait () in
Lwt.finalize
(fun () ->
let saved_roms =
match Sexplib.Sexp.load_sexp (result_tmp / "rom") with
| Sexplib.Sexp.List sexps ->
List.map Obuilder_spec.Rom.t_of_sexp sexps
| exception _ | _ -> []
in
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; ty = `Bind; dst = target; readonly = false }
)
>>= fun mounts ->
Lwt_list.map_p (fun v ->
match v.Obuilder_spec.Rom.kind with
| `Build (hash, dir) ->
Store.result t.store hash >|= fun path ->
let path = Option.get path in
let src = path / "rootfs" / dir in
{ Config.Mount.src; ty = `Bind; dst = v.target; readonly = true }
) (rom @ saved_roms) >>= fun rom_mounts ->
let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (result_tmp / "env")) in
let mounts = mounts @ rom_mounts in
let config = Config.v ~cwd:workdir ~argv:`Terminal ~hostname ~user ~env ~mounts ~mount_secrets ~network () in
Sandbox.shell ?unix_sock ~cancelled ?stdin t.sandbox config result_tmp >>!= fun cond ->
Lwt.wakeup_later shell_established ();
Lwt_condition.wait cond >>= fun () ->
Lwt.return_ok ()
)
(fun () ->
!to_release |> Lwt_list.iter_s (fun f -> f ())
)
)

type copy_details = {
base : S.id;
user : Obuilder_spec.user;
Expand Down Expand Up @@ -148,7 +200,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
(* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *)
let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in
Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log result_tmp ->
let argv = ["tar"; "-xf"; "-"] in
let argv = `Run ["tar"; "-xf"; "-"] in
let config = Config.v
~cwd:"/"
~argv
Expand Down Expand Up @@ -212,14 +264,14 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
| `Comment _ -> k ~base ~context
| `Workdir workdir -> k ~base ~context:(update_workdir ~context workdir)
| `User user -> k ~base ~context:{context with user}
| `Run { shell = cmd; cache; network; secrets = mount_secrets } ->
| `Run { shell = cmd; cache; network; secrets = mount_secrets; rom } ->
let result =
let { Context.switch; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in
resolve_secrets secrets mount_secrets |> Result.map @@ fun mount_secrets ->
(switch, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log)
in
Lwt.return result >>!= fun (switch, run_input, log) ->
run t ~switch ~log ~cache run_input >>!= fun base ->
run t ~switch ~log ~cache ~rom run_input >>!= fun base ->
k ~base ~context
| `Copy x ->
copy t ~context ~base x >>!= fun base ->
Expand All @@ -231,21 +283,31 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
k ~base ~context:{context with shell}

let get_base t ~log base =
log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom base));
let id = Sha256.to_hex (Sha256.string base) in
Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp ->
Log.info (fun f -> f "Base image not present; importing %S…" base);
let rootfs = tmp / "rootfs" in
Os.sudo ["mkdir"; "-m"; "755"; "--"; rootfs] >>= fun () ->
Fetch.fetch ~log ~rootfs base >>= fun env ->
Os.write_file ~path:(tmp / "env")
(Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
Lwt_result.return ()
)
>>!= fun id -> Store.result t.store id
>|= Option.get >>= fun path ->
let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
Lwt_result.return (id, env)
let () = match base with
| `Image i -> log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom i));
| `Build b -> log `Heading (Fmt.str "(base %a)" Sexplib.Sexp.pp_hum (Atom b));
in
match base with
| `Build base ->
Store.result t.store base
>|= Option.get >>= fun path ->
let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
Lwt_result.return (base, env)
| `Image base ->
let id = Sha256.to_hex (Sha256.string base) in
Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp ->
Log.info (fun f -> f "Base image not present; importing %S…" base);
let rootfs = tmp / "rootfs" in
Os.sudo ["mkdir"; "-m"; "755"; "--"; rootfs] >>= fun () ->
Fetch.fetch ~log ~rootfs base >>= fun env ->
Os.write_file ~path:(tmp / "env")
(Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
Lwt_result.return ()
)
>>!= fun id -> Store.result t.store id
>|= Option.get >>= fun path ->
let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
Lwt_result.return (id, env)

let rec build t context { Obuilder_spec.child_builds; from = base; ops } =
let rec aux context = function
Expand All @@ -262,6 +324,13 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
let context = { context with env = context.env @ env } in
run_steps t ~context ~base:id ops

let shell t ?unix_sock ?stdin id =
let stdin = Option.map (fun stdin -> Os.{ raw = stdin; needs_close = false }) stdin in
let rinput = { base = ""; workdir = "/"; user = Obuilder_spec.(`Unix { uid = 1000; gid = 1000 }); env = []; cmd = ""; shell = [ "sh" ]; network = [ "host" ]; mount_secrets = [] } in
let established, shell_established = Lwt.wait () in
let f = run_shell t ?unix_sock ~shell_established ~switch:None ?stdin ~cache:[] ~rom:[] id rinput in
established, f

let build t context spec =
let r = build t context spec in
(r : (string, [ `Cancelled | `Msg of string ]) Lwt_result.t :> (string, [> `Cancelled | `Msg of string ]) Lwt_result.t)
Expand Down Expand Up @@ -336,6 +405,9 @@ module Make_Docker (Raw_store : S.STORE) = struct
sandbox : Docker_sandbox.t;
}

let shell _t ?unix_sock:_ ?stdin:_ _id =
failwith "Shells/Interactive Terminals are not supported via the Docker sandbox"

(* Inputs to run that should affect the hash. i.e. if anything in here changes
then we need a fresh build. *)
type run_input = {
Expand All @@ -347,6 +419,7 @@ module Make_Docker (Raw_store : S.STORE) = struct
shell : string list;
network : string list;
mount_secrets : Config.Secret.t list;
rom : Obuilder_spec.Rom.t list;
} [@@deriving sexp_of]

let run t ~switch ~log ~cache run_input =
Expand All @@ -356,7 +429,7 @@ module Make_Docker (Raw_store : S.STORE) = struct
|> Sha256.string
|> Sha256.to_hex
in
let { base; workdir; user; env; cmd; shell; network; mount_secrets } = run_input in
let { base; workdir; user; env; cmd; shell; network; mount_secrets; rom } = run_input in
Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ ->
let to_release = ref [] in
Lwt.finalize
Expand All @@ -367,8 +440,17 @@ module Make_Docker (Raw_store : S.STORE) = struct
{ Config.Mount.ty = `Volume; src; dst = target; readonly = false }
)
>>= fun mounts ->
Lwt_list.map_p (fun v ->
match v.Obuilder_spec.Rom.kind with
| `Build (hash, dir) ->
Store.result t.store hash >|= fun path ->
let path = Option.get path in
let src = path / "rootfs" / dir in
{ Config.Mount.src; ty = `Volume; dst = v.target; readonly = true }
) rom >>= fun rom_mounts ->
let mounts = mounts @ rom_mounts in
let entrypoint, argv = Docker.setup_command ~entp:shell ~cmd:[cmd] in
let config = Config.v ~cwd:workdir ~entrypoint ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network () in
let config = Config.v ~cwd:workdir ~entrypoint ~argv:(`Run 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 () ->
Lwt_result.bind_lwt
Expand Down Expand Up @@ -471,11 +553,11 @@ module Make_Docker (Raw_store : S.STORE) = struct
| `Comment _ -> k ~base ~context
| `Workdir workdir -> k ~base ~context:(update_workdir ~context workdir)
| `User user -> k ~base ~context:{context with user}
| `Run { shell = cmd; cache; network; secrets = mount_secrets } ->
| `Run { shell = cmd; cache; network; secrets = mount_secrets; rom } ->
let result =
let { Context.switch; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in
resolve_secrets secrets mount_secrets |> Result.map @@ fun mount_secrets ->
(switch, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log)
(switch, { base; workdir; user; env; cmd; shell; network; mount_secrets; rom }, log)
in
Lwt.return result >>!= fun (switch, run_input, log) ->
run t ~switch ~log ~cache run_input >>!= fun base ->
Expand All @@ -495,16 +577,26 @@ module Make_Docker (Raw_store : S.STORE) = struct
k ~base ~context:{context with shell}

let get_base t ~log base =
log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom base));
let id = Sha256.to_hex (Sha256.string base) in
Store.build t.store ~id ~log (fun ~cancelled:_ ~log:_ _ ->
Log.info (fun f -> f "Base image not present; importing %S…" base);
Docker.Cmd.pull (`Docker_image base) >>= fun () ->
Docker.Cmd.tag (`Docker_image base) (Docker.docker_image id) >>= fun () ->
Lwt_result.return ()
)
>>!= fun id ->
Lwt_result.return (id, [])
let () = match base with
| `Image i -> log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom i));
| `Build b -> log `Heading (Fmt.str "(base %a)" Sexplib.Sexp.pp_hum (Atom b));
in
match base with
| `Build base ->
Store.result t.store base
>|= Option.get >>= fun path ->
let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
Lwt_result.return (base, env)
| `Image base ->
let id = Sha256.to_hex (Sha256.string base) in
Store.build t.store ~id ~log (fun ~cancelled:_ ~log:_ _ ->
Log.info (fun f -> f "Base image not present; importing %S…" base);
Docker.Cmd.pull (`Docker_image base) >>= fun () ->
Docker.Cmd.tag (`Docker_image base) (Docker.docker_image id) >>= fun () ->
Lwt_result.return ()
)
>>!= fun id ->
Lwt_result.return (id, [])

let rec build ~scope t context { Obuilder_spec.child_builds; from = base; ops } =
let rec aux context = function
Expand Down
2 changes: 1 addition & 1 deletion lib/config.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,7 @@ end
type t = {
cwd : string;
entrypoint : string option;
argv : string list;
argv : [`Run of string list | `Terminal ];
hostname : string;
user : Obuilder_spec.user;
env : env;
Expand Down
6 changes: 6 additions & 0 deletions lib/db_store.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,6 +78,12 @@ module Make (Raw : S.STORE) = struct
| `Loaded -> client_log `Note (Fmt.str "---> using %S from cache" id)
| `Saved -> client_log `Note (Fmt.str "---> saved as %S" id)

let with_temp t id fn =
let tmp = "tmp-" ^ id in
Raw.build ~base:id t.raw ~id:tmp fn >>!= fun () ->
Raw.delete t.raw tmp >>= fun () ->
Lwt.return @@ Ok ()

(* Check to see if we're in the process of building [id].
If so, just tail the log from that.
If not, use [get_build] to get the build.
Expand Down
2 changes: 2 additions & 0 deletions lib/db_store.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,8 @@ module Make (Raw : S.STORE) : sig
@param switch Turn this off if you no longer need the result. The build
will be cancelled if no-one else is waiting for it. *)

val with_temp : t -> S.id -> (string -> (unit, [`Cancelled | `Msg of string]) Lwt_result.t) -> (unit, [`Cancelled | `Msg of string]) Lwt_result.t

val delete : ?log:(S.id -> unit) -> t -> S.id -> unit Lwt.t

val prune : ?log:(S.id -> unit) -> t -> before:Unix.tm -> int -> int Lwt.t
Expand Down
Loading

0 comments on commit ea2f7b8

Please sign in to comment.