···

       
19
       
 
       
 (synopsis "Shelter from the Storm")

     

       
20
       
 
       
 (description "A shell session shim to help you explore!")

     

       
21
       
 
       
 (depends

     

       
22
       
-
       
   ocaml

     

       
0
       
 
       

     

       
23
       
 
       
   eio_posix

     

       
24
       
-
       
   void

     

       
25
       
 
       
   zfs

     

       
26
       
 
       
   cid

     

       
27
       
 
       
   ppx_repr

     

       
28
       
-
       
   irmin-fs

     

       
0
       
 
       

     

       
0
       
 
       

     

       
29
       
 
       
   cmdliner

     

       
30
       
 
       
  )

     

       
31
       
 
       
 (tags

     

···

       
19
       
 
       
 (synopsis "Shelter from the Storm")

     

       
20
       
 
       
 (description "A shell session shim to help you explore!")

     

       
21
       
 
       
 (depends

     

       
22
       
+
       
   (ocaml (< "5.3.0~~")) ; for the irmin pin only

     

       
23
       
+
       
   (ctypes (< "0.23.0")) ; for a const ptr mismatch with zfs from https://github.com/yallop/ocaml-ctypes/pull/782

     

       
24
       
 
       
   eio_posix

     

       
0
       
 
       

     

       
25
       
 
       
   zfs

     

       
26
       
 
       
   cid

     

       
27
       
 
       
   ppx_repr

     

       
28
       
+
       
   irmin-git

     

       
29
       
+
       
   morbig

     

       
30
       
+
       
   ppx_blob

     

       
31
       
 
       
   cmdliner

     

       
32
       
 
       
  )

     

       
33
       
 
       
 (tags

     

···

       
10
       
 
       
bug-reports: "https://github.com/username/reponame/issues"

     

       
11
       
 
       
depends: [

     

       
12
       
 
       
  "dune" {>= "3.17"}

     

       
13
       
-
       
  "ocaml"

     

       
0
       
 
       

     

       
14
       
 
       
  "eio_posix"

     

       
15
       
-
       
  "void"

     

       
16
       
 
       
  "zfs"

     

       
17
       
 
       
  "cid"

     

       
18
       
 
       
  "ppx_repr"

     

       
19
       
-
       
  "irmin-fs"

     

       
0
       
 
       

     

       
0
       
 
       

     

       
20
       
 
       
  "cmdliner"

     

       
21
       
 
       
  "odoc" {with-doc}

     

       
22
       
 
       
]

     
···

       
39
       
 
       
  [ "zfs.dev"      "git+https://github.com/patricoferris/ocaml-zfs" ]

     

       
40
       
 
       
  [ "void.dev"     "git+https://github.com/quantifyearth/void" ]

     

       
41
       
 
       
  [ "irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

       
42
       
-
       
  [ "irmin-fs.dev" "git+https://github.com/mirage/irmin#eio" ]

     

       
0
       
 
       

     

       
0
       
 
       

     

       
43
       
 
       
]

     

···

       
10
       
 
       
bug-reports: "https://github.com/username/reponame/issues"

     

       
11
       
 
       
depends: [

     

       
12
       
 
       
  "dune" {>= "3.17"}

     

       
13
       
+
       
  "ocaml" {< "5.3.0~~"}

     

       
14
       
+
       
  "ctypes" {< "0.23.0"}

     

       
15
       
 
       
  "eio_posix"

     

       
0
       
 
       

     

       
16
       
 
       
  "zfs"

     

       
17
       
 
       
  "cid"

     

       
18
       
 
       
  "ppx_repr"

     

       
19
       
+
       
  "irmin-git"

     

       
20
       
+
       
  "morbig"

     

       
21
       
+
       
  "ppx_blob"

     

       
22
       
 
       
  "cmdliner"

     

       
23
       
 
       
  "odoc" {with-doc}

     

       
24
       
 
       
]

     
···

       
41
       
 
       
  [ "zfs.dev"      "git+https://github.com/patricoferris/ocaml-zfs" ]

     

       
42
       
 
       
  [ "void.dev"     "git+https://github.com/quantifyearth/void" ]

     

       
43
       
 
       
  [ "irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

       
44
       
+
       
  [ "ppx_irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

       
45
       
+
       
  [ "irmin-git.dev" "git+https://github.com/mirage/irmin#eio" ]

     

       
46
       
+
       
  [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#675125d9e95cd09ef0c18ab1d9d6d69a26856b9f" ]

     

       
47
       
 
       
]

     

···

       
2
       
 
       
  [ "zfs.dev"      "git+https://github.com/patricoferris/ocaml-zfs" ]

     

       
3
       
 
       
  [ "void.dev"     "git+https://github.com/quantifyearth/void" ]

     

       
4
       
 
       
  [ "irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

       
5
       
-
       
  [ "irmin-fs.dev" "git+https://github.com/mirage/irmin#eio" ]

     

       
0
       
 
       

     

       
0
       
 
       

     

       
6
       
 
       
]

     

···

       
2
       
 
       
  [ "zfs.dev"      "git+https://github.com/patricoferris/ocaml-zfs" ]

     

       
3
       
 
       
  [ "void.dev"     "git+https://github.com/quantifyearth/void" ]

     

       
4
       
 
       
  [ "irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

       
5
       
+
       
  [ "ppx_irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

       
6
       
+
       
  [ "irmin-git.dev" "git+https://github.com/mirage/irmin#eio" ]

     

       
7
       
+
       
  [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#675125d9e95cd09ef0c18ab1d9d6d69a26856b9f" ]

     

       
8
       
 
       
]

     

···

       
15
       
 
       
  Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path;

     

       
16
       
 
       
  path

     

       
17
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
18
       
 
       
(* Command Line *)

     

       
19
       
 
       
open Cmdliner

     

       
20
       
 
       


     
···

       
27
       
 
       


     

       
28
       
 
       
let main =

     

       
29
       
 
       
  let run config cmd_file =

     

       
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 =

     
···

       
46
       
 
       


     

       
47
       
 
       
let passthrough =

     

       
48
       
 
       
  let run config cmd_file =

     

       
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

     
···

       
57
       
 
       


     

       
58
       
 
       
let extract_commands =

     

       
59
       
 
       
  let run cmd_file =

     

       
60
       
-
       
    Eio_posix.run @@ fun env ->

     

       
61
       
 
       
    let cmd_file = Eio.Path.( / ) env#fs (Option.get cmd_file) in

     

       
62
       
 
       
    Shelter.Script.to_commands cmd_file |> List.iter (Fmt.pr "%s\n")

     

       
63
       
 
       
  in

     

···

       
15
       
 
       
  Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path;

     

       
16
       
 
       
  path

     

       
17
       
 
       


     

       
18
       
+
       
module Eventloop = struct

     

       
19
       
+
       
  let run fn =

     

       
20
       
+
       
    Eio_posix.run @@ fun env ->

     

       
21
       
+
       
    Lwt_eio.with_event_loop ~clock:env#clock @@ fun _token -> fn env

     

       
22
       
+
       
end

     

       
23
       
+
       


     

       
24
       
 
       
(* Command Line *)

     

       
25
       
 
       
open Cmdliner

     

       
26
       
 
       


     
···

       
33
       
 
       


     

       
34
       
 
       
let main =

     

       
35
       
 
       
  let run config cmd_file =

     

       
36
       
+
       
    Eventloop.run @@ fun env ->

     

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

     

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

     

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

     

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

     

       
41
       
 
       
  in

     

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

     

       
43
       
 
       
  let man =

     
···

       
53
       
 
       


     

       
54
       
 
       
let passthrough =

     

       
55
       
 
       
  let run config cmd_file =

     

       
56
       
+
       
    Eventloop.run @@ fun env ->

     

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

     

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

     

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

     

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

     

       
61
       
 
       
  in

     

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

     

       
63
       
 
       
  let info = Cmd.info "passthrough" in

     
···

       
65
       
 
       


     

       
66
       
 
       
let extract_commands =

     

       
67
       
 
       
  let run cmd_file =

     

       
68
       
+
       
    Eventloop.run @@ fun env ->

     

       
69
       
 
       
    let cmd_file = Eio.Path.( / ) env#fs (Option.get cmd_file) in

     

       
70
       
 
       
    Shelter.Script.to_commands cmd_file |> List.iter (Fmt.pr "%s\n")

     

       
71
       
 
       
  in

     

···

       
1
       
 
       
(library

     

       
2
       
 
       
 (name shelter)

     

       
3
       
 
       
 (public_name shelter)

     

       
4
       
-
       
 (libraries cmdliner irmin-fs.unix eio.unix eio linenoise void repr morbig))

     

···

       
1
       
 
       
(library

     

       
2
       
 
       
 (name shelter)

     

       
3
       
 
       
 (public_name shelter)

     

       
4
       
+
       
 (libraries cmdliner irmin-git.unix eio.unix eio linenoise void repr morbig))

     

···

       
17
       
 
       
  (** A context that is not persisted, but is passed through each loop of the

     

       
18
       
 
       
      shell *)

     

       
19
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
20
       
 
       
  val init :

     

       
21
       
 
       
    _ Eio.Path.t ->

     

       
22
       
 
       
    Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     
···

       
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 ->

     

       
33
       
 
       
    entry History.t * ctx ->

     

       
34
       
 
       
    action ->

     

       
35
       
-
       
    (entry History.t * ctx, Eio.Process.error) result

     

       
0
       
 
       

     

       
0
       
 
       

     

       
36
       
 
       
  (** [run history action] runs the action in [history]. Return a new [history]

     

       
37
       
 
       
      that can be persisted *)

     

       
38
       
 
       


     

···

       
17
       
 
       
  (** A context that is not persisted, but is passed through each loop of the

     

       
18
       
 
       
      shell *)

     

       
19
       
 
       


     

       
20
       
+
       
  type error

     

       
21
       
+
       
  (** Shell specific errors *)

     

       
22
       
+
       


     

       
23
       
+
       
  val pp_error : error Fmt.t

     

       
24
       
+
       


     

       
25
       
 
       
  val init :

     

       
26
       
 
       
    _ Eio.Path.t ->

     

       
27
       
 
       
    Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     
···

       
32
       
 
       


     

       
33
       
 
       
  val run :

     

       
34
       
 
       
    config ->

     

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

     

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

     

       
37
       
 
       
    _ Eio.Time.clock ->

     

       
38
       
 
       
    Eio_unix.Process.mgr_ty Eio_unix.Process.mgr ->

     

       
39
       
 
       
    entry History.t * ctx ->

     

       
40
       
 
       
    action ->

     

       
41
       
+
       
    ( entry History.t * ctx,

     

       
42
       
+
       
      [ `Process of Eio.Process.error | `Shell of error ] )

     

       
43
       
+
       
    result

     

       
44
       
 
       
  (** [run history action] runs the action in [history]. Return a new [history]

     

       
45
       
 
       
      that can be persisted *)

     

       
46
       
 
       


     

···

       
1
       
 
       
open Eio

     

       
2
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
3
       
 
       
type config = unit

     

       
4
       
 
       


     

       
5
       
 
       
let config_term = Cmdliner.Term.const ()

     
···

       
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) =

     
···

       
56
       
 
       
      S.set_exn ~info store (key ()) command;

     

       
57
       
 
       
      let _ : (unit, string) result = LNoise.history_add command in

     

       
58
       
 
       
      Ok (full_store, ()))

     

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

     

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

     

···

       
1
       
 
       
open Eio

     

       
2
       
 
       


     

       
3
       
+
       
type error = string

     

       
4
       
+
       


     

       
5
       
+
       
let pp_error = Fmt.string

     

       
6
       
+
       


     

       
7
       
 
       
type config = unit

     

       
8
       
 
       


     

       
9
       
 
       
let config_term = Cmdliner.Term.const ()

     
···

       
41
       
 
       
      in

     

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

     

       
43
       
 
       


     

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

     

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

     

       
46
       
 
       
       full_store),

     

       
47
       
 
       
      () ) (Exec command) =

     
···

       
60
       
 
       
      S.set_exn ~info store (key ()) command;

     

       
61
       
 
       
      let _ : (unit, string) result = LNoise.history_add command in

     

       
62
       
 
       
      Ok (full_store, ()))

     

       
63
       
+
       
    else Shelter.process_error (Eio.Process.Child_error res)

     

       
64
       
+
       
  with Eio.Exn.Io (Eio.Process.E e, _) -> Shelter.process_error e

     

···

       
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 ~sw ~stdout env#proc ~cwd:eio_tmp cmd

     

       
307
       
 
       


     

       
308
       
 
       
(* 

     

       
309
       
 
       
                                 Apache License

     

···

       
2
       
 
       
module Store = Store

     

       
3
       
 
       
module H = Shelter.History

     

       
4
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
5
       
 
       
module History = struct

     

       
6
       
 
       
  type mode = Void.mode

     

       
7
       
 
       


     
···

       
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
       
 
       

     

       
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
       
 
       

     

       
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
       
 
       

     

       
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
       
 
       

     

       
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
       
 
       

     

       
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)

     

       
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

     

       
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
       
-
       
                  }

     

       
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 ->

     

       
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;

     

       
364
       
-
       
            Ok (s, ctx)

     

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

     

···

       
2
       
 
       
module Store = Store

     

       
3
       
 
       
module H = Shelter.History

     

       
4
       
 
       


     

       
5
       
+
       
type error = string

     

       
6
       
+
       


     

       
7
       
+
       
let pp_error = Fmt.string

     

       
8
       
+
       


     

       
9
       
 
       
module History = struct

     

       
10
       
 
       
  type mode = Void.mode

     

       
11
       
 
       


     
···

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

     

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

     

       
17
       
 
       


     

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

     

       
19
       
+
       


     

       
20
       
+
       
  type pre = {

     

       
21
       
 
       
    mode : mode;

     

       
22
       
 
       
    build : Store.Build.t;

     

       
23
       
 
       
    args : string list;

     

       
0
       
 
       

     

       
24
       
 
       
    env : string list;

     

       
25
       
 
       
    cwd : string;

     

       
26
       
 
       
    user : int * int;

     

       
0
       
 
       

     

       
27
       
 
       
  }

     

       
28
       
 
       
  [@@deriving repr]

     

       
29
       
+
       
  (** Needed for execution *)

     

       
30
       
+
       


     

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

     

       
32
       
 
       


     

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

     

       
34
       
 
       
end

     
···

       
40
       
 
       
type entry = History.t

     

       
41
       
 
       


     

       
42
       
 
       
type action =

     

       
43
       
+
       
  (* Change modes *)

     

       
44
       
 
       
  | Set_mode of History.mode

     

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

     

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

     

       
47
       
 
       
  | Set_session of string

     

       
48
       
+
       
  (* Run a command *)

     

       
49
       
 
       
  | Exec of string list

     

       
50
       
+
       
  (* Undo the last command *)

     

       
51
       
 
       
  | Undo

     

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

     

       
53
       
 
       
  | Replay of string

     

       
54
       
+
       
  (* Display info *)

     

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

     

       
56
       
+
       
  (* Error state *)

     

       
57
       
 
       
  | Unknown of string list

     

       
0
       
 
       

     

       
58
       
 
       
[@@deriving repr]

     

       
59
       
 
       


     

       
60
       
 
       
let split_and_remove_empty s =

     
···

       
64
       
 
       


     

       
65
       
 
       
let shelter_action = function

     

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

     

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

     

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

     

       
0
       
 
       

     

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

     

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

     

       
71
       
 
       
  | [ "undo" ] -> Undo

     

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

     

       
73
       
 
       
  | other -> Unknown other

     

       
74
       
 
       


     

       
75
       
 
       
let action_of_command cmd =

     
···

       
81
       
 
       
let history_key = [ "history" ]

     

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

     

       
83
       
 
       


     

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

     

       
85
       
+
       
  let repo = S.repo store in

     

       
86
       
+
       
  match S.Head.find store with

     

       
87
       
+
       
  | None -> []

     

       
88
       
+
       
  | Some hd ->

     

       
89
       
+
       
      let rec linearize c =

     

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

     

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

     

       
92
       
+
       
        | _ -> [ c ]

     

       
93
       
 
       
      in

     

       
94
       
+
       
      let commits = linearize hd in

     

       
95
       
+
       
      let get_diff_content t1 t2 =

     

       
96
       
+
       
        match S.Tree.diff t1 t2 with

     

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

     

       
98
       
+
       
        | lst ->

     

       
99
       
+
       
            let pp_diff =

     

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

     

       
101
       
+
       
            in

     

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

     

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

     

       
104
       
+
       
              lst;

     

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

     

       
106
       
+
       
      in

     

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

     

       
108
       
+
       
      let rec diff_calc = function

     

       
109
       
+
       
        | [] -> []

     

       
110
       
+
       
        | [ x ] ->

     

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

     

       
112
       
+
       
            [ (hash x, diff) ]

     

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

     

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

     

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

     

       
116
       
+
       
      in

     

       
117
       
+
       
      diff_calc commits

     

       
118
       
 
       


     

       
119
       
 
       
let with_latest ~default s f =

     

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

     

       
121
       
 
       


     

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

     

       
123
       
 
       


     
···

       
133
       
 
       
  let repo = S.repo session in

     

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

     

       
135
       
 
       
  let head = S.Head.find session in

     

       
136
       
+
       
  let head_hash =

     

       
137
       
+
       
    Option.map

     

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

     

       
139
       
+
       
      head

     

       
140
       
+
       
  in

     

       
141
       
+
       
  (head_hash, List.assoc_opt head heads)

     

       
142
       
 
       


     

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

     

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

     
···

       
165
       
 
       
      Ok store

     

       
166
       
 
       


     

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

     

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

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
169
       
 
       
  let pp_diff fmt d =

     

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

     

       
171
       
 
       
  in

     

       
172
       
 
       
  let pp_entry fmt (e : entry) =

     

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

     

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

     

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

     

       
176
       
+
       
      pp_diff e.post.diff

     

       
177
       
 
       
  in

     

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

     

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

     

       
0
       
 
       

     

       
0
       
 
       

     

       
180
       
 
       


     

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

     

       
182
       
+
       
  let head, sesh = which_branch store in

     

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

     

       
184
       
 
       
  let prompt () =

     

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

     

       
186
       
 
       
    Format.flush_str_formatter ()

     

       
187
       
 
       
  in

     

       
188
       
+
       
  let pp_head fmt = function

     

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

     

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

     

       
191
       
+
       
  in

     

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

     

       
193
       
 
       
  let pp_status fmt = function

     

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

     

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

     

       
196
       
 
       
    | _ -> Fmt.nop fmt ()

     

       
197
       
 
       
  in

     

       
198
       
+
       
  let prompt_entry (e : entry) =

     

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

     

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

     

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

     

       
202
       
 
       
    Format.flush_str_formatter ()

     

       
203
       
 
       
  in

     

       
204
       
 
       
  with_latest store ~default:prompt prompt_entry

     

       
205
       
 
       


     

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

     

       
207
       
+
       


     

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

     

       
209
       
 
       


     

       
210
       
 
       
let init fs proc s =

     

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

     

       
212
       
 
       
  List.iter

     

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

     

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

     

       
215
       
+
       
    (history s);

     

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

     

       
217
       
+
       
  let tools =

     

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

     

       
219
       
+
       
    Eio.Fiber.List.iter

     

       
220
       
+
       
      (fun (toolname, content) ->

     

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

     

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

     

       
223
       
+
       
      tools;

     

       
224
       
+
       
    tool_dir

     

       
225
       
+
       
  in

     

       
226
       
+
       
  { store; tool_dir = tools }

     

       
227
       
+
       


     

       
228
       
+
       
(* Run a command:

     

       
229
       
+
       
  

     

       
230
       
+
       
   - TODO: pretty confusing that we `entry` to build from and also as the

     

       
231
       
+
       
     thing we are building (e.g. the build field and the args field... *)

     

       
232
       
+
       
let exec (config : config) ~stdout fs proc

     

       
233
       
+
       
    ((H.Store ((module S), _) : entry H.t), (ctx : ctx)) (entry : entry) =

     

       
234
       
+
       
  let build, env, (uid, gid) =

     

       
235
       
+
       
    match entry.pre.build with

     

       
236
       
+
       
    | Store.Build.Image img ->

     

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

     

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

     

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

     

       
240
       
+
       
  in

     

       
241
       
+
       
  let command = entry.pre.args in

     

       
242
       
+
       
  let hash_entry =

     

       
243
       
+
       
    { entry with pre = { entry.pre with build = Build build } }

     

       
244
       
+
       
  in

     

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

     

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

     

       
247
       
+
       
     rather than needing, for example, the time it took to execute!

     

       
248
       
+
       


     

       
249
       
+
       
     Also, combine it with previous build step. *)

     

       
250
       
+
       
  let new_cid =

     

       
251
       
+
       
    Store.cid (Cid.to_string build ^ Repr.to_string History.pre_t hash_entry.pre)

     

       
252
       
+
       
  in

     

       
253
       
+
       
  let with_rootfs fn =

     

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

     

       
255
       
+
       
    else

     

       
256
       
+
       
      let diff_path =

     

       
257
       
+
       
        Eio.Path.(fs / Filename.temp_dir "shelter-diff-" "" / "diff")

     

       
258
       
+
       
      in

     

       
259
       
+
       
      Store.Run.with_clone ctx.store ~src:build new_cid diff_path fn

     

       
260
       
+
       
  in

     

       
261
       
+
       
  with_rootfs @@ function

     

       
262
       
+
       
  | `Exists path ->

     

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

     

       
264
       
+
       
      let () =

     

       
265
       
+
       
        Eio.Path.(with_open_in (fs / (path :> string) / "log")) @@ fun ic ->

     

       
266
       
+
       
        Eio.Flow.copy ic stdout

     

       
267
       
+
       
      in

     

       
268
       
+
       
      let c = Eio.Path.(load (fs / (path :> string) / "hash")) in

     

       
269
       
+
       
      Ok (`Reset c)

     

       
270
       
+
       
  | `Build rootfs ->

     

       
271
       
+
       
      let spawn sw log =

     

       
272
       
+
       
        if config.no_runc then

     

       
273
       
+
       
          (* Experiment Void Process *)

     

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

     

       
275
       
+
       
          let void =

     

       
276
       
+
       
            Void.empty

     

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

     

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

     

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

     

       
280
       
+
       
            |> Void.exec ~env

     

       
281
       
+
       
                 [

     

       
282
       
+
       
                   config.shell;

     

       
283
       
+
       
                   "-c";

     

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

     

       
285
       
+
       
                 ]

     

       
286
       
+
       
          in

     

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

     

       
288
       
+
       
        else

     

       
289
       
+
       
          let tool_mount : Runc.Json_config.mount =

     

       
290
       
+
       
            {

     

       
291
       
+
       
              ty = `Bind;

     

       
292
       
+
       
              src = ctx.tool_dir;

     

       
293
       
+
       
              dst = "/shelter-tools";

     

       
294
       
+
       
              readonly = true;

     

       
295
       
+
       
            }

     

       
296
       
+
       
          in

     

       
297
       
+
       
          let config =

     

       
298
       
+
       
            Runc.Json_config.

     

       
299
       
+
       
              {

     

       
300
       
+
       
                cwd = entry.pre.cwd;

     

       
301
       
+
       
                argv =

     

       
302
       
+
       
                  [

     

       
303
       
+
       
                    config.shell;

     

       
304
       
+
       
                    "-c";

     

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

     

       
306
       
+
       
                  ];

     

       
307
       
+
       
                hostname = "builder";

     

       
308
       
+
       
                network = [ "host" ];

     

       
309
       
+
       
                user = (uid, gid);

     

       
310
       
+
       
                env = entry.pre.env;

     

       
311
       
+
       
                mounts = [ tool_mount ];

     

       
312
       
+
       
                entrypoint = None;

     

       
313
       
+
       
              }

     

       
314
       
+
       
          in

     

       
315
       
+
       
          let env =

     

       
316
       
+
       
            object

     

       
317
       
+
       
              method fs = fs

     

       
318
       
+
       
              method proc = proc

     

       
319
       
+
       
              method stdout = stdout

     

       
320
       
+
       
            end

     

       
321
       
+
       
          in

     

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

     

       
323
       
+
       
      in

     

       
324
       
+
       
      let start, res =

     

       
325
       
+
       
        Switch.run @@ fun sw ->

     

       
326
       
+
       
        let log =

     

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

     

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

     

       
329
       
+
       
        in

     

       
330
       
+
       
        let res = spawn sw log in

     

       
331
       
+
       
        let start = Mtime_clock.now () in

     

       
332
       
+
       
        match res with

     

       
333
       
+
       
        | `Runc r -> (start, Eio.Process.await r)

     

       
334
       
+
       
        | `Void v -> (start, Void.to_eio_status (Eio.Promise.await v))

     

       
335
       
+
       
      in

     

       
336
       
+
       
      let stop = Mtime_clock.now () in

     

       
337
       
+
       
      let span = Mtime.span start stop in

     

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

     

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

     

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

     

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

     

       
342
       
+
       
      in

     

       
343
       
+
       
      if res = `Exited 0 then (

     

       
344
       
+
       
        (* Extract env *)

     

       
345
       
+
       
        let env_path =

     

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

     

       
347
       
+
       
        in

     

       
348
       
+
       
        let env =

     

       
349
       
+
       
          Eio.Path.(load env_path)

     

       
350
       
+
       
          |> String.split_on_char '\n'

     

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

     

       
352
       
+
       
        in

     

       
353
       
+
       
        Eio.Path.unlink env_path;

     

       
354
       
+
       
        let cwd =

     

       
355
       
+
       
          List.find_map

     

       
356
       
+
       
            (fun v ->

     

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

     

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

     

       
359
       
+
       
              | _ -> None)

     

       
360
       
+
       
            env

     

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

     

       
362
       
+
       
        in

     

       
363
       
+
       
        if entry.pre.mode = RW then

     

       
364
       
+
       
          Ok

     

       
365
       
+
       
            (`Entry

     

       
366
       
+
       
               ( {

     

       
367
       
+
       
                   hash_entry with

     

       
368
       
+
       
                   History.pre =

     

       
369
       
+
       
                     {

     

       
370
       
+
       
                       hash_entry.pre with

     

       
371
       
+
       
                       build = Build new_cid;

     

       
372
       
+
       
                       env;

     

       
373
       
+
       
                       cwd;

     

       
374
       
+
       
                       user = (uid, gid);

     

       
375
       
+
       
                     };

     

       
376
       
+
       
                 },

     

       
377
       
+
       
                 rootfs ))

     

       
378
       
+
       
        else

     

       
379
       
+
       
          Ok

     

       
380
       
+
       
            (`Entry

     

       
381
       
+
       
               ( {

     

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

     

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

     

       
384
       
+
       
                 },

     

       
385
       
+
       
                 rootfs )))

     

       
386
       
+
       
      else Shelter.process_error (Eio.Process.Child_error res)

     

       
387
       
+
       


     

       
388
       
+
       
let complete_exec ((H.Store ((module S), store) as s : entry H.t), ctx) clock fs

     

       
389
       
+
       
    new_entry diff =

     

       
390
       
+
       
  match new_entry with

     

       
391
       
+
       
  | Error e -> Error e

     

       
392
       
+
       
  | Ok (`Reset c) -> (

     

       
393
       
+
       
      match

     

       
394
       
+
       
        S.Hash.unsafe_of_raw_string c |> S.Commit.of_hash (S.repo store)

     

       
395
       
+
       
      with

     

       
396
       
+
       
      | None ->

     

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

     

       
398
       
+
       
          Ok (s, ctx)

     

       
399
       
+
       
      | Some c ->

     

       
400
       
+
       
          S.Head.set store c;

     

       
401
       
+
       
          Ok (s, ctx))

     

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

     

       
403
       
+
       
      (* Set diff *)

     

       
404
       
+
       
      let entry = History.{ entry with post = { entry.post with diff } } in

     

       
405
       
+
       
      (* Commit if RW *)

     

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

     

       
407
       
+
       
        commit

     

       
408
       
+
       
          ~message:("exec " ^ String.concat " " entry.pre.args)

     

       
409
       
+
       
          clock s entry;

     

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

     

       
411
       
+
       
        let hash = S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string in

     

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

     

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

     

       
414
       
+
       
          hash);

     

       
415
       
+
       
      Ok (s, ctx)

     

       
416
       
+
       


     

       
417
       
+
       
let replay config (H.Store ((module S), s) as store : entry H.t) ctx fs clock

     

       
418
       
+
       
    proc stdout existing_branch =

     

       
419
       
+
       
  let seshes = sessions store in

     

       
420
       
+
       
  if not (List.exists (String.equal existing_branch) seshes) then (

     

       
421
       
+
       
    Fmt.epr "%s does not exist!" existing_branch;

     

       
422
       
+
       
    Ok (store, ctx))

     

       
423
       
+
       
  else

     

       
424
       
+
       
    let repo = S.repo s in

     

       
425
       
+
       
    let onto = S.of_branch repo existing_branch in

     

       
426
       
+
       
    match S.lcas ~n:1 s onto with

     

       
427
       
+
       
    | Error lcas_error ->

     

       
428
       
+
       
        Fmt.epr "Replay LCAS: %a" (Repr.pp S.lca_error_t) lcas_error;

     

       
429
       
+
       
        Ok (store, ctx)

     

       
430
       
+
       
    | Ok [ lcas ] -> (

     

       
431
       
+
       
        let all_commits = history store in

     

       
432
       
+
       
        let lcas_hash = S.Commit.hash lcas |> S.Hash.to_raw_string in

     

       
433
       
+
       
        let rec collect = function

     

       
434
       
+
       
          | [] -> []

     

       
435
       
+
       
          | (x, _) :: _ when String.equal lcas_hash x -> []

     

       
436
       
+
       
          | v :: vs -> v :: collect vs

     

       
437
       
+
       
        in

     

       
438
       
+
       
        let commits_to_apply = collect all_commits in

     

       
439
       
+
       
        match commits_to_apply with

     

       
440
       
+
       
        | [] -> Shelter.shell_error ""

     

       
441
       
+
       
        | (h, first) :: rest ->

     

       
442
       
+
       
            let _, last_other =

     

       
443
       
+
       
              history (H.Store ((module S), onto)) |> List.hd

     

       
444
       
+
       
            in

     

       
445
       
+
       
            let new_first =

     

       
446
       
+
       
              {

     

       
447
       
+
       
                first with

     

       
448
       
+
       
                pre = { first.pre with build = last_other.pre.build };

     

       
449
       
+
       
              }

     

       
450
       
+
       
            in

     

       
451
       
+
       
            let commits_to_apply = (h, new_first) :: rest in

     

       
452
       
+
       
            (* Now we reset our head to point to the other store's head

     

       
453
       
+
       
           and replay our commits onto it *)

     

       
454
       
+
       
            let other_head = S.Head.get onto in

     

       
455
       
+
       
            S.Head.set s other_head;

     

       
456
       
+
       
            let res =

     

       
457
       
+
       
              List.fold_left

     

       
458
       
+
       
                (fun last (_, (entry : entry)) ->

     

       
459
       
+
       
                  match last with

     

       
460
       
+
       
                  | Error _ as e -> e

     

       
461
       
+
       
                  | Ok (new_store, new_ctx) ->

     

       
462
       
+
       
                      let new_entry, diff =

     

       
463
       
+
       
                        exec config ~stdout fs proc (new_store, new_ctx) entry

     

       
464
       
+
       
                      in

     

       
465
       
+
       
                      complete_exec (new_store, new_ctx) clock fs new_entry diff)

     

       
466
       
+
       
                (Ok (H.Store ((module S), s), ctx))

     

       
467
       
+
       
                commits_to_apply

     

       
468
       
+
       
            in

     

       
469
       
+
       
            res)

     

       
470
       
+
       
    | _ -> assert false (* Because n = 1 *)

     

       
471
       
 
       


     

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

     

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

     

       
474
       
 
       
  | Set_mode mode ->

     

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

     

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

     

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

     

       
478
       
 
       
      Ok (s, ctx)

     

       
479
       
+
       
  | Set_session m -> (

     

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

     

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

     

       
482
       
+
       
      let sessions = sessions s in

     

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

     

       
484
       
+
       
      | true ->

     

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

     

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

     

       
487
       
+
       
      | false -> (

     

       
488
       
+
       
          match fork s m with

     

       
489
       
+
       
          | Error err ->

     

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

     

       
491
       
+
       
              Ok (s, ctx)

     

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

     

       
493
       
 
       
  | Unknown args ->

     

       
494
       
+
       
      Fmt.epr "%a" (text `Red) "Unknown Shelter Action\n";

     

       
495
       
+
       
      Shelter.shell_error (String.concat " " args)

     

       
496
       
+
       
  | Info `Current ->

     

       
0
       
 
       

     

       
497
       
 
       
      let sessions = sessions s in

     

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

     

       
499
       
+
       
      let history = history s in

     

       
500
       
 
       
      let pp_commit fmt (hash, msg) =

     

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

     

       
502
       
 
       
      in

     

       
503
       
+
       
      let repo = S.repo store in

     

       
504
       
 
       
      let commits =

     

       
505
       
+
       
        List.fold_left

     

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

     

       
507
       
+
       
            let commit =

     

       
508
       
+
       
              S.Hash.unsafe_of_raw_string commit

     

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

     

       
510
       
+
       
            in

     

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

     

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

     

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

     

       
514
       
+
       
          [] history

     

       
515
       
 
       
      in

     

       
516
       
 
       
      let latest =

     

       
517
       
 
       
        with_latest

     

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

     

       
519
       
 
       
          s

     

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

     

       
521
       
 
       
      in

     

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

     

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

     
···

       
529
       
 
       
      Ok (s, ctx)

     

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

     

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

     

       
532
       
+
       
  | Replay branch -> replay config s ctx fs clock proc stdout branch

     

       
533
       
+
       
  | Info `History ->

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
534
       
 
       
      display_history s;

     

       
535
       
 
       
      Ok (s, ctx)

     

       
536
       
 
       
  | Exec command -> (

     
···

       
539
       
 
       
          ~default:(fun () ->

     

       
540
       
 
       
            History.

     

       
541
       
 
       
              {

     

       
542
       
+
       
                pre =

     

       
543
       
+
       
                  {

     

       
544
       
+
       
                    mode = Void.RW;

     

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

     

       
546
       
+
       
                    args = command;

     

       
547
       
+
       
                    (* TODO: extract with fetch *)

     

       
548
       
+
       
                    env = [];

     

       
549
       
+
       
                    cwd = "/";

     

       
550
       
+
       
                    user = (0, 0);

     

       
551
       
+
       
                  };

     

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

     

       
553
       
 
       
              })

     

       
554
       
+
       
          s Fun.id

     

       
0
       
 
       

     

       
555
       
 
       
      in

     

       
556
       
+
       
      let entry = { entry with pre = { entry.pre with args = command } } in

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
557
       
 
       
      try

     

       
558
       
+
       
        let new_entry, diff = exec config ~stdout fs proc (s, ctx) entry in

     

       
559
       
+
       
        complete_exec (s, ctx) clock fs new_entry diff

     

       
560
       
+
       
      with Eio.Exn.Io (Eio.Process.E e, _) -> Shelter.process_error e)

     

       
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
       
 
       

     

       
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