···

       
16
       
 
       
    build : Store.Build.t;

     

       
17
       
 
       
    args : string list;

     

       
18
       
 
       
    time : int64;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
19
       
 
       
    diff : Diff.t;

     

       
20
       
 
       
  }

     

       
21
       
 
       
  [@@deriving repr]

     
···

       
172
       
 
       
    (list s);

     

       
173
       
 
       
  store

     

       
174
       
 
       


     

       
175
       
-
       
let run (_config : config) _fs clock _proc

     

       
176
       
 
       
    (((H.Store ((module S), store) : entry H.t) as s), ctx) = function

     

       
177
       
 
       
  | Set_mode mode ->

     

       
178
       
 
       
      with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun (_, entry) ->

     
···

       
240
       
 
       
                args = command;

     

       
241
       
 
       
                time = 0L;

     

       
242
       
 
       
                diff = [];

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
243
       
 
       
              })

     

       
244
       
 
       
          s

     

       
245
       
 
       
        @@ fun (_, e) -> e

     
···

       
261
       
 
       
          let void =

     

       
262
       
 
       
            Void.empty

     

       
263
       
 
       
            |> Void.rootfs ~mode:entry.mode rootfs

     

       
264
       
-
       
            |> Void.exec [ "/bin/ash"; "-c"; String.concat " " command ]

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
265
       
 
       
          in

     

       
266
       
 
       
          Switch.run @@ fun sw ->

     

       
267
       
 
       
          let start = Mtime_clock.now () in

     
···

       
270
       
 
       
            Void.exit_status proc |> Eio.Promise.await |> Void.to_eio_status

     

       
271
       
 
       
          in

     

       
272
       
 
       
          let stop = Mtime_clock.now () in

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
273
       
 
       
          let span = Mtime.span start stop in

     

       
274
       
 
       
          let time = Mtime.Span.to_uint64_ns span in

     

       
275
       
 
       
          (* Add command to history regardless of exit status *)

     
···

       
278
       
 
       
          in

     

       
279
       
 
       
          if res = `Exited 0 then

     

       
280
       
 
       
            if entry.mode = RW then

     

       
281
       
-
       
              Ok { hash_entry with build = Build new_cid; time }

     

       
282
       
-
       
            else Ok hash_entry

     

       
283
       
 
       
          else Error (Eio.Process.Child_error res)

     

       
284
       
 
       
        in

     

       
285
       
 
       
        match new_entry with

     

···

       
16
       
 
       
    build : Store.Build.t;

     

       
17
       
 
       
    args : string list;

     

       
18
       
 
       
    time : int64;

     

       
19
       
+
       
    env : string list;

     

       
20
       
+
       
    cwd : string;

     

       
21
       
 
       
    diff : Diff.t;

     

       
22
       
 
       
  }

     

       
23
       
 
       
  [@@deriving repr]

     
···

       
174
       
 
       
    (list s);

     

       
175
       
 
       
  store

     

       
176
       
 
       


     

       
177
       
+
       
let run (_config : config) fs clock _proc

     

       
178
       
 
       
    (((H.Store ((module S), store) : entry H.t) as s), ctx) = function

     

       
179
       
 
       
  | Set_mode mode ->

     

       
180
       
 
       
      with_latest ~default:(fun _ -> Ok (s, ctx)) s @@ fun (_, entry) ->

     
···

       
242
       
 
       
                args = command;

     

       
243
       
 
       
                time = 0L;

     

       
244
       
 
       
                diff = [];

     

       
245
       
+
       
                (* TODO: extract with fetch *)

     

       
246
       
+
       
                env = [];

     

       
247
       
+
       
                cwd = "/";

     

       
248
       
 
       
              })

     

       
249
       
 
       
          s

     

       
250
       
 
       
        @@ fun (_, e) -> e

     
···

       
266
       
 
       
          let void =

     

       
267
       
 
       
            Void.empty

     

       
268
       
 
       
            |> Void.rootfs ~mode:entry.mode rootfs

     

       
269
       
+
       
            |> Void.cwd entry.cwd

     

       
270
       
+
       
            |> Void.exec ~env:entry.env

     

       
271
       
+
       
                 [

     

       
272
       
+
       
                   "/bin/ash";

     

       
273
       
+
       
                   "-c";

     

       
274
       
+
       
                   String.concat " " command ^ " && env > /shelter-env";

     

       
275
       
+
       
                 ]

     

       
276
       
 
       
          in

     

       
277
       
 
       
          Switch.run @@ fun sw ->

     

       
278
       
 
       
          let start = Mtime_clock.now () in

     
···

       
281
       
 
       
            Void.exit_status proc |> Eio.Promise.await |> Void.to_eio_status

     

       
282
       
 
       
          in

     

       
283
       
 
       
          let stop = Mtime_clock.now () in

     

       
284
       
+
       
          (* Extract env *)

     

       
285
       
+
       
          let env_path = Eio.Path.(fs / rootfs / "shelter-env") in

     

       
286
       
+
       
          let env = Eio.Path.(load env_path) |> String.split_on_char '\n' in

     

       
287
       
+
       
          Eio.Path.unlink env_path;

     

       
288
       
+
       
          let cwd =

     

       
289
       
+
       
            List.find_map

     

       
290
       
+
       
              (fun v ->

     

       
291
       
+
       
                match Astring.String.cut ~sep:"=" v with

     

       
292
       
+
       
                | Some ("PWD", dir) -> Some dir

     

       
293
       
+
       
                | _ -> None)

     

       
294
       
+
       
              env

     

       
295
       
+
       
            |> Option.value ~default:hash_entry.cwd

     

       
296
       
+
       
          in

     

       
297
       
 
       
          let span = Mtime.span start stop in

     

       
298
       
 
       
          let time = Mtime.Span.to_uint64_ns span in

     

       
299
       
 
       
          (* Add command to history regardless of exit status *)

     
···

       
302
       
 
       
          in

     

       
303
       
 
       
          if res = `Exited 0 then

     

       
304
       
 
       
            if entry.mode = RW then

     

       
305
       
+
       
              Ok { hash_entry with build = Build new_cid; time; env; cwd }

     

       
306
       
+
       
            else Ok { hash_entry with cwd; env }

     

       
307
       
 
       
          else Error (Eio.Process.Child_error res)

     

       
308
       
 
       
        in

     

       
309
       
 
       
        match new_entry with

     

···

       
6
       
 
       
    build : Store.Build.t;

     

       
7
       
 
       
    args : string list;

     

       
8
       
 
       
    time : int64;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
9
       
 
       
    diff : Diff.t;

     

       
10
       
 
       
  }

     

       
11
       
 
       
  [@@deriving repr]

     

···

       
6
       
 
       
    build : Store.Build.t;

     

       
7
       
 
       
    args : string list;

     

       
8
       
 
       
    time : int64;

     

       
9
       
+
       
    env : string list;

     

       
10
       
+
       
    cwd : string;

     

       
11
       
 
       
    diff : Diff.t;

     

       
12
       
 
       
  }

     

       
13
       
 
       
  [@@deriving repr]

     

···

       
9
       
 
       


     

       
10
       
 
       
type void = {

     

       
11
       
 
       
  args : string list;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
12
       
 
       
  rootfs : (string * mode) option;

     

       
13
       
 
       
  mounts : mount list;

     

       
14
       
 
       
}

     
···

       
98
       
 
       


     

       
99
       
 
       
type path = string

     

       
100
       
 
       


     

       
101
       
-
       
let empty = { args = []; rootfs = None; mounts = [] }

     

       
102
       
 
       


     

       
103
       
 
       
let actions v : Fork_action.t list =

     

       
104
       
 
       
  let root, tmpfs, root_mode =

     
···

       
108
       
 
       
  in

     

       
109
       
 
       
  let args = match v.args with [] -> failwith "No exec" | args -> args in

     

       
110
       
 
       
  let e =

     

       
111
       
-
       
    Process.Fork_action.execve (List.hd args) ~env:[||]

     

       
112
       
 
       
      ~argv:(Array.of_list args)

     

       
113
       
 
       
  in

     

       
114
       
 
       
  (* Process mount point points *)

     
···

       
126
       
 
       
  let mounts = pivot_root root root_flags tmpfs mounts in

     

       
127
       
 
       
  let uid, gid = Unix.(getuid (), getgid ()) in

     

       
128
       
 
       
  let user_namespace = map_uid_gid ~uid ~gid in

     

       
129
       
-
       
  [ user_namespace; mounts; e ]

     

       
130
       
 
       


     

       
131
       
 
       
let rootfs ~mode path v = { v with rootfs = Some (path, mode) }

     

       
132
       
-
       
let exec args v = { v with args }

     

       
0
       
 
       

     

       
133
       
 
       


     

       
134
       
 
       
let mount ~mode ~src ~tgt v =

     

       
135
       
 
       
  let mode = if mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty in

     

···

       
9
       
 
       


     

       
10
       
 
       
type void = {

     

       
11
       
 
       
  args : string list;

     

       
12
       
+
       
  env : string list;

     

       
13
       
+
       
  cwd : string;

     

       
14
       
 
       
  rootfs : (string * mode) option;

     

       
15
       
 
       
  mounts : mount list;

     

       
16
       
 
       
}

     
···

       
100
       
 
       


     

       
101
       
 
       
type path = string

     

       
102
       
 
       


     

       
103
       
+
       
let empty = { args = []; env = []; rootfs = None; mounts = []; cwd = "/" }

     

       
104
       
 
       


     

       
105
       
 
       
let actions v : Fork_action.t list =

     

       
106
       
 
       
  let root, tmpfs, root_mode =

     
···

       
110
       
 
       
  in

     

       
111
       
 
       
  let args = match v.args with [] -> failwith "No exec" | args -> args in

     

       
112
       
 
       
  let e =

     

       
113
       
+
       
    Process.Fork_action.execve (List.hd args) ~env:(Array.of_list v.env) 

     

       
114
       
 
       
      ~argv:(Array.of_list args)

     

       
115
       
 
       
  in

     

       
116
       
 
       
  (* Process mount point points *)

     
···

       
128
       
 
       
  let mounts = pivot_root root root_flags tmpfs mounts in

     

       
129
       
 
       
  let uid, gid = Unix.(getuid (), getgid ()) in

     

       
130
       
 
       
  let user_namespace = map_uid_gid ~uid ~gid in

     

       
131
       
+
       
  [ user_namespace; mounts; Process.Fork_action.chdir v.cwd; e ]

     

       
132
       
 
       


     

       
133
       
 
       
let rootfs ~mode path v = { v with rootfs = Some (path, mode) }

     

       
134
       
+
       
let cwd cwd v = { v with cwd }

     

       
135
       
+
       
let exec ?(env=[]) args v = { v with args; env }

     

       
136
       
 
       


     

       
137
       
 
       
let mount ~mode ~src ~tgt v =

     

       
138
       
 
       
  let mode = if mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty in

     

···

       
47
       
 
       


     

       
48
       
 
       
val mount : mode:mode -> src:path -> tgt:path -> void -> void

     

       
49
       
 
       


     

       
50
       
-
       
val exec : string list -> void -> void

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
51
       
 
       
(** Make a void configuration ready to be spawned *)

     

       
52
       
 
       


     

       
53
       
 
       
val spawn : sw:Eio.Switch.t -> void -> t

     

···

       
47
       
 
       


     

       
48
       
 
       
val mount : mode:mode -> src:path -> tgt:path -> void -> void

     

       
49
       
 
       


     

       
50
       
+
       


     

       
51
       
+
       
val cwd : string -> void -> void

     

       
52
       
+
       
(** Set the current working directory *)

     

       
53
       
+
       


     

       
54
       
+
       
val exec : ?env:string list -> string list -> void -> void

     

       
55
       
 
       
(** Make a void configuration ready to be spawned *)

     

       
56
       
 
       


     

       
57
       
 
       
val spawn : sw:Eio.Switch.t -> void -> t