···

       
30
       
 
       
    Eio_posix.run @@ fun env ->

     

       
31
       
 
       
    let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in

     

       
32
       
 
       
    let dir = state_dir env#fs "shelter" in

     

       
33
       
-
       
    Main.main config env#fs env#clock env#process_mgr dir cmd_file

     

       
0
       
 
       

     

       
34
       
 
       
  in

     

       
35
       
 
       
  let t = Term.(const run $ Shelter_main.config_term $ cmd_file) in

     

       
36
       
 
       
  let man =

     
···

       
49
       
 
       
    Eio_posix.run @@ fun env ->

     

       
50
       
 
       
    let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in

     

       
51
       
 
       
    let dir = state_dir env#fs "passthrough" in

     

       
52
       
-
       
    Pass.main config env#fs env#clock env#process_mgr dir cmd_file

     

       
0
       
 
       

     

       
53
       
 
       
  in

     

       
54
       
 
       
  let t = Term.(const run $ Shelter_passthrough.config_term $ cmd_file) in

     

       
55
       
 
       
  let info = Cmd.info "passthrough" in

     

···

       
30
       
 
       
    Eio_posix.run @@ fun env ->

     

       
31
       
 
       
    let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in

     

       
32
       
 
       
    let dir = state_dir env#fs "shelter" in

     

       
33
       
+
       
    let stdout = (env#stdout :> Eio.Flow.sink_ty Eio.Flow.sink) in

     

       
34
       
+
       
    Main.main config ~stdout env#fs env#clock env#process_mgr dir cmd_file

     

       
35
       
 
       
  in

     

       
36
       
 
       
  let t = Term.(const run $ Shelter_main.config_term $ cmd_file) in

     

       
37
       
 
       
  let man =

     
···

       
50
       
 
       
    Eio_posix.run @@ fun env ->

     

       
51
       
 
       
    let cmd_file = Option.map (Eio.Path.( / ) env#fs) cmd_file in

     

       
52
       
 
       
    let dir = state_dir env#fs "passthrough" in

     

       
53
       
+
       
    let stdout = (env#stdout :> Eio.Flow.sink_ty Eio.Flow.sink) in

     

       
54
       
+
       
    Pass.main config ~stdout env#fs env#clock env#process_mgr dir cmd_file

     

       
55
       
 
       
  in

     

       
56
       
 
       
  let t = Term.(const run $ Shelter_passthrough.config_term $ cmd_file) in

     

       
57
       
 
       
  let info = Cmd.info "passthrough" in

     

···

       
27
       
 
       


     

       
28
       
 
       
  val run :

     

       
29
       
 
       
    config ->

     

       
0
       
 
       

     

       
30
       
 
       
    Eio.Fs.dir_ty Eio.Path.t ->

     

       
31
       
 
       
    _ Eio.Time.clock ->

     

       
32
       
 
       
    Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     

···

       
27
       
 
       


     

       
28
       
 
       
  val run :

     

       
29
       
 
       
    config ->

     

       
30
       
+
       
    stdout:Eio.Flow.sink_ty Eio.Flow.sink ->

     

       
31
       
 
       
    Eio.Fs.dir_ty Eio.Path.t ->

     

       
32
       
 
       
    _ Eio.Time.clock ->

     

       
33
       
 
       
    Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     

···

       
37
       
 
       
      in

     

       
38
       
 
       
      List.iter (fun v -> LNoise.history_add v |> ignore) entries

     

       
39
       
 
       


     

       
40
       
-
       
let run (() : config) _fs clock proc

     

       
41
       
 
       
    ( ((Shelter.History.Store ((module S), store) : entry Shelter.History.t) as

     

       
42
       
 
       
       full_store),

     

       
43
       
 
       
      () ) (Exec command) =

     

···

       
37
       
 
       
      in

     

       
38
       
 
       
      List.iter (fun v -> LNoise.history_add v |> ignore) entries

     

       
39
       
 
       


     

       
40
       
+
       
let run (() : config) ~stdout:_ _fs clock proc

     

       
41
       
 
       
    ( ((Shelter.History.Store ((module S), store) : entry Shelter.History.t) as

     

       
42
       
 
       
       full_store),

     

       
43
       
 
       
      () ) (Exec command) =

     

···

       
5
       
 
       
module Make (H : History.S) (Engine : Engine.S with type entry = H.t) = struct

     

       
6
       
 
       
  module Store = Irmin_fs_unix.KV.Make (H)

     

       
7
       
 
       


     

       
8
       
-
       
  let run config fs clock proc store =

     

       
9
       
 
       
    let store = History.Store ((module Store), store) in

     

       
10
       
 
       
    let initial_ctx = Engine.init fs proc store in

     

       
11
       
 
       
    let rec loop store ctx exit_code =

     
···

       
14
       
 
       
      | None -> ()

     

       
15
       
 
       
      | Some input -> (

     

       
16
       
 
       
          let action = Engine.action_of_command input in

     

       
17
       
-
       
          match Engine.run config fs clock proc (store, ctx) action with

     

       
18
       
 
       
          | Error (Eio.Process.Child_error exit_code) ->

     

       
19
       
 
       
              Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       
20
       
 
       
              loop store ctx exit_code

     
···

       
29
       
 
       
    Eio.Path.load cf |> String.split_on_char '\n'

     

       
30
       
 
       
    |> List.map Engine.action_of_command

     

       
31
       
 
       


     

       
32
       
-
       
  let main config fs clock proc directory command_file =

     

       
33
       
 
       
    Irmin_fs.run directory @@ fun () ->

     

       
34
       
 
       
    let conf = Irmin_fs.config (Eio.Path.native_exn directory) in

     

       
35
       
 
       
    let repo = Store.Repo.v conf in

     
···

       
42
       
 
       
        let folder (store, ctx, exit_code) action =

     

       
43
       
 
       
          if exit_code <> `Exited 0 then (store, ctx, exit_code)

     

       
44
       
 
       
          else

     

       
45
       
-
       
            match Engine.run config fs clock proc (store, ctx) action with

     

       
0
       
 
       

     

       
0
       
 
       

     

       
46
       
 
       
            | Error (Eio.Process.Child_error exit_code) ->

     

       
47
       
 
       
                Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       
48
       
 
       
                (store, ctx, exit_code)

     
···

       
59
       
 
       
        | `Exited n | `Signaled n ->

     

       
60
       
 
       
            Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       
61
       
 
       
            exit n)

     

       
62
       
-
       
    | None -> run config fs clock proc store

     

       
63
       
 
       
end

     

···

       
5
       
 
       
module Make (H : History.S) (Engine : Engine.S with type entry = H.t) = struct

     

       
6
       
 
       
  module Store = Irmin_fs_unix.KV.Make (H)

     

       
7
       
 
       


     

       
8
       
+
       
  let run config ~stdout fs clock proc store =

     

       
9
       
 
       
    let store = History.Store ((module Store), store) in

     

       
10
       
 
       
    let initial_ctx = Engine.init fs proc store in

     

       
11
       
 
       
    let rec loop store ctx exit_code =

     
···

       
14
       
 
       
      | None -> ()

     

       
15
       
 
       
      | Some input -> (

     

       
16
       
 
       
          let action = Engine.action_of_command input in

     

       
17
       
+
       
          match Engine.run config ~stdout fs clock proc (store, ctx) action with

     

       
18
       
 
       
          | Error (Eio.Process.Child_error exit_code) ->

     

       
19
       
 
       
              Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       
20
       
 
       
              loop store ctx exit_code

     
···

       
29
       
 
       
    Eio.Path.load cf |> String.split_on_char '\n'

     

       
30
       
 
       
    |> List.map Engine.action_of_command

     

       
31
       
 
       


     

       
32
       
+
       
  let main config ~stdout fs clock proc directory command_file =

     

       
33
       
 
       
    Irmin_fs.run directory @@ fun () ->

     

       
34
       
 
       
    let conf = Irmin_fs.config (Eio.Path.native_exn directory) in

     

       
35
       
 
       
    let repo = Store.Repo.v conf in

     
···

       
42
       
 
       
        let folder (store, ctx, exit_code) action =

     

       
43
       
 
       
          if exit_code <> `Exited 0 then (store, ctx, exit_code)

     

       
44
       
 
       
          else

     

       
45
       
+
       
            match

     

       
46
       
+
       
              Engine.run config ~stdout fs clock proc (store, ctx) action

     

       
47
       
+
       
            with

     

       
48
       
 
       
            | Error (Eio.Process.Child_error exit_code) ->

     

       
49
       
 
       
                Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       
50
       
 
       
                (store, ctx, exit_code)

     
···

       
61
       
 
       
        | `Exited n | `Signaled n ->

     

       
62
       
 
       
            Fmt.epr "%a\n%!" Eio.Process.pp_status exit_code;

     

       
63
       
 
       
            exit n)

     

       
64
       
+
       
    | None -> run config ~stdout fs clock proc store

     

       
65
       
 
       
end

     

···

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
1
       
 
       
(library

     

       
2
       
 
       
 (name shelter_main)

     

       
3
       
 
       
 (public_name shelter.main)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
4
       
 
       
 (preprocess

     

       
5
       
-
       
  (pps ppx_repr))

     

       
6
       
 
       
 (libraries shelter cid void zfs))

     

···

       
1
       
+
       
; (rule

     

       
2
       
+
       
;   (target opentrace)

     

       
3
       
+
       
;   (action

     

       
4
       
+
       
;     (with-stdout-to opentrace (run echo hello))))

     

       
5
       
+
       


     

       
6
       
 
       
(library

     

       
7
       
 
       
 (name shelter_main)

     

       
8
       
 
       
 (public_name shelter.main)

     

       
9
       
+
       
 (preprocessor_deps

     

       
10
       
+
       
  (file opentrace))

     

       
11
       
 
       
 (preprocess

     

       
12
       
+
       
  (pps ppx_repr ppx_blob))

     

       
13
       
 
       
 (libraries shelter cid void zfs))

     

···

       
31
       
 
       
        ("options", `List (List.map (fun x -> `String x) options));

     

       
32
       
 
       
      ]

     

       
33
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
34
       
 
       
  let strings xs = `List (List.map (fun x -> `String x) xs)

     

       
35
       
 
       
  let namespace x = `Assoc [ ("type", `String x) ]

     

       
36
       
 
       


     
···

       
112
       
 
       
    network : string list;

     

       
113
       
 
       
    user : int * int;

     

       
114
       
 
       
    env : string list;

     

       
0
       
 
       

     

       
115
       
 
       
    entrypoint : string option;

     

       
116
       
 
       
  }

     

       
117
       
 
       


     

       
118
       
-
       
  let make { cwd; argv; hostname; network; user; env; entrypoint } ~config_dir

     

       
119
       
-
       
      ~results_dir : Yojson.Safe.t =

     

       
120
       
 
       
    assert (entrypoint = None);

     

       
121
       
 
       
    let user =

     

       
122
       
 
       
      let uid, gid = user in

     
···

       
161
       
 
       
                    `Assoc

     

       
162
       
 
       
                      [

     

       
163
       
 
       
                        ("type", `String "RLIMIT_NOFILE");

     

       
164
       
-
       
                        ("hard", `Int 1024);

     

       
165
       
-
       
                        ("soft", `Int 1024);

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
166
       
 
       
                      ];

     

       
167
       
 
       
                  ] );

     

       
168
       
 
       
              ("noNewPrivileges", `Bool false);

     
···

       
180
       
 
       
               ~options:

     

       
181
       
 
       
                 [ (* TODO: copy to others? *) "nosuid"; "noexec"; "nodev" ]

     

       
182
       
 
       
               ~ty:"proc" ~src:"proc"

     

       
183
       
-
       
            :: mount "/dev" ~ty:"tmpfs" ~src:"tmpfs"

     

       
184
       
-
       
                 ~options:[ "nosuid"; "strictatime"; "mode=755"; "size=65536k" ]

     

       
185
       
-
       
            :: mount "/dev/pts" ~ty:"devpts" ~src:"devpts"

     

       
186
       
-
       
                 ~options:

     

       
187
       
-
       
                   [

     

       
188
       
-
       
                     "nosuid";

     

       
189
       
-
       
                     "noexec";

     

       
190
       
-
       
                     "newinstance";

     

       
191
       
-
       
                     "ptmxmode=0666";

     

       
192
       
-
       
                     "mode=0620";

     

       
193
       
-
       
                     "gid=5";

     

       
194
       
-
       
                     (* tty *)

     

       
195
       
-
       
                   ]

     

       
196
       
-
       
            :: mount

     

       
197
       
-
       
                 "/sys"

     

       
198
       
-
       
                 (* This is how Docker does it. runc's default is a bit different. *)

     

       
199
       
-
       
                 ~ty:"sysfs" ~src:"sysfs"

     

       
200
       
-
       
                 ~options:[ "nosuid"; "noexec"; "nodev"; "ro" ]

     

       
201
       
-
       
            :: mount "/sys/fs/cgroup" ~ty:"cgroup" ~src:"cgroup"

     

       
202
       
-
       
                 ~options:[ "ro"; "nosuid"; "noexec"; "nodev" ]

     

       
203
       
-
       
            :: mount "/dev/shm" ~ty:"tmpfs" ~src:"shm"

     

       
204
       
-
       
                 ~options:

     

       
205
       
-
       
                   [ "nosuid"; "noexec"; "nodev"; "mode=1777"; "size=65536k" ]

     

       
206
       
-
       
            :: mount "/dev/mqueue" ~ty:"mqueue" ~src:"mqueue"

     

       
207
       
-
       
                 ~options:[ "nosuid"; "noexec"; "nodev" ]

     

       
208
       
-
       
            :: mount "/etc/hosts" ~ty:"bind" ~src:(config_dir // "hosts")

     

       
209
       
-
       
                 ~options:[ "ro"; "rbind"; "rprivate" ]

     

       
210
       
-
       
            ::

     

       
211
       
-
       
            (if network = [ "host" ] then

     

       
212
       
-
       
               [

     

       
213
       
-
       
                 mount "/etc/resolv.conf" ~ty:"bind" ~src:"/etc/resolv.conf"

     

       
214
       
-
       
                   ~options:[ "ro"; "rbind"; "rprivate" ];

     

       
215
       
-
       
               ]

     

       
216
       
-
       
             else [])) );

     

       
0
       
 
       

     

       
0
       
 
       

     

       
217
       
 
       
        ( "linux",

     

       
218
       
 
       
          `Assoc

     

       
219
       
 
       
            [

     
···

       
248
       
 
       


     

       
249
       
 
       
let next_id = ref 0

     

       
250
       
 
       


     

       
251
       
-
       
let spawn ~sw fs proc config dir =

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
252
       
 
       
  let tmp = Filename.temp_dir ~perms:0o700 "shelter-run-" "" in

     

       
253
       
-
       
  let eio_tmp = Eio.Path.(fs / tmp) in

     

       
254
       
 
       
  let json_config = Json_config.make config ~config_dir:tmp ~results_dir:dir in

     

       
255
       
 
       
  Eio.Path.save ~create:(`If_missing 0o644) (eio_tmp / "config.json")

     

       
256
       
 
       
    (Yojson.Safe.pretty_to_string json_config ^ "\n");

     
···

       
259
       
 
       
  let id = string_of_int !next_id in

     

       
260
       
 
       
  incr next_id;

     

       
261
       
 
       
  let cmd = [ "runc"; "--root"; "runc"; "run"; id ] in

     

       
262
       
-
       
  Eio.Process.spawn ~sw proc ~cwd:eio_tmp cmd

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
263
       
 
       


     

       
264
       
 
       
(* 

     

       
265
       
 
       
                                 Apache License

     

···

       
31
       
 
       
        ("options", `List (List.map (fun x -> `String x) options));

     

       
32
       
 
       
      ]

     

       
33
       
 
       


     

       
34
       
+
       
  type mount = { ty : [ `Bind ]; src : string; dst : string; readonly : bool }

     

       
35
       
+
       


     

       
36
       
+
       
  let user_mounts =

     

       
37
       
+
       
    List.map @@ fun { ty; src; dst; readonly } ->

     

       
38
       
+
       
    assert (ty = `Bind);

     

       
39
       
+
       
    let options = [ "bind"; "nosuid"; "nodev" ] in

     

       
40
       
+
       
    mount ~ty:"bind" ~src dst

     

       
41
       
+
       
      ~options:(if readonly then "ro" :: options else options)

     

       
42
       
+
       


     

       
43
       
 
       
  let strings xs = `List (List.map (fun x -> `String x) xs)

     

       
44
       
 
       
  let namespace x = `Assoc [ ("type", `String x) ]

     

       
45
       
 
       


     
···

       
121
       
 
       
    network : string list;

     

       
122
       
 
       
    user : int * int;

     

       
123
       
 
       
    env : string list;

     

       
124
       
+
       
    mounts : mount list;

     

       
125
       
 
       
    entrypoint : string option;

     

       
126
       
 
       
  }

     

       
127
       
 
       


     

       
128
       
+
       
  let make { cwd; argv; hostname; network; user; env; mounts; entrypoint }

     

       
129
       
+
       
      ~config_dir ~results_dir : Yojson.Safe.t =

     

       
130
       
 
       
    assert (entrypoint = None);

     

       
131
       
 
       
    let user =

     

       
132
       
 
       
      let uid, gid = user in

     
···

       
171
       
 
       
                    `Assoc

     

       
172
       
 
       
                      [

     

       
173
       
 
       
                        ("type", `String "RLIMIT_NOFILE");

     

       
174
       
+
       
                        ("hard", `Int 10_024);

     

       
175
       
+
       
                        ("soft", `Int 10_024);

     

       
176
       
+
       
                      ];

     

       
177
       
+
       
                    `Assoc

     

       
178
       
+
       
                      [

     

       
179
       
+
       
                        ("type", `String "RLIMIT_MEMLOCK");

     

       
180
       
+
       
                        ("hard", `Int 1_000_000);

     

       
181
       
+
       
                        ("soft", `Int 1_000_000);

     

       
182
       
 
       
                      ];

     

       
183
       
 
       
                  ] );

     

       
184
       
 
       
              ("noNewPrivileges", `Bool false);

     
···

       
196
       
 
       
               ~options:

     

       
197
       
 
       
                 [ (* TODO: copy to others? *) "nosuid"; "noexec"; "nodev" ]

     

       
198
       
 
       
               ~ty:"proc" ~src:"proc"

     

       
199
       
+
       
             :: mount "/dev" ~ty:"tmpfs" ~src:"tmpfs"

     

       
200
       
+
       
                  ~options:

     

       
201
       
+
       
                    [ "nosuid"; "strictatime"; "mode=755"; "size=65536k" ]

     

       
202
       
+
       
             :: mount "/dev/pts" ~ty:"devpts" ~src:"devpts"

     

       
203
       
+
       
                  ~options:

     

       
204
       
+
       
                    [

     

       
205
       
+
       
                      "nosuid";

     

       
206
       
+
       
                      "noexec";

     

       
207
       
+
       
                      "newinstance";

     

       
208
       
+
       
                      "ptmxmode=0666";

     

       
209
       
+
       
                      "mode=0620";

     

       
210
       
+
       
                      "gid=5";

     

       
211
       
+
       
                      (* tty *)

     

       
212
       
+
       
                    ]

     

       
213
       
+
       
             :: mount

     

       
214
       
+
       
                  "/sys"

     

       
215
       
+
       
                  (* This is how Docker does it. runc's default is a bit different. *)

     

       
216
       
+
       
                  ~ty:"sysfs" ~src:"sysfs"

     

       
217
       
+
       
                  ~options:[ "nosuid"; "noexec"; "nodev"; "ro" ]

     

       
218
       
+
       
             :: mount "/sys/fs/cgroup" ~ty:"cgroup" ~src:"cgroup"

     

       
219
       
+
       
                  ~options:[ "ro"; "nosuid"; "noexec"; "nodev" ]

     

       
220
       
+
       
             :: mount "/dev/shm" ~ty:"tmpfs" ~src:"shm"

     

       
221
       
+
       
                  ~options:

     

       
222
       
+
       
                    [ "nosuid"; "noexec"; "nodev"; "mode=1777"; "size=65536k" ]

     

       
223
       
+
       
             :: mount "/dev/mqueue" ~ty:"mqueue" ~src:"mqueue"

     

       
224
       
+
       
                  ~options:[ "nosuid"; "noexec"; "nodev" ]

     

       
225
       
+
       
             :: mount "/etc/hosts" ~ty:"bind" ~src:(config_dir // "hosts")

     

       
226
       
+
       
                  ~options:[ "ro"; "rbind"; "rprivate" ]

     

       
227
       
+
       
             ::

     

       
228
       
+
       
             (if network = [ "host" ] then

     

       
229
       
+
       
                [

     

       
230
       
+
       
                  mount "/etc/resolv.conf" ~ty:"bind" ~src:"/etc/resolv.conf"

     

       
231
       
+
       
                    ~options:[ "ro"; "rbind"; "rprivate" ];

     

       
232
       
+
       
                ]

     

       
233
       
+
       
              else [])

     

       
234
       
+
       
            @ user_mounts mounts) );

     

       
235
       
 
       
        ( "linux",

     

       
236
       
 
       
          `Assoc

     

       
237
       
 
       
            [

     
···

       
266
       
 
       


     

       
267
       
 
       
let next_id = ref 0

     

       
268
       
 
       


     

       
269
       
+
       
let to_other_sink_as_well ~other

     

       
270
       
+
       
    (Eio.Resource.T (t, handler) : Eio.Flow.sink_ty Eio.Flow.sink) =

     

       
271
       
+
       
  let module Sink = (val Eio.Resource.get handler Eio.Flow.Pi.Sink) in

     

       
272
       
+
       
  let copy_buf = Buffer.create 128 in

     

       
273
       
+
       
  let copy () ~src =

     

       
274
       
+
       
    Eio.Flow.copy src (Eio.Flow.buffer_sink copy_buf);

     

       
275
       
+
       
    Eio.Flow.copy_string (Buffer.contents copy_buf) other;

     

       
276
       
+
       
    Sink.copy t ~src:(Buffer.contents copy_buf |> Eio.Flow.string_source);

     

       
277
       
+
       
    Buffer.clear copy_buf

     

       
278
       
+
       
  in

     

       
279
       
+
       
  let single_write () x =

     

       
280
       
+
       
    let _ : int = Eio.Flow.single_write other x in

     

       
281
       
+
       
    Sink.single_write t x

     

       
282
       
+
       
  in

     

       
283
       
+
       
  let module T = struct

     

       
284
       
+
       
    type t = unit

     

       
285
       
+
       


     

       
286
       
+
       
    let single_write = single_write

     

       
287
       
+
       
    let copy = copy

     

       
288
       
+
       
  end in

     

       
289
       
+
       
  Eio.Resource.T ((), Eio.Flow.Pi.sink (module T))

     

       
290
       
+
       


     

       
291
       
+
       
let spawn ~sw log env config dir =

     

       
292
       
 
       
  let tmp = Filename.temp_dir ~perms:0o700 "shelter-run-" "" in

     

       
293
       
+
       
  let eio_tmp = Eio.Path.(env#fs / tmp) in

     

       
294
       
 
       
  let json_config = Json_config.make config ~config_dir:tmp ~results_dir:dir in

     

       
295
       
 
       
  Eio.Path.save ~create:(`If_missing 0o644) (eio_tmp / "config.json")

     

       
296
       
 
       
    (Yojson.Safe.pretty_to_string json_config ^ "\n");

     
···

       
299
       
 
       
  let id = string_of_int !next_id in

     

       
300
       
 
       
  incr next_id;

     

       
301
       
 
       
  let cmd = [ "runc"; "--root"; "runc"; "run"; id ] in

     

       
302
       
+
       
  let stdout =

     

       
303
       
+
       
    to_other_sink_as_well ~other:env#stdout

     

       
304
       
+
       
      (log :> Eio.Flow.sink_ty Eio.Flow.sink)

     

       
305
       
+
       
  in

     

       
306
       
+
       
  Eio.Process.spawn ~stdout ~sw env#proc ~cwd:eio_tmp cmd

     

       
307
       
 
       


     

       
308
       
 
       
(* 

     

       
309
       
 
       
                                 Apache License

     

···

       
11
       
 
       
        | "R" -> Void.R | "RW" -> Void.RW | _ -> failwith "Malformed Void.mode")

     

       
12
       
 
       
      (function Void.R -> "R" | Void.RW -> "RW")

     

       
13
       
 
       


     

       
14
       
-
       
  type t = {

     

       
0
       
 
       

     

       
0
       
 
       

     

       
15
       
 
       
    mode : mode;

     

       
16
       
 
       
    build : Store.Build.t;

     

       
17
       
 
       
    args : string list;

     

       
18
       
-
       
    time : int64;

     

       
19
       
 
       
    env : string list;

     

       
20
       
 
       
    cwd : string;

     

       
21
       
 
       
    user : int * int;

     

       
22
       
-
       
    diff : Diff.t;

     

       
23
       
 
       
  }

     

       
24
       
 
       
  [@@deriving repr]

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
25
       
 
       


     

       
26
       
 
       
  let merge = Irmin.Merge.(default (Repr.option t))

     

       
27
       
 
       
end

     
···

       
33
       
 
       
type entry = History.t

     

       
34
       
 
       


     

       
35
       
 
       
type action =

     

       
0
       
 
       

     

       
36
       
 
       
  | Set_mode of History.mode

     

       
0
       
 
       

     

       
0
       
 
       

     

       
37
       
 
       
  | Set_session of string

     

       
0
       
 
       

     

       
38
       
 
       
  | Exec of string list

     

       
39
       
-
       
  | Info

     

       
40
       
 
       
  | Undo

     

       
41
       
-
       
  | Fork of string

     

       
42
       
 
       
  | Replay of string

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
43
       
 
       
  | Unknown of string list

     

       
44
       
-
       
  | History

     

       
45
       
 
       
[@@deriving repr]

     

       
46
       
 
       


     

       
47
       
 
       
let split_and_remove_empty s =

     
···

       
51
       
 
       


     

       
52
       
 
       
let shelter_action = function

     

       
53
       
 
       
  | "mode" :: [ "r" ] -> Set_mode R

     

       
54
       
-
       
  | "mode" :: [ "rw" ] -> Set_mode R

     

       
55
       
 
       
  | "session" :: [ m ] -> Set_session m

     

       
56
       
-
       
  | "fork" :: [ m ] -> Fork m

     

       
57
       
 
       
  | "replay" :: [ onto ] -> Replay onto

     

       
58
       
-
       
  | [ "info" ] -> Info

     

       
59
       
 
       
  | [ "undo" ] -> Undo

     

       
60
       
-
       
  | [ "history" ] -> History

     

       
61
       
 
       
  | other -> Unknown other

     

       
62
       
 
       


     

       
63
       
 
       
let action_of_command cmd =

     
···

       
69
       
 
       
let history_key = [ "history" ]

     

       
70
       
 
       
let key clock = history_key @ [ string_of_float @@ Eio.Time.now clock ]

     

       
71
       
 
       


     

       
72
       
-
       
let list (H.Store ((module S), store) : entry H.t) =

     

       
73
       
-
       
  match S.list store history_key with

     

       
74
       
-
       
  | [] -> []

     

       
75
       
-
       
  | xs ->

     

       
76
       
-
       
      let rec loop acc = function

     

       
77
       
-
       
        | (s, `Contents (v, _meta)) :: next -> loop ((s, v) :: acc) next

     

       
78
       
-
       
        | _ :: next -> loop acc next

     

       
79
       
-
       
        | [] -> List.rev acc

     

       
0
       
 
       

     

       
80
       
 
       
      in

     

       
81
       
-
       
      loop [] (List.map (fun (v, tree) -> (v, S.Tree.to_concrete tree)) xs)

     

       
82
       
-
       
      |> List.stable_sort (fun (s1, _) (s2, _) ->

     

       
83
       
-
       
             Float.compare (Float.of_string s1) (Float.of_string s2))

     

       
84
       
-
       
      |> List.rev

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
85
       
 
       


     

       
86
       
 
       
let with_latest ~default s f =

     

       
87
       
-
       
  match list s with [] -> default () | hd :: _ -> f hd

     

       
88
       
 
       


     

       
89
       
 
       
let text c = Fmt.(styled (`Fg c) string)

     

       
90
       
 
       


     
···

       
100
       
 
       
  let repo = S.repo session in

     

       
101
       
 
       
  let heads = List.map (fun b -> (S.Branch.find repo b, b)) branches in

     

       
102
       
 
       
  let head = S.Head.find session in

     

       
103
       
-
       
  List.assoc_opt head heads

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
104
       
 
       


     

       
105
       
 
       
(* Reset the head of the current session by one commit *)

     

       
106
       
 
       
let reset_hard ((H.Store ((module S), session) : entry H.t) as s) =

     
···

       
127
       
 
       
      Ok store

     

       
128
       
 
       


     

       
129
       
 
       
(* Fork a new session from an existing one *)

     

       
130
       
-
       
let display_history (H.Store ((module S), session) : entry H.t) =

     

       
131
       
-
       
  let history = S.history ~depth:max_int session in

     

       
132
       
-
       
  let content c =

     

       
133
       
-
       
    H.Store ((module S), S.of_commit c) |> list |> List.hd |> snd

     

       
134
       
-
       
  in

     

       
135
       
 
       
  let pp_diff fmt d =

     

       
136
       
 
       
    if d = [] then () else Fmt.pf fmt "\n  %a" (Repr.pp Diff.t) d

     

       
137
       
 
       
  in

     

       
138
       
 
       
  let pp_entry fmt (e : entry) =

     

       
139
       
 
       
    Fmt.pf fmt "%-10s %s%a"

     

       
140
       
-
       
      Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.time)

     

       
141
       
-
       
      (String.concat " " e.args) pp_diff e.diff

     

       
0
       
 
       

     

       
142
       
 
       
  in

     

       
143
       
-
       
  let linearize =

     

       
144
       
-
       
    S.History.fold_vertex (fun c v -> content c :: v) history [] |> List.rev

     

       
145
       
-
       
  in

     

       
146
       
-
       
  List.iter (fun c -> Fmt.pr "%a\n%!" pp_entry c) linearize

     

       
147
       
 
       


     

       
148
       
 
       
let prompt status ((H.Store ((module S), _session) : entry H.t) as store) =

     

       
149
       
-
       
  let sesh = Option.value ~default:"main" (which_branch store) in

     

       
0
       
 
       

     

       
150
       
 
       
  let prompt () =

     

       
151
       
 
       
    Fmt.(styled (`Fg `Yellow) string) Format.str_formatter "shelter> ";

     

       
152
       
 
       
    Format.flush_str_formatter ()

     

       
153
       
 
       
  in

     

       
154
       
-
       
  let pp_sesh fmt sesh = Fmt.pf fmt "[%a]" (text `Green) sesh in

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
155
       
 
       
  let pp_status fmt = function

     

       
156
       
 
       
    | `Exited 0 -> Fmt.nop fmt ()

     

       
157
       
 
       
    | `Exited n -> Fmt.pf fmt "%a " (text `Red) (string_of_int n)

     

       
158
       
 
       
    | _ -> Fmt.nop fmt ()

     

       
159
       
 
       
  in

     

       
160
       
-
       
  let prompt_entry (_, (e : entry)) =

     

       
161
       
 
       
    Fmt.pf Format.str_formatter "%a%a%a : { mode: %a }> " pp_status status

     

       
162
       
 
       
      (text `Yellow) "shelter" pp_sesh sesh (text `Red)

     

       
163
       
-
       
      (if e.mode = R then "r" else "rw");

     

       
164
       
 
       
    Format.flush_str_formatter ()

     

       
165
       
 
       
  in

     

       
166
       
 
       
  with_latest store ~default:prompt prompt_entry

     

       
167
       
 
       


     

       
168
       
-
       
type ctx = Store.t

     

       
0
       
 
       

     

       
0
       
 
       

     

       
169
       
 
       


     

       
170
       
 
       
let init fs proc s =

     

       
171
       
 
       
  let store = Store.init fs proc "shelter" in

     

       
172
       
 
       
  List.iter

     

       
173
       
-
       
    (fun (_, { History.args; _ }) ->

     

       
174
       
 
       
      LNoise.history_add (String.concat " " args) |> ignore)

     

       
175
       
-
       
    (list s);

     

       
176
       
-
       
  store

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
177
       
 
       


     

       
178
       
-
       
let run (config : config) fs clock proc

     

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

     

       
180
       
 
       
  | Set_mode mode ->

     

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

     

       
182
       
-
       
      commit ~message:"mode change" clock s { entry with mode };

     

       
0
       
 
       

     

       
183
       
 
       
      Ok (s, ctx)

     

       
184
       
-
       
  | Set_session m ->

     

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

     

       
186
       
-
       
      let new_store = S.of_branch (S.repo store) m in

     

       
187
       
-
       
      let new_full_store = H.Store ((module S), new_store) in

     

       
188
       
-
       
      commit ~message:"new session" clock new_full_store entry;

     

       
189
       
-
       
      Ok (new_full_store, ctx)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
190
       
 
       
  | Unknown args ->

     

       
191
       
 
       
      Fmt.epr "%a: %s\n%!" (text `Red) "Unknown Shelter Action"

     

       
192
       
 
       
        (String.concat " " args);

     

       
193
       
 
       
      Ok (s, ctx)

     

       
194
       
-
       
  | Info ->

     

       
195
       
 
       
      let sessions = sessions s in

     

       
196
       
-
       
      let sesh = Option.value ~default:"main" (which_branch s) in

     

       
197
       
-
       
      let history = S.history store in

     

       
198
       
 
       
      let pp_commit fmt (hash, msg) =

     

       
199
       
 
       
        Fmt.pf fmt "[%a]: %s" (text `Yellow) hash msg

     

       
200
       
 
       
      in

     

       
0
       
 
       

     

       
201
       
 
       
      let commits =

     

       
202
       
-
       
        S.History.fold_vertex

     

       
203
       
-
       
          (fun commit acc ->

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
204
       
 
       
            let info = S.Commit.info commit |> S.Info.message in

     

       
205
       
 
       
            let hash = S.Commit.hash commit |> Repr.to_string S.Hash.t in

     

       
206
       
 
       
            (String.sub hash 0 7, info) :: acc)

     

       
207
       
-
       
          history []

     

       
208
       
 
       
      in

     

       
209
       
 
       
      let latest =

     

       
210
       
 
       
        with_latest

     

       
211
       
 
       
          ~default:(fun () -> None)

     

       
212
       
 
       
          s

     

       
213
       
-
       
          (fun (_, e) -> Some (Repr.to_string Store.Build.t e.build))

     

       
214
       
 
       
      in

     

       
215
       
 
       
      Fmt.pr "Sessions: %a\nCurrent: %a\nHash: %a\nCommits:@.  %a\n%!"

     

       
216
       
 
       
        Fmt.(list ~sep:(Fmt.any ", ") string)

     
···

       
222
       
 
       
      Ok (s, ctx)

     

       
223
       
 
       
  | Exec [] -> Ok (s, ctx)

     

       
224
       
 
       
  | Undo -> Ok (reset_hard s, ctx)

     

       
225
       
-
       
  | Fork new_branch -> (

     

       
226
       
-
       
      match fork s new_branch with

     

       
227
       
-
       
      | Error err ->

     

       
228
       
-
       
          Fmt.pr "[fork]: %a\n%!" (text `Red) err;

     

       
229
       
-
       
          Ok (s, ctx)

     

       
230
       
-
       
      | Ok store -> Ok (store, ctx))

     

       
231
       
 
       
  | Replay _ -> Ok (s, ctx)

     

       
232
       
-
       
  | History ->

     

       
233
       
 
       
      display_history s;

     

       
234
       
 
       
      Ok (s, ctx)

     

       
235
       
 
       
  | Exec command -> (

     
···

       
238
       
 
       
          ~default:(fun () ->

     

       
239
       
 
       
            History.

     

       
240
       
 
       
              {

     

       
241
       
-
       
                mode = Void.RW;

     

       
242
       
-
       
                build = Store.Build.Image config.image;

     

       
243
       
-
       
                args = command;

     

       
244
       
-
       
                time = 0L;

     

       
245
       
-
       
                diff = [];

     

       
246
       
-
       
                (* TODO: extract with fetch *)

     

       
247
       
-
       
                env = [];

     

       
248
       
-
       
                cwd = "/";

     

       
249
       
-
       
                user = (0, 0);

     

       
0
       
 
       

     

       
0
       
 
       

     

       
250
       
 
       
              })

     

       
251
       
 
       
          s

     

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

     

       
253
       
 
       
      in

     

       
254
       
 
       
      let build, env, (uid, gid) =

     

       
255
       
-
       
        match entry.build with

     

       
256
       
 
       
        | Store.Build.Image img ->

     

       
257
       
-
       
            let build, env, user = Store.fetch ctx img in

     

       
258
       
 
       
            (build, env, Option.value ~default:(0, 0) user)

     

       
259
       
-
       
        | Store.Build.Build cid -> (cid, entry.env, entry.user)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
260
       
 
       
      in

     

       
261
       
-
       
      let hash_entry = { entry with build = Build build; args = command } in

     

       
262
       
-
       
      let new_cid = Store.cid (Repr.to_string History.t hash_entry) in

     

       
0
       
 
       

     

       
0
       
 
       

     

       
263
       
 
       
      let with_rootfs fn =

     

       
264
       
-
       
        if entry.mode = R then (Store.Run.with_build ctx build fn, [])

     

       
265
       
-
       
        else Store.Run.with_clone ctx ~src:build new_cid fn

     

       
266
       
 
       
      in

     

       
267
       
 
       
      try

     

       
268
       
 
       
        let new_entry, diff =

     

       
269
       
-
       
          with_rootfs @@ fun rootfs ->

     

       
270
       
-
       
          let spawn sw =

     

       
271
       
-
       
            if config.no_runc then

     

       
272
       
-
       
              let rootfs = Filename.concat rootfs "rootfs" in

     

       
273
       
-
       
              let void =

     

       
274
       
-
       
                Void.empty

     

       
275
       
-
       
                |> Void.rootfs ~mode:entry.mode rootfs

     

       
276
       
-
       
                |> Void.cwd entry.cwd

     

       
277
       
-
       
                (* TODO: Support UIDs |> Void.uid 1000 *)

     

       
278
       
-
       
                |> Void.exec ~env

     

       
279
       
-
       
                     [

     

       
280
       
-
       
                       config.shell;

     

       
281
       
-
       
                       "-c";

     

       
282
       
-
       
                       String.concat " " command ^ " && env > /tmp/shelter-env";

     

       
283
       
-
       
                     ]

     

       
284
       
 
       
              in

     

       
285
       
-
       
              `Void (Void.spawn ~sw void |> Void.exit_status)

     

       
286
       
-
       
            else

     

       
287
       
-
       
              let config =

     

       
288
       
-
       
                Runc.Json_config.

     

       
289
       
-
       
                  {

     

       
290
       
-
       
                    cwd = entry.cwd;

     

       
291
       
-
       
                    argv =

     

       
292
       
-
       
                      [

     

       
293
       
-
       
                        config.shell;

     

       
294
       
-
       
                        "-c";

     

       
295
       
-
       
                        String.concat " " command ^ " && env > /tmp/shelter-env";

     

       
296
       
-
       
                      ];

     

       
297
       
-
       
                    hostname = "";

     

       
298
       
-
       
                    network = [];

     

       
299
       
-
       
                    user = (uid, gid);

     

       
300
       
-
       
                    env = entry.env;

     

       
301
       
-
       
                    entrypoint = None;

     

       
302
       
-
       
                  }

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
303
       
 
       
              in

     

       
304
       
-
       
              `Runc (Runc.spawn ~sw fs proc config rootfs)

     

       
305
       
-
       
          in

     

       
306
       
-
       
          Switch.run @@ fun sw ->

     

       
307
       
-
       
          let res = spawn sw in

     

       
308
       
-
       
          let start = Mtime_clock.now () in

     

       
309
       
-
       
          let res =

     

       
310
       
-
       
            match res with

     

       
311
       
-
       
            | `Runc r -> Eio.Process.await r

     

       
312
       
-
       
            | `Void v -> Void.to_eio_status (Eio.Promise.await v)

     

       
313
       
-
       
          in

     

       
314
       
-
       
          let stop = Mtime_clock.now () in

     

       
315
       
-
       
          let span = Mtime.span start stop in

     

       
316
       
-
       
          let time = Mtime.Span.to_uint64_ns span in

     

       
317
       
-
       
          (* Add command to history regardless of exit status *)

     

       
318
       
-
       
          let _ : (unit, string) result =

     

       
319
       
-
       
            LNoise.history_add (String.concat " " command)

     

       
320
       
-
       
          in

     

       
321
       
-
       
          if res = `Exited 0 then (

     

       
322
       
-
       
            (* Extract env *)

     

       
323
       
-
       
            let env_path =

     

       
324
       
-
       
              Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env")

     

       
325
       
-
       
            in

     

       
326
       
-
       
            let env =

     

       
327
       
-
       
              Eio.Path.(load env_path)

     

       
328
       
-
       
              |> String.split_on_char '\n'

     

       
329
       
-
       
              |> List.filter (fun s -> not (String.equal "" s))

     

       
330
       
-
       
            in

     

       
331
       
-
       
            Eio.Path.unlink env_path;

     

       
332
       
-
       
            let cwd =

     

       
333
       
-
       
              List.find_map

     

       
334
       
-
       
                (fun v ->

     

       
335
       
-
       
                  match Astring.String.cut ~sep:"=" v with

     

       
336
       
-
       
                  | Some ("PWD", dir) -> Some dir

     

       
337
       
-
       
                  | _ -> None)

     

       
338
       
-
       
                env

     

       
339
       
-
       
              |> Option.value ~default:hash_entry.cwd

     

       
340
       
-
       
            in

     

       
341
       
-
       
            if entry.mode = RW then

     

       
342
       
-
       
              Ok

     

       
343
       
-
       
                {

     

       
344
       
-
       
                  hash_entry with

     

       
345
       
-
       
                  build = Build new_cid;

     

       
346
       
-
       
                  time;

     

       
347
       
-
       
                  env;

     

       
348
       
-
       
                  cwd;

     

       
349
       
-
       
                  user = (uid, gid);

     

       
350
       
-
       
                }

     

       
351
       
-
       
            else Ok { hash_entry with time; cwd; env; user = (uid, gid) })

     

       
352
       
-
       
          else Error (Eio.Process.Child_error res)

     

       
353
       
 
       
        in

     

       
354
       
 
       
        match new_entry with

     

       
355
       
 
       
        | Error e -> Error e

     

       
356
       
-
       
        | Ok entry ->

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
357
       
 
       
            (* Set diff *)

     

       
358
       
-
       
            let entry = { entry with diff } in

     

       
359
       
 
       
            (* Commit if RW *)

     

       
360
       
-
       
            if entry.mode = RW then

     

       
361
       
 
       
              commit

     

       
362
       
 
       
                ~message:("exec " ^ String.concat " " command)

     

       
363
       
 
       
                clock s entry;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
364
       
 
       
            Ok (s, ctx)

     

       
365
       
 
       
      with Eio.Exn.Io (Eio.Process.E e, _) -> Error e)

     

···

       
11
       
 
       
        | "R" -> Void.R | "RW" -> Void.RW | _ -> failwith "Malformed Void.mode")

     

       
12
       
 
       
      (function Void.R -> "R" | Void.RW -> "RW")

     

       
13
       
 
       


     

       
14
       
+
       
  type post = { diff : Diff.t; time : int64 } [@@deriving repr]

     

       
15
       
+
       


     

       
16
       
+
       
  type pre = {

     

       
17
       
 
       
    mode : mode;

     

       
18
       
 
       
    build : Store.Build.t;

     

       
19
       
 
       
    args : string list;

     

       
0
       
 
       

     

       
20
       
 
       
    env : string list;

     

       
21
       
 
       
    cwd : string;

     

       
22
       
 
       
    user : int * int;

     

       
0
       
 
       

     

       
23
       
 
       
  }

     

       
24
       
 
       
  [@@deriving repr]

     

       
25
       
+
       
  (** Needed for execution *)

     

       
26
       
+
       


     

       
27
       
+
       
  type t = { pre : pre; post : post } [@@deriving repr]

     

       
28
       
 
       


     

       
29
       
 
       
  let merge = Irmin.Merge.(default (Repr.option t))

     

       
30
       
 
       
end

     
···

       
36
       
 
       
type entry = History.t

     

       
37
       
 
       


     

       
38
       
 
       
type action =

     

       
39
       
+
       
  (* Change modes *)

     

       
40
       
 
       
  | Set_mode of History.mode

     

       
41
       
+
       
  (* Fork a new branch from an existing one,

     

       
42
       
+
       
     or switch to a branch if it exists *)

     

       
43
       
 
       
  | Set_session of string

     

       
44
       
+
       
  (* Run a command *)

     

       
45
       
 
       
  | Exec of string list

     

       
46
       
+
       
  (* Undo the last command *)

     

       
47
       
 
       
  | Undo

     

       
48
       
+
       
  (* Replay the current branch onto another *)

     

       
49
       
 
       
  | Replay of string

     

       
50
       
+
       
  (* Display info *)

     

       
51
       
+
       
  | Info of [ `Current | `History ]

     

       
52
       
+
       
  (* Error state *)

     

       
53
       
 
       
  | Unknown of string list

     

       
0
       
 
       

     

       
54
       
 
       
[@@deriving repr]

     

       
55
       
 
       


     

       
56
       
 
       
let split_and_remove_empty s =

     
···

       
60
       
 
       


     

       
61
       
 
       
let shelter_action = function

     

       
62
       
 
       
  | "mode" :: [ "r" ] -> Set_mode R

     

       
63
       
+
       
  | "mode" :: [ "rw" ] -> Set_mode RW

     

       
64
       
 
       
  | "session" :: [ m ] -> Set_session m

     

       
0
       
 
       

     

       
65
       
 
       
  | "replay" :: [ onto ] -> Replay onto

     

       
66
       
+
       
  | [ "info" ] -> Info `Current

     

       
67
       
 
       
  | [ "undo" ] -> Undo

     

       
68
       
+
       
  | [ "history" ] -> Info `History

     

       
69
       
 
       
  | other -> Unknown other

     

       
70
       
 
       


     

       
71
       
 
       
let action_of_command cmd =

     
···

       
77
       
 
       
let history_key = [ "history" ]

     

       
78
       
 
       
let key clock = history_key @ [ string_of_float @@ Eio.Time.now clock ]

     

       
79
       
 
       


     

       
80
       
+
       
let history (H.Store ((module S), store) : entry H.t) =

     

       
81
       
+
       
  let repo = S.repo store in

     

       
82
       
+
       
  match S.Head.find store with

     

       
83
       
+
       
  | None -> []

     

       
84
       
+
       
  | Some hd ->

     

       
85
       
+
       
      let rec linearize c =

     

       
86
       
+
       
        match S.Commit.parents c |> List.map (S.Commit.of_hash repo) with

     

       
87
       
+
       
        | [ Some p ] -> c :: linearize p

     

       
88
       
+
       
        | _ -> [ c ]

     

       
89
       
 
       
      in

     

       
90
       
+
       
      let commits = linearize hd in

     

       
91
       
+
       
      let get_diff_content t1 t2 =

     

       
92
       
+
       
        match S.Tree.diff t1 t2 with

     

       
93
       
+
       
        | [ (_, `Added (c, _)) ] -> c

     

       
94
       
+
       
        | lst ->

     

       
95
       
+
       
            let pp_diff =

     

       
96
       
+
       
              Repr.pp (Irmin.Diff.t (Repr.pair History.t S.metadata_t))

     

       
97
       
+
       
            in

     

       
98
       
+
       
            Fmt.epr "Get diff (%i) content %a%!" (List.length lst)

     

       
99
       
+
       
              Fmt.(list ~sep:Fmt.comma (Fmt.pair (Repr.pp S.path_t) pp_diff))

     

       
100
       
+
       
              lst;

     

       
101
       
+
       
            invalid_arg "Get diff should only have a single difference."

     

       
102
       
+
       
      in

     

       
103
       
+
       
      let hash c = S.Commit.hash c |> S.Hash.to_raw_string in

     

       
104
       
+
       
      let rec diff_calc = function

     

       
105
       
+
       
        | [] -> []

     

       
106
       
+
       
        | [ x ] ->

     

       
107
       
+
       
            let diff = get_diff_content (S.Tree.empty ()) (S.Commit.tree x) in

     

       
108
       
+
       
            [ (hash x, diff) ]

     

       
109
       
+
       
        | c :: p :: rest ->

     

       
110
       
+
       
            let diff = get_diff_content (S.Commit.tree p) (S.Commit.tree c) in

     

       
111
       
+
       
            (hash c, diff) :: diff_calc (p :: rest)

     

       
112
       
+
       
      in

     

       
113
       
+
       
      diff_calc commits

     

       
114
       
 
       


     

       
115
       
 
       
let with_latest ~default s f =

     

       
116
       
+
       
  match history s with [] -> default () | (_, hd) :: _ -> f hd

     

       
117
       
 
       


     

       
118
       
 
       
let text c = Fmt.(styled (`Fg c) string)

     

       
119
       
 
       


     
···

       
129
       
 
       
  let repo = S.repo session in

     

       
130
       
 
       
  let heads = List.map (fun b -> (S.Branch.find repo b, b)) branches in

     

       
131
       
 
       
  let head = S.Head.find session in

     

       
132
       
+
       
  let head_hash =

     

       
133
       
+
       
    Option.map

     

       
134
       
+
       
      (fun hash -> String.sub (Fmt.str "%a" S.Commit.pp_hash hash) 0 7)

     

       
135
       
+
       
      head

     

       
136
       
+
       
  in

     

       
137
       
+
       
  (head_hash, List.assoc_opt head heads)

     

       
138
       
 
       


     

       
139
       
 
       
(* Reset the head of the current session by one commit *)

     

       
140
       
 
       
let reset_hard ((H.Store ((module S), session) : entry H.t) as s) =

     
···

       
161
       
 
       
      Ok store

     

       
162
       
 
       


     

       
163
       
 
       
(* Fork a new session from an existing one *)

     

       
164
       
+
       
let display_history (s : entry H.t) =

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
165
       
 
       
  let pp_diff fmt d =

     

       
166
       
 
       
    if d = [] then () else Fmt.pf fmt "\n  %a" (Repr.pp Diff.t) d

     

       
167
       
 
       
  in

     

       
168
       
 
       
  let pp_entry fmt (e : entry) =

     

       
169
       
 
       
    Fmt.pf fmt "%-10s %s%a"

     

       
170
       
+
       
      Fmt.(str "%a" (styled (`Fg `Yellow) uint64_ns_span) e.post.time)

     

       
171
       
+
       
      (String.concat " " e.pre.args)

     

       
172
       
+
       
      pp_diff e.post.diff

     

       
173
       
 
       
  in

     

       
174
       
+
       
  let entries = history s |> List.rev in

     

       
175
       
+
       
  List.iter (fun (_hash, c) -> Fmt.pr "%a\n%!" pp_entry c) entries

     

       
0
       
 
       

     

       
0
       
 
       

     

       
176
       
 
       


     

       
177
       
 
       
let prompt status ((H.Store ((module S), _session) : entry H.t) as store) =

     

       
178
       
+
       
  let head, sesh = which_branch store in

     

       
179
       
+
       
  let sesh = Option.value ~default:"main" sesh in

     

       
180
       
 
       
  let prompt () =

     

       
181
       
 
       
    Fmt.(styled (`Fg `Yellow) string) Format.str_formatter "shelter> ";

     

       
182
       
 
       
    Format.flush_str_formatter ()

     

       
183
       
 
       
  in

     

       
184
       
+
       
  let pp_head fmt = function

     

       
185
       
+
       
    | None -> Fmt.nop fmt ()

     

       
186
       
+
       
    | Some h -> Fmt.pf fmt "#%a" (text `Magenta) h

     

       
187
       
+
       
  in

     

       
188
       
+
       
  let pp_sesh fmt sesh = Fmt.pf fmt "[%a%a]" (text `Green) sesh pp_head head in

     

       
189
       
 
       
  let pp_status fmt = function

     

       
190
       
 
       
    | `Exited 0 -> Fmt.nop fmt ()

     

       
191
       
 
       
    | `Exited n -> Fmt.pf fmt "%a " (text `Red) (string_of_int n)

     

       
192
       
 
       
    | _ -> Fmt.nop fmt ()

     

       
193
       
 
       
  in

     

       
194
       
+
       
  let prompt_entry (e : entry) =

     

       
195
       
 
       
    Fmt.pf Format.str_formatter "%a%a%a : { mode: %a }> " pp_status status

     

       
196
       
 
       
      (text `Yellow) "shelter" pp_sesh sesh (text `Red)

     

       
197
       
+
       
      (if e.pre.mode = R then "r" else "rw");

     

       
198
       
 
       
    Format.flush_str_formatter ()

     

       
199
       
 
       
  in

     

       
200
       
 
       
  with_latest store ~default:prompt prompt_entry

     

       
201
       
 
       


     

       
202
       
+
       
type ctx = { store : Store.t; tool_dir : string }

     

       
203
       
+
       


     

       
204
       
+
       
let tools = [ ("opentrace", Tools.opentrace) ]

     

       
205
       
 
       


     

       
206
       
 
       
let init fs proc s =

     

       
207
       
 
       
  let store = Store.init fs proc "shelter" in

     

       
208
       
 
       
  List.iter

     

       
209
       
+
       
    (fun (_, { History.pre = { History.args; _ }; _ }) ->

     

       
210
       
 
       
      LNoise.history_add (String.concat " " args) |> ignore)

     

       
211
       
+
       
    (history s);

     

       
212
       
+
       
  let tool_cid = Store.cid (String.concat ":" (List.map snd tools)) in

     

       
213
       
+
       
  let tools =

     

       
214
       
+
       
    Store.Run.with_tool store tool_cid @@ fun tool_dir ->

     

       
215
       
+
       
    Eio.Fiber.List.iter

     

       
216
       
+
       
      (fun (toolname, content) ->

     

       
217
       
+
       
        let new_path = Eio.Path.(fs / tool_dir / toolname) in

     

       
218
       
+
       
        Eio.Path.save ~create:(`If_missing 0o755) new_path content)

     

       
219
       
+
       
      tools;

     

       
220
       
+
       
    tool_dir

     

       
221
       
+
       
  in

     

       
222
       
+
       
  { store; tool_dir = tools }

     

       
223
       
 
       


     

       
224
       
+
       
let run (config : config) ~stdout fs clock proc

     

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

     

       
226
       
 
       
  | Set_mode mode ->

     

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

     

       
228
       
+
       
      commit ~message:"mode change" clock s

     

       
229
       
+
       
        { entry with pre = { entry.pre with mode } };

     

       
230
       
 
       
      Ok (s, ctx)

     

       
231
       
+
       
  | Set_session m -> (

     

       
232
       
+
       
      (* Either set the session if the branch exists or create a new branch

     

       
233
       
+
       
         from the latest commit of the current branch *)

     

       
234
       
+
       
      let sessions = sessions s in

     

       
235
       
+
       
      match List.exists (String.equal m) sessions with

     

       
236
       
+
       
      | true ->

     

       
237
       
+
       
          let sesh = S.of_branch (S.repo store) m in

     

       
238
       
+
       
          Ok (H.Store ((module S), sesh), ctx)

     

       
239
       
+
       
      | false -> (

     

       
240
       
+
       
          match fork s m with

     

       
241
       
+
       
          | Error err ->

     

       
242
       
+
       
              Fmt.pr "[fork]: %a\n%!" (text `Red) err;

     

       
243
       
+
       
              Ok (s, ctx)

     

       
244
       
+
       
          | Ok store -> Ok (store, ctx)))

     

       
245
       
 
       
  | Unknown args ->

     

       
246
       
 
       
      Fmt.epr "%a: %s\n%!" (text `Red) "Unknown Shelter Action"

     

       
247
       
 
       
        (String.concat " " args);

     

       
248
       
 
       
      Ok (s, ctx)

     

       
249
       
+
       
  | Info `Current ->

     

       
250
       
 
       
      let sessions = sessions s in

     

       
251
       
+
       
      let sesh = Option.value ~default:"main" (snd (which_branch s)) in

     

       
252
       
+
       
      let history = history s in

     

       
253
       
 
       
      let pp_commit fmt (hash, msg) =

     

       
254
       
 
       
        Fmt.pf fmt "[%a]: %s" (text `Yellow) hash msg

     

       
255
       
 
       
      in

     

       
256
       
+
       
      let repo = S.repo store in

     

       
257
       
 
       
      let commits =

     

       
258
       
+
       
        List.fold_left

     

       
259
       
+
       
          (fun acc (commit, _) ->

     

       
260
       
+
       
            let commit =

     

       
261
       
+
       
              S.Hash.unsafe_of_raw_string commit

     

       
262
       
+
       
              |> S.Commit.of_hash repo |> Option.get

     

       
263
       
+
       
            in

     

       
264
       
 
       
            let info = S.Commit.info commit |> S.Info.message in

     

       
265
       
 
       
            let hash = S.Commit.hash commit |> Repr.to_string S.Hash.t in

     

       
266
       
 
       
            (String.sub hash 0 7, info) :: acc)

     

       
267
       
+
       
          [] history

     

       
268
       
 
       
      in

     

       
269
       
 
       
      let latest =

     

       
270
       
 
       
        with_latest

     

       
271
       
 
       
          ~default:(fun () -> None)

     

       
272
       
 
       
          s

     

       
273
       
+
       
          (fun e -> Some (Repr.to_string Store.Build.t e.pre.build))

     

       
274
       
 
       
      in

     

       
275
       
 
       
      Fmt.pr "Sessions: %a\nCurrent: %a\nHash: %a\nCommits:@.  %a\n%!"

     

       
276
       
 
       
        Fmt.(list ~sep:(Fmt.any ", ") string)

     
···

       
282
       
 
       
      Ok (s, ctx)

     

       
283
       
 
       
  | Exec [] -> Ok (s, ctx)

     

       
284
       
 
       
  | Undo -> Ok (reset_hard s, ctx)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
285
       
 
       
  | Replay _ -> Ok (s, ctx)

     

       
286
       
+
       
  | Info `History ->

     

       
287
       
 
       
      display_history s;

     

       
288
       
 
       
      Ok (s, ctx)

     

       
289
       
 
       
  | Exec command -> (

     
···

       
292
       
 
       
          ~default:(fun () ->

     

       
293
       
 
       
            History.

     

       
294
       
 
       
              {

     

       
295
       
+
       
                pre =

     

       
296
       
+
       
                  {

     

       
297
       
+
       
                    mode = Void.RW;

     

       
298
       
+
       
                    build = Store.Build.Image config.image;

     

       
299
       
+
       
                    args = command;

     

       
300
       
+
       
                    (* TODO: extract with fetch *)

     

       
301
       
+
       
                    env = [];

     

       
302
       
+
       
                    cwd = "/";

     

       
303
       
+
       
                    user = (0, 0);

     

       
304
       
+
       
                  };

     

       
305
       
+
       
                post = { diff = []; time = 0L };

     

       
306
       
 
       
              })

     

       
307
       
 
       
          s

     

       
308
       
+
       
        @@ fun e -> e

     

       
309
       
 
       
      in

     

       
310
       
 
       
      let build, env, (uid, gid) =

     

       
311
       
+
       
        match entry.pre.build with

     

       
312
       
 
       
        | Store.Build.Image img ->

     

       
313
       
+
       
            let build, env, user = Store.fetch ctx.store img in

     

       
314
       
 
       
            (build, env, Option.value ~default:(0, 0) user)

     

       
315
       
+
       
        | Store.Build.Build cid -> (cid, entry.pre.env, entry.pre.user)

     

       
316
       
+
       
      in

     

       
317
       
+
       
      let hash_entry =

     

       
318
       
+
       
        {

     

       
319
       
+
       
          entry with

     

       
320
       
+
       
          pre = { entry.pre with build = Build build; args = command };

     

       
321
       
+
       
        }

     

       
322
       
 
       
      in

     

       
323
       
+
       
      (* Store things under History.pre, this makes it possible to rediscover

     

       
324
       
+
       
         the hash for something purely from the arguments needed to execute something

     

       
325
       
+
       
         rather than needing, for example, the time it took to execute! *)

     

       
326
       
+
       
      let new_cid = Store.cid (Repr.to_string History.pre_t hash_entry.pre) in

     

       
327
       
 
       
      let with_rootfs fn =

     

       
328
       
+
       
        if entry.pre.mode = R then (Store.Run.with_build ctx.store build fn, [])

     

       
329
       
+
       
        else Store.Run.with_clone ctx.store ~src:build new_cid fn

     

       
330
       
 
       
      in

     

       
331
       
 
       
      try

     

       
332
       
 
       
        let new_entry, diff =

     

       
333
       
+
       
          with_rootfs @@ function

     

       
334
       
+
       
          | `Exists path ->

     

       
335
       
+
       
              (* Copy the stdout log to stdout *)

     

       
336
       
+
       
              let () =

     

       
337
       
+
       
                Eio.Path.(with_open_in (fs / (path :> string) / "log"))

     

       
338
       
+
       
                @@ fun ic -> Eio.Flow.copy ic stdout

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
339
       
 
       
              in

     

       
340
       
+
       
              let repo = S.repo store in

     

       
341
       
+
       
              let c =

     

       
342
       
+
       
                Eio.Path.(load (fs / (path :> string) / "hash"))

     

       
343
       
+
       
                |> S.Hash.unsafe_of_raw_string |> S.Commit.of_hash repo

     

       
344
       
+
       
              in

     

       
345
       
+
       
              Ok (`Reset c)

     

       
346
       
+
       
          | `Build rootfs ->

     

       
347
       
+
       
              let spawn sw log =

     

       
348
       
+
       
                if config.no_runc then

     

       
349
       
+
       
                  let rootfs = Filename.concat rootfs "rootfs" in

     

       
350
       
+
       
                  let void =

     

       
351
       
+
       
                    Void.empty

     

       
352
       
+
       
                    |> Void.rootfs ~mode:entry.pre.mode rootfs

     

       
353
       
+
       
                    |> Void.cwd entry.pre.cwd

     

       
354
       
+
       
                    (* TODO: Support UIDs |> Void.uid 1000 *)

     

       
355
       
+
       
                    |> Void.exec ~env

     

       
356
       
+
       
                         [

     

       
357
       
+
       
                           config.shell;

     

       
358
       
+
       
                           "-c";

     

       
359
       
+
       
                           String.concat " " command

     

       
360
       
+
       
                           ^ " && env > /tmp/shelter-env";

     

       
361
       
+
       
                         ]

     

       
362
       
+
       
                  in

     

       
363
       
+
       
                  `Void (Void.spawn ~sw void |> Void.exit_status)

     

       
364
       
+
       
                else

     

       
365
       
+
       
                  let tool_mount : Runc.Json_config.mount =

     

       
366
       
+
       
                    {

     

       
367
       
+
       
                      ty = `Bind;

     

       
368
       
+
       
                      src = ctx.tool_dir;

     

       
369
       
+
       
                      dst = "/shelter-tools";

     

       
370
       
+
       
                      readonly = true;

     

       
371
       
+
       
                    }

     

       
372
       
+
       
                  in

     

       
373
       
+
       
                  let config =

     

       
374
       
+
       
                    Runc.Json_config.

     

       
375
       
+
       
                      {

     

       
376
       
+
       
                        cwd = entry.pre.cwd;

     

       
377
       
+
       
                        argv =

     

       
378
       
+
       
                          [

     

       
379
       
+
       
                            config.shell;

     

       
380
       
+
       
                            "-c";

     

       
381
       
+
       
                            String.concat " " command

     

       
382
       
+
       
                            ^ " && env > /tmp/shelter-env";

     

       
383
       
+
       
                          ];

     

       
384
       
+
       
                        hostname = "";

     

       
385
       
+
       
                        network = [ "host" ];

     

       
386
       
+
       
                        user = (uid, gid);

     

       
387
       
+
       
                        env = entry.pre.env;

     

       
388
       
+
       
                        mounts = [ tool_mount ];

     

       
389
       
+
       
                        entrypoint = None;

     

       
390
       
+
       
                      }

     

       
391
       
+
       
                  in

     

       
392
       
+
       
                  let env =

     

       
393
       
+
       
                    object

     

       
394
       
+
       
                      method fs = fs

     

       
395
       
+
       
                      method proc = proc

     

       
396
       
+
       
                      method stdout = stdout

     

       
397
       
+
       
                    end

     

       
398
       
+
       
                  in

     

       
399
       
+
       
                  `Runc (Runc.spawn ~sw log env config rootfs)

     

       
400
       
+
       
              in

     

       
401
       
+
       
              Switch.run @@ fun sw ->

     

       
402
       
+
       
              let log =

     

       
403
       
+
       
                Eio.Path.open_out ~sw ~create:(`If_missing 0o644)

     

       
404
       
+
       
                  Eio.Path.(fs / rootfs / "log")

     

       
405
       
+
       
              in

     

       
406
       
+
       
              let res = spawn sw log in

     

       
407
       
+
       
              let start = Mtime_clock.now () in

     

       
408
       
+
       
              let res =

     

       
409
       
+
       
                match res with

     

       
410
       
+
       
                | `Runc r -> Eio.Process.await r

     

       
411
       
+
       
                | `Void v -> Void.to_eio_status (Eio.Promise.await v)

     

       
412
       
+
       
              in

     

       
413
       
+
       
              let stop = Mtime_clock.now () in

     

       
414
       
+
       
              let span = Mtime.span start stop in

     

       
415
       
+
       
              let time = Mtime.Span.to_uint64_ns span in

     

       
416
       
+
       
              (* Add command to history regardless of exit status *)

     

       
417
       
+
       
              let _ : (unit, string) result =

     

       
418
       
+
       
                LNoise.history_add (String.concat " " command)

     

       
419
       
 
       
              in

     

       
420
       
+
       
              if res = `Exited 0 then (

     

       
421
       
+
       
                (* Extract env *)

     

       
422
       
+
       
                let env_path =

     

       
423
       
+
       
                  Eio.Path.(fs / rootfs / "rootfs" / "tmp" / "shelter-env")

     

       
424
       
+
       
                in

     

       
425
       
+
       
                let env =

     

       
426
       
+
       
                  Eio.Path.(load env_path)

     

       
427
       
+
       
                  |> String.split_on_char '\n'

     

       
428
       
+
       
                  |> List.filter (fun s -> not (String.equal "" s))

     

       
429
       
+
       
                in

     

       
430
       
+
       
                Eio.Path.unlink env_path;

     

       
431
       
+
       
                let cwd =

     

       
432
       
+
       
                  List.find_map

     

       
433
       
+
       
                    (fun v ->

     

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

     

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

     

       
436
       
+
       
                      | _ -> None)

     

       
437
       
+
       
                    env

     

       
438
       
+
       
                  |> Option.value ~default:hash_entry.pre.cwd

     

       
439
       
+
       
                in

     

       
440
       
+
       
                if entry.pre.mode = RW then

     

       
441
       
+
       
                  Ok

     

       
442
       
+
       
                    (`Entry

     

       
443
       
+
       
                       ( {

     

       
444
       
+
       
                           hash_entry with

     

       
445
       
+
       
                           History.pre =

     

       
446
       
+
       
                             {

     

       
447
       
+
       
                               hash_entry.pre with

     

       
448
       
+
       
                               build = Build new_cid;

     

       
449
       
+
       
                               env;

     

       
450
       
+
       
                               cwd;

     

       
451
       
+
       
                               user = (uid, gid);

     

       
452
       
+
       
                             };

     

       
453
       
+
       
                         },

     

       
454
       
+
       
                         rootfs ))

     

       
455
       
+
       
                else

     

       
456
       
+
       
                  Ok

     

       
457
       
+
       
                    (`Entry

     

       
458
       
+
       
                       ( {

     

       
459
       
+
       
                           pre =

     

       
460
       
+
       
                             { hash_entry.pre with cwd; env; user = (uid, gid) };

     

       
461
       
+
       
                           post = { hash_entry.post with time };

     

       
462
       
+
       
                         },

     

       
463
       
+
       
                         rootfs )))

     

       
464
       
+
       
              else Error (Eio.Process.Child_error res)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
465
       
 
       
        in

     

       
466
       
 
       
        match new_entry with

     

       
467
       
 
       
        | Error e -> Error e

     

       
468
       
+
       
        | Ok (`Reset None) ->

     

       
469
       
+
       
            Fmt.epr "Resetting to existing entry failed...\n%!";

     

       
470
       
+
       
            Ok (s, ctx)

     

       
471
       
+
       
        | Ok (`Reset (Some c)) ->

     

       
472
       
+
       
            S.Head.set store c;

     

       
473
       
+
       
            Ok (s, ctx)

     

       
474
       
+
       
        | Ok (`Entry (entry, path)) ->

     

       
475
       
 
       
            (* Set diff *)

     

       
476
       
+
       
            let entry = { entry with post = { entry.post with diff } } in

     

       
477
       
 
       
            (* Commit if RW *)

     

       
478
       
+
       
            if entry.pre.mode = RW then (

     

       
479
       
 
       
              commit

     

       
480
       
 
       
                ~message:("exec " ^ String.concat " " command)

     

       
481
       
 
       
                clock s entry;

     

       
482
       
+
       
              (* Save the commit hash for easy restoring later *)

     

       
483
       
+
       
              let hash =

     

       
484
       
+
       
                S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string

     

       
485
       
+
       
              in

     

       
486
       
+
       
              Eio.Path.save ~create:(`If_missing 0o644)

     

       
487
       
+
       
                Eio.Path.(fs / path / "hash")

     

       
488
       
+
       
                hash);

     

       
489
       
 
       
            Ok (s, ctx)

     

       
490
       
 
       
      with Eio.Exn.Io (Eio.Process.E e, _) -> Error e)

     

···

       
1
       
 
       
module Store = Store

     

       
2
       
 
       


     

       
3
       
 
       
module History : sig

     

       
4
       
-
       
  type t = {

     

       
0
       
 
       

     

       
0
       
 
       

     

       
5
       
 
       
    mode : Void.mode;

     

       
6
       
 
       
    build : Store.Build.t;

     

       
7
       
 
       
    args : string list;

     

       
8
       
-
       
    time : int64;

     

       
9
       
 
       
    env : string list;

     

       
10
       
 
       
    cwd : string;

     

       
11
       
 
       
    user : int * int;

     

       
12
       
-
       
    diff : Diff.t;

     

       
13
       
 
       
  }

     

       
14
       
 
       
  [@@deriving repr]

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
15
       
 
       


     

       
16
       
 
       
  include Irmin.Contents.S with type t := t

     

       
17
       
 
       
end

     

···

       
1
       
 
       
module Store = Store

     

       
2
       
 
       


     

       
3
       
 
       
module History : sig

     

       
4
       
+
       
  type post = { diff : Diff.t; time : int64 } [@@deriving repr]

     

       
5
       
+
       


     

       
6
       
+
       
  type pre = {

     

       
7
       
 
       
    mode : Void.mode;

     

       
8
       
 
       
    build : Store.Build.t;

     

       
9
       
 
       
    args : string list;

     

       
0
       
 
       

     

       
10
       
 
       
    env : string list;

     

       
11
       
 
       
    cwd : string;

     

       
12
       
 
       
    user : int * int;

     

       
0
       
 
       

     

       
13
       
 
       
  }

     

       
14
       
 
       
  [@@deriving repr]

     

       
15
       
+
       
  (** Needed for execution *)

     

       
16
       
+
       


     

       
17
       
+
       
  type t = { pre : pre; post : post } [@@deriving repr]

     

       
18
       
 
       


     

       
19
       
 
       
  include Irmin.Contents.S with type t := t

     

       
20
       
 
       
end

     

···

       
30
       
 
       
  val builds : string -> dataset

     

       
31
       
 
       
  val build : string -> string -> dataset

     

       
32
       
 
       
  val snapshot : dataset -> snapshot

     

       
0
       
 
       

     

       
0
       
 
       

     

       
33
       
 
       
end = struct

     

       
34
       
 
       
  type dataset = string

     

       
35
       
 
       
  type snapshot = string

     
···

       
38
       
 
       
  let builds pool : dataset = pool / "builds"

     

       
39
       
 
       
  let build pool path : dataset = builds pool / path

     

       
40
       
 
       
  let snapshot ds = ds ^ "@snappy"

     

       
0
       
 
       

     

       
0
       
 
       

     

       
41
       
 
       
end

     

       
42
       
 
       


     

       
43
       
 
       
let with_dataset ?(typ = Zfs.Types.filesystem) t dataset f =

     
···

       
78
       
 
       
    }

     

       
79
       
 
       
  in

     

       
80
       
 
       
  create_and_mount t (Datasets.builds t.pool);

     

       
0
       
 
       

     

       
81
       
 
       
  t

     

       
82
       
 
       


     

       
83
       
 
       
let snapshot t (snap : Datasets.snapshot) =

     
···

       
160
       
 
       
    let ds = Datasets.build t.pool (Cid.to_string cid) in

     

       
161
       
 
       
    Fun.protect ~finally:(fun () -> unmount_dataset t ds) @@ fun () ->

     

       
162
       
 
       
    mount_dataset t ds;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
163
       
 
       
    fn ("/" ^ (ds :> string))

     

       
164
       
 
       


     

       
165
       
 
       
  let with_clone t ~src new_cid fn =

     
···

       
167
       
 
       
    let tgt = Datasets.build t.pool (Cid.to_string new_cid) in

     

       
168
       
 
       
    let src_snap = Datasets.snapshot ds in

     

       
169
       
 
       
    let tgt_snap = Datasets.snapshot tgt in

     

       
170
       
-
       
    clone t src_snap tgt;

     

       
171
       
-
       
    let v = with_build t new_cid fn in

     

       
172
       
-
       
    snapshot t tgt_snap;

     

       
173
       
-
       
    let d = diff t src_snap tgt_snap in

     

       
174
       
-
       
    (v, d)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
175
       
 
       
end

     

···

       
30
       
 
       
  val builds : string -> dataset

     

       
31
       
 
       
  val build : string -> string -> dataset

     

       
32
       
 
       
  val snapshot : dataset -> snapshot

     

       
33
       
+
       
  val tools : string -> dataset

     

       
34
       
+
       
  val tool : string -> string -> dataset

     

       
35
       
 
       
end = struct

     

       
36
       
 
       
  type dataset = string

     

       
37
       
 
       
  type snapshot = string

     
···

       
40
       
 
       
  let builds pool : dataset = pool / "builds"

     

       
41
       
 
       
  let build pool path : dataset = builds pool / path

     

       
42
       
 
       
  let snapshot ds = ds ^ "@snappy"

     

       
43
       
+
       
  let tools pool : dataset = pool / "tools"

     

       
44
       
+
       
  let tool pool path : dataset = tools pool / path

     

       
45
       
 
       
end

     

       
46
       
 
       


     

       
47
       
 
       
let with_dataset ?(typ = Zfs.Types.filesystem) t dataset f =

     
···

       
82
       
 
       
    }

     

       
83
       
 
       
  in

     

       
84
       
 
       
  create_and_mount t (Datasets.builds t.pool);

     

       
85
       
+
       
  create_and_mount t (Datasets.tools t.pool);

     

       
86
       
 
       
  t

     

       
87
       
 
       


     

       
88
       
 
       
let snapshot t (snap : Datasets.snapshot) =

     
···

       
165
       
 
       
    let ds = Datasets.build t.pool (Cid.to_string cid) in

     

       
166
       
 
       
    Fun.protect ~finally:(fun () -> unmount_dataset t ds) @@ fun () ->

     

       
167
       
 
       
    mount_dataset t ds;

     

       
168
       
+
       
    fn (`Build ("/" ^ (ds :> string)))

     

       
169
       
+
       


     

       
170
       
+
       
  let with_tool t cid fn =

     

       
171
       
+
       
    let ds = Datasets.tool t.pool (Cid.to_string cid) in

     

       
172
       
+
       
    Fun.protect ~finally:(fun () -> unmount_dataset t ds) @@ fun () ->

     

       
173
       
+
       
    mount_dataset t ds;

     

       
174
       
 
       
    fn ("/" ^ (ds :> string))

     

       
175
       
 
       


     

       
176
       
 
       
  let with_clone t ~src new_cid fn =

     
···

       
178
       
 
       
    let tgt = Datasets.build t.pool (Cid.to_string new_cid) in

     

       
179
       
 
       
    let src_snap = Datasets.snapshot ds in

     

       
180
       
 
       
    let tgt_snap = Datasets.snapshot tgt in

     

       
181
       
+
       
    if Zfs.exists t.zfs (tgt :> string) Zfs.Types.dataset then

     

       
182
       
+
       
      (fn (`Exists ("/" ^ (tgt :> string))), diff t src_snap tgt_snap)

     

       
183
       
+
       
    else (

     

       
184
       
+
       
      clone t src_snap tgt;

     

       
185
       
+
       
      let v = with_build t new_cid fn in

     

       
186
       
+
       
      snapshot t tgt_snap;

     

       
187
       
+
       
      let d = diff t src_snap tgt_snap in

     

       
188
       
+
       
      (v, d))

     

       
189
       
 
       
end

     

···

       
0
       
 
       

     

···

       
1
       
+
       
let opentrace = [%blob "./opentrace"]