comparing 72ca76f2ab52d1c584bf93b9130be290ffebe615 and fix-build on anil.recoil.org/shelter

+5 -3

dune-project

···

       19
       19
        
        (synopsis "Shelter from the Storm")

     

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

     

       21
       21
        
        (depends

     

       22
       22
       -
          ocaml

     

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

     

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

     

       23
       24
        
          eio_posix

     

       24
       24
       -
          void

     

       25
       25
        
          zfs

     

       26
       26
        
          cid

     

       27
       27
        
          ppx_repr

     

       28
       28
       -
          irmin-fs

     

       28
       28
       +
          irmin-git

     

       29
       29
       +
          morbig

     

       30
       30
       +
          ppx_blob

     

       29
       31
        
          cmdliner

     

       30
       32
        
         )

     

       31
       33
        
        (tags

+8 -4

shelter.opam

···

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

     

       11
       11
        
       depends: [

     

       12
       12
        
         "dune" {>= "3.17"}

     

       13
       13
       -
         "ocaml"

     

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

     

       14
       14
       +
         "ctypes" {< "0.23.0"}

     

       14
       15
        
         "eio_posix"

     

       15
       15
       -
         "void"

     

       16
       16
        
         "zfs"

     

       17
       17
        
         "cid"

     

       18
       18
        
         "ppx_repr"

     

       19
       19
       -
         "irmin-fs"

     

       19
       19
       +
         "irmin-git"

     

       20
       20
       +
         "morbig"

     

       21
       21
       +
         "ppx_blob"

     

       20
       22
        
         "cmdliner"

     

       21
       23
        
         "odoc" {with-doc}

     

       22
       24
        
       ]

     
···

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       43
       47
        
       ]

+3 -1

shelter.opam.template

···

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       6
       8
        
       ]

+13 -5

src/bin/main.ml

···

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

     

       16
       16
        
         path

     

       17
       17
        
       

     

       18
       18
       +
       module Eventloop = struct

     

       19
       19
       +
         let run fn =

     

       20
       20
       +
           Eio_posix.run @@ fun env ->

     

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

     

       22
       22
       +
       end

     

       23
       23
       +
       

     

       18
       24
        
       (* Command Line *)

     

       19
       25
        
       open Cmdliner

     

       20
       26
        
       

     
···

       27
       33
        
       

     

       28
       34
        
       let main =

     

       29
       35
        
         let run config cmd_file =

     

       30
       30
       -
           Eio_posix.run @@ fun env ->

     

       36
       36
       +
           Eventloop.run @@ fun env ->

     

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

     

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

     

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

     

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

     

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

     

       34
       41
        
         in

     

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

     

       36
       43
        
         let man =

     
···

       46
       53
        
       

     

       47
       54
        
       let passthrough =

     

       48
       55
        
         let run config cmd_file =

     

       49
       49
       -
           Eio_posix.run @@ fun env ->

     

       56
       56
       +
           Eventloop.run @@ fun env ->

     

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

     

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

     

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

     

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

     

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

     

       53
       61
        
         in

     

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

     

       55
       63
        
         let info = Cmd.info "passthrough" in

     
···

       57
       65
        
       

     

       58
       66
        
       let extract_commands =

     

       59
       67
        
         let run cmd_file =

     

       60
       60
       -
           Eio_posix.run @@ fun env ->

     

       68
       68
       +
           Eventloop.run @@ fun env ->

     

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

     

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

     

       63
       71
        
         in

+1 -1

src/lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (name shelter)

     

       3
       3
        
        (public_name shelter)

     

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

     

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

+10 -2

src/lib/engine.ml

···

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

     

       18
       18
        
             shell *)

     

       19
       19
        
       

     

       20
       20
       +
         type error

     

       21
       21
       +
         (** Shell specific errors *)

     

       22
       22
       +
       

     

       23
       23
       +
         val pp_error : error Fmt.t

     

       24
       24
       +
       

     

       20
       25
        
         val init :

     

       21
       26
        
           _ Eio.Path.t ->

     

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

     
···

       27
       32
        
       

     

       28
       33
        
         val run :

     

       29
       34
        
           config ->

     

       30
       30
       -
           _ Eio.Path.t ->

     

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

     

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

     

       31
       37
        
           _ Eio.Time.clock ->

     

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

     

       33
       39
        
           entry History.t * ctx ->

     

       34
       40
        
           action ->

     

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

     

       41
       41
       +
           ( entry History.t * ctx,

     

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

     

       43
       43
       +
           result

     

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

     

       37
       45
        
             that can be persisted *)

     

       38
       46

+7 -3

src/lib/passthrough/shelter_passthrough.ml

···

       1
       1
        
       open Eio

     

       2
       2
        
       

     

       3
       3
       +
       type error = string

     

       4
       4
       +
       

     

       5
       5
       +
       let pp_error = Fmt.string

     

       6
       6
       +
       

     

       3
       7
        
       type config = unit

     

       4
       8
        
       

     

       5
       9
        
       let config_term = Cmdliner.Term.const ()

     
···

       37
       41
        
             in

     

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

     

       39
       43
        
       

     

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

     

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

     

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

     

       42
       46
        
              full_store),

     

       43
       47
        
             () ) (Exec command) =

     
···

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

     

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

     

       58
       62
        
             Ok (full_store, ()))

     

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

     

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

     

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

     

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

+22 -3

src/lib/shelter/config.ml

···

       1
       1
       -
       type t = { no_diffing : bool; no_ebpf : bool }

     

       1
       1
       +
       type t = {

     

       2
       2
       +
         no_diffing : bool;

     

       3
       3
       +
         no_ebpf : bool;

     

       4
       4
       +
         no_runc : bool;

     

       5
       5
       +
         image : string;

     

       6
       6
       +
         shell : string;

     

       7
       7
       +
       }

     

       2
       8
        
       

     

       3
       9
        
       let cmdliner =

     

       4
       10
        
         let open Cmdliner in

     
···

       10
       16
        
           let doc = "Disable eBPF." in

     

       11
       17
        
           Arg.(value & flag & info [ "no-ebpf" ] ~doc)

     

       12
       18
        
         in

     

       19
       19
       +
         let image =

     

       20
       20
       +
           let doc = "Base image to start Shelter with." in

     

       21
       21
       +
           Arg.(value & opt string "alpine" & info [ "image" ] ~doc)

     

       22
       22
       +
         in

     

       23
       23
       +
         let shell =

     

       24
       24
       +
           let doc = "Path to the shell (e.g. /bin/ash)" in

     

       25
       25
       +
           Arg.(value & opt string "/bin/ash" & info [ "shell" ] ~doc)

     

       26
       26
       +
         in

     

       27
       27
       +
         let no_runc =

     

       28
       28
       +
           let doc = "Disable RUNC and use Void processes." in

     

       29
       29
       +
           Arg.(value & flag & info [ "no-runc" ] ~doc)

     

       30
       30
       +
         in

     

       13
       31
        
         Term.(

     

       14
       14
       -
           const (fun no_diffing no_ebpf -> { no_diffing; no_ebpf })

     

       15
       15
       -
           $ no_diffing $ no_ebpf)

     

       32
       32
       +
           const (fun no_diffing no_ebpf no_runc image shell ->

     

       33
       33
       +
               { no_diffing; no_ebpf; no_runc; image; shell })

     

       34
       34
       +
           $ no_diffing $ no_ebpf $ no_runc $ image $ shell)

+8 -1

src/lib/shelter/dune

···

       1
       1
       +
       ; (rule

     

       2
       2
       +
       ;   (target opentrace)

     

       3
       3
       +
       ;   (action

     

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

     

       5
       5
       +
       

     

       1
       6
        
       (library

     

       2
       7
        
        (name shelter_main)

     

       3
       8
        
        (public_name shelter.main)

     

       9
       9
       +
        (preprocessor_deps

     

       10
       10
       +
         (file opentrace))

     

       4
       11
        
        (preprocess

     

       5
       5
       -
         (pps ppx_repr))

     

       12
       12
       +
         (pps ppx_repr ppx_blob))

     

       6
       13
        
        (libraries shelter cid void zfs))

+29 -2

src/lib/shelter/fetch.ml

···

       1
       1
        
       let ( / ) = Eio.Path.( / )

     

       2
       2
       +
       let replace_slash s = String.split_on_char '/' s |> String.concat "-"

     

       3
       3
       +
       

     

       4
       4
       +
       let get_user proc image =

     

       5
       5
       +
         Eio.Process.parse_out proc Eio.Buf_read.take_all

     

       6
       6
       +
           [

     

       7
       7
       +
             "docker";

     

       8
       8
       +
             "image";

     

       9
       9
       +
             "inspect";

     

       10
       10
       +
             "--format";

     

       11
       11
       +
             {|{{.Config.User}}|};

     

       12
       12
       +
             "--";

     

       13
       13
       +
             image;

     

       14
       14
       +
           ]

     

       15
       15
       +
         |> String.trim

     

       16
       16
       +
       

     

       17
       17
       +
       let get_env proc image =

     

       18
       18
       +
         Eio.Process.parse_out proc Eio.Buf_read.take_all

     

       19
       19
       +
           [

     

       20
       20
       +
             "docker";

     

       21
       21
       +
             "image";

     

       22
       22
       +
             "inspect";

     

       23
       23
       +
             "--format";

     

       24
       24
       +
             {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|};

     

       25
       25
       +
             "--";

     

       26
       26
       +
             image;

     

       27
       27
       +
           ]

     

       28
       28
       +
         |> String.split_on_char '\x00'

     

       2
       29
        
       

     

       3
       30
        
       let get_image ~dir ~proc image =

     

       4
       31
        
         let container_id =

     
···

       6
       33
        
             [ "docker"; "run"; "-d"; image ]

     

       7
       34
        
           |> String.trim

     

       8
       35
        
         in

     

       9
       9
       -
         let tar = image ^ ".tar.gz" in

     

       36
       36
       +
         let tar = replace_slash image ^ ".tar.gz" in

     

       10
       37
        
         let dir_s = Eio.Path.native_exn dir in

     

       11
       38
        
         let () =

     

       12
       39
        
           Eio.Process.run proc

     
···

       18
       45
        
             [

     

       19
       46
        
               "tar";

     

       20
       47
        
               "-xf";

     

       21
       21
       -
               Filename.concat dir_s "alpine.tar.gz";

     

       48
       48
       +
               Filename.concat dir_s tar;

     

       22
       49
        
               "-C";

     

       23
       50
        
               Filename.concat dir_s "rootfs";

     

       24
       51
        
             ]

src/lib/shelter/opentrace

This is a binary file and will not be displayed.

+498

src/lib/shelter/runc.ml

···

       1
       1
       +
       (* From Obuilder see License file at end of document *)

     

       2
       2
       +
       let ( / ) = Eio.Path.( / )

     

       3
       3
       +
       let ( // ) = Filename.concat

     

       4
       4
       +
       

     

       5
       5
       +
       type config = { fast_sync : bool }

     

       6
       6
       +
       

     

       7
       7
       +
       let get_machine () =

     

       8
       8
       +
         let ch = Unix.open_process_in "uname -m" in

     

       9
       9
       +
         let arch = input_line ch in

     

       10
       10
       +
         match Unix.close_process_in ch with

     

       11
       11
       +
         | Unix.WEXITED 0 -> String.trim arch

     

       12
       12
       +
         | _ -> failwith "Failed to get arch with 'uname -m'"

     

       13
       13
       +
       

     

       14
       14
       +
       let get_arches () =

     

       15
       15
       +
         if Sys.unix then

     

       16
       16
       +
           match get_machine () with

     

       17
       17
       +
           | "x86_64" -> [ "SCMP_ARCH_X86_64"; "SCMP_ARCH_X86"; "SCMP_ARCH_X32" ]

     

       18
       18
       +
           | "aarch64" -> [ "SCMP_ARCH_AARCH64"; "SCMP_ARCH_ARM" ]

     

       19
       19
       +
           | _ -> []

     

       20
       20
       +
         else []

     

       21
       21
       +
       

     

       22
       22
       +
       let secret_file id = "secret-" ^ string_of_int id

     

       23
       23
       +
       

     

       24
       24
       +
       module Json_config = struct

     

       25
       25
       +
         let mount ?(options = []) ~ty ~src dst =

     

       26
       26
       +
           `Assoc

     

       27
       27
       +
             [

     

       28
       28
       +
               ("destination", `String dst);

     

       29
       29
       +
               ("type", `String ty);

     

       30
       30
       +
               ("source", `String src);

     

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

     

       32
       32
       +
             ]

     

       33
       33
       +
       

     

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

     

       35
       35
       +
       

     

       36
       36
       +
         let user_mounts =

     

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

     

       38
       38
       +
           assert (ty = `Bind);

     

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

     

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

     

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

     

       42
       42
       +
       

     

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

     

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

     

       45
       45
       +
       

     

       46
       46
       +
         (* This is a subset of the capabilities that Docker uses by default.

     

       47
       47
       +
            These control what root can do in the container.

     

       48
       48
       +
            If the init process is non-root, permitted, effective and ambient sets are cleared.

     

       49
       49
       +
            See capabilities(7) for full details. *)

     

       50
       50
       +
         let default_linux_caps =

     

       51
       51
       +
           [

     

       52
       52
       +
             "CAP_CHOWN";

     

       53
       53
       +
             (* Make arbitrary changes to file UIDs and GIDs *)

     

       54
       54
       +
             "CAP_DAC_OVERRIDE";

     

       55
       55
       +
             (* Bypass file read, write, and execute permission checks. *)

     

       56
       56
       +
             "CAP_FSETID";

     

       57
       57
       +
             (* Set SUID/SGID bits. *)

     

       58
       58
       +
             "CAP_FOWNER";

     

       59
       59
       +
             (* Bypass permission checks. *)

     

       60
       60
       +
             "CAP_MKNOD";

     

       61
       61
       +
             (* Create special files using mknod. *)

     

       62
       62
       +
             "CAP_SETGID";

     

       63
       63
       +
             (* Make arbitrary manipulations of process GIDs. *)

     

       64
       64
       +
             "CAP_SETUID";

     

       65
       65
       +
             (* Make arbitrary manipulations of process UIDs. *)

     

       66
       66
       +
             "CAP_SETFCAP";

     

       67
       67
       +
             (* Set arbitrary capabilities on a file. *)

     

       68
       68
       +
             "CAP_SETPCAP";

     

       69
       69
       +
             (* Add any capability from bounding set to inheritable set. *)

     

       70
       70
       +
             "CAP_SYS_CHROOT";

     

       71
       71
       +
             (* Use chroot. *)

     

       72
       72
       +
             "CAP_KILL";

     

       73
       73
       +
             (* Bypass permission checks for sending signals. *)

     

       74
       74
       +
             "CAP_AUDIT_WRITE"

     

       75
       75
       +
             (* Write records to kernel auditing log. *)

     

       76
       76
       +
             (* Allowed by Docker, but disabled here (because we use host networking):

     

       77
       77
       +
           "CAP_NET_RAW";              (* Use RAW and PACKET sockets / bind to any address *)

     

       78
       78
       +
           "CAP_NET_BIND_SERVICE";     (* Bind a socket to Internet domain privileged ports. *)

     

       79
       79
       +
           *);

     

       80
       80
       +
           ]

     

       81
       81
       +
       

     

       82
       82
       +
         let seccomp_syscalls ~fast_sync =

     

       83
       83
       +
           if fast_sync then

     

       84
       84
       +
             [

     

       85
       85
       +
               `Assoc

     

       86
       86
       +
                 [

     

       87
       87
       +
                   (* Sync calls are pointless for the builder, because if the computer crashes then we'll

     

       88
       88
       +
                  just throw the build dir away and start again. And btrfs sync is really slow.

     

       89
       89
       +
                  Based on https://bblank.thinkmo.de/using-seccomp-to-filter-sync-operations.html

     

       90
       90
       +
                  Note: requires runc >= v1.0.0-rc92. *)

     

       91
       91
       +
                   ( "names",

     

       92
       92
       +
                     strings

     

       93
       93
       +
                       [

     

       94
       94
       +
                         "fsync";

     

       95
       95
       +
                         "fdatasync";

     

       96
       96
       +
                         "msync";

     

       97
       97
       +
                         "sync";

     

       98
       98
       +
                         "syncfs";

     

       99
       99
       +
                         "sync_file_range";

     

       100
       100
       +
                       ] );

     

       101
       101
       +
                   ("action", `String "SCMP_ACT_ERRNO");

     

       102
       102
       +
                   ("errnoRet", `Int 0);

     

       103
       103
       +
                   (* Return error "success" *)

     

       104
       104
       +
                 ];

     

       105
       105
       +
             ]

     

       106
       106
       +
           else []

     

       107
       107
       +
       

     

       108
       108
       +
         let seccomp_policy =

     

       109
       109
       +
           let fields =

     

       110
       110
       +
             [

     

       111
       111
       +
               ("defaultAction", `String "SCMP_ACT_ALLOW");

     

       112
       112
       +
               ("syscalls", `List (seccomp_syscalls ~fast_sync:true));

     

       113
       113
       +
             ]

     

       114
       114
       +
           in

     

       115
       115
       +
           `Assoc fields

     

       116
       116
       +
       

     

       117
       117
       +
         type config = {

     

       118
       118
       +
           cwd : string;

     

       119
       119
       +
           argv : string list;

     

       120
       120
       +
           hostname : string;

     

       121
       121
       +
           network : string list;

     

       122
       122
       +
           user : int * int;

     

       123
       123
       +
           env : string list;

     

       124
       124
       +
           mounts : mount list;

     

       125
       125
       +
           entrypoint : string option;

     

       126
       126
       +
         }

     

       127
       127
       +
       

     

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

     

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

     

       130
       130
       +
           assert (entrypoint = None);

     

       131
       131
       +
           let user =

     

       132
       132
       +
             let uid, gid = user in

     

       133
       133
       +
             `Assoc [ ("uid", `Int uid); ("gid", `Int gid) ]

     

       134
       134
       +
           in

     

       135
       135
       +
           let network_ns =

     

       136
       136
       +
             match network with

     

       137
       137
       +
             | [ "host" ] -> []

     

       138
       138
       +
             | [] -> [ "network" ]

     

       139
       139
       +
             | xs ->

     

       140
       140
       +
                 Fmt.failwith "Unsupported network configuration %a"

     

       141
       141
       +
                   Fmt.Dump.(list string)

     

       142
       142
       +
                   xs

     

       143
       143
       +
           in

     

       144
       144
       +
           let namespaces = network_ns @ [ "pid"; "ipc"; "uts"; "mount" ] in

     

       145
       145
       +
           `Assoc

     

       146
       146
       +
             [

     

       147
       147
       +
               ("ociVersion", `String "1.0.1-dev");

     

       148
       148
       +
               ( "process",

     

       149
       149
       +
                 `Assoc

     

       150
       150
       +
                   [

     

       151
       151
       +
                     ("terminal", `Bool false);

     

       152
       152
       +
                     ("user", user);

     

       153
       153
       +
                     ("args", strings argv);

     

       154
       154
       +
                     ("env", strings env);

     

       155
       155
       +
                     ("cwd", `String cwd);

     

       156
       156
       +
                     ( "capabilities",

     

       157
       157
       +
                       `Assoc

     

       158
       158
       +
                         [

     

       159
       159
       +
                           ("bounding", strings default_linux_caps);

     

       160
       160
       +
                           (* Limits capabilities gained on execve. *)

     

       161
       161
       +
                           ("effective", strings default_linux_caps);

     

       162
       162
       +
                           (* Checked by kernel to decide access *)

     

       163
       163
       +
                           ("inheritable", strings default_linux_caps);

     

       164
       164
       +
                           (* Preserved across an execve (if root, or cap in ambient set) *)

     

       165
       165
       +
                           ("permitted", strings default_linux_caps);

     

       166
       166
       +
                           (* Limiting superset for the effective capabilities *)

     

       167
       167
       +
                         ] );

     

       168
       168
       +
                     ( "rlimits",

     

       169
       169
       +
                       `List

     

       170
       170
       +
                         [

     

       171
       171
       +
                           `Assoc

     

       172
       172
       +
                             [

     

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

     

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

     

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

     

       176
       176
       +
                             ];

     

       177
       177
       +
                           `Assoc

     

       178
       178
       +
                             [

     

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

     

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

     

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

     

       182
       182
       +
                             ];

     

       183
       183
       +
                         ] );

     

       184
       184
       +
                     ("noNewPrivileges", `Bool false);

     

       185
       185
       +
                   ] );

     

       186
       186
       +
               ( "root",

     

       187
       187
       +
                 `Assoc

     

       188
       188
       +
                   [

     

       189
       189
       +
                     ("path", `String (results_dir // "rootfs"));

     

       190
       190
       +
                     ("readonly", `Bool false);

     

       191
       191
       +
                   ] );

     

       192
       192
       +
               ("hostname", `String hostname);

     

       193
       193
       +
               ( "mounts",

     

       194
       194
       +
                 `List

     

       195
       195
       +
                   (mount "/proc"

     

       196
       196
       +
                      ~options:

     

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

     

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

     

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

     

       200
       200
       +
                         ~options:

     

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

     

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

     

       203
       203
       +
                         ~options:

     

       204
       204
       +
                           [

     

       205
       205
       +
                             "nosuid";

     

       206
       206
       +
                             "noexec";

     

       207
       207
       +
                             "newinstance";

     

       208
       208
       +
                             "ptmxmode=0666";

     

       209
       209
       +
                             "mode=0620";

     

       210
       210
       +
                             "gid=5";

     

       211
       211
       +
                             (* tty *)

     

       212
       212
       +
                           ]

     

       213
       213
       +
                    :: mount

     

       214
       214
       +
                         "/sys"

     

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

     

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

     

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

     

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

     

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

     

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

     

       221
       221
       +
                         ~options:

     

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

     

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

     

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

     

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

     

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

     

       227
       227
       +
                    ::

     

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

     

       229
       229
       +
                       [

     

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

     

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

     

       232
       232
       +
                       ]

     

       233
       233
       +
                     else [])

     

       234
       234
       +
                   @ user_mounts mounts) );

     

       235
       235
       +
               ( "linux",

     

       236
       236
       +
                 `Assoc

     

       237
       237
       +
                   [

     

       238
       238
       +
                     ("namespaces", `List (List.map namespace namespaces));

     

       239
       239
       +
                     ( "maskedPaths",

     

       240
       240
       +
                       strings

     

       241
       241
       +
                         [

     

       242
       242
       +
                           "/proc/acpi";

     

       243
       243
       +
                           "/proc/asound";

     

       244
       244
       +
                           "/proc/kcore";

     

       245
       245
       +
                           "/proc/keys";

     

       246
       246
       +
                           "/proc/latency_stats";

     

       247
       247
       +
                           "/proc/timer_list";

     

       248
       248
       +
                           "/proc/timer_stats";

     

       249
       249
       +
                           "/proc/sched_debug";

     

       250
       250
       +
                           "/sys/firmware";

     

       251
       251
       +
                           "/proc/scsi";

     

       252
       252
       +
                         ] );

     

       253
       253
       +
                     ( "readonlyPaths",

     

       254
       254
       +
                       strings

     

       255
       255
       +
                         [

     

       256
       256
       +
                           "/proc/bus";

     

       257
       257
       +
                           "/proc/fs";

     

       258
       258
       +
                           "/proc/irq";

     

       259
       259
       +
                           "/proc/sys";

     

       260
       260
       +
                           "/proc/sysrq-trigger";

     

       261
       261
       +
                         ] );

     

       262
       262
       +
                     ("seccomp", seccomp_policy);

     

       263
       263
       +
                   ] );

     

       264
       264
       +
             ]

     

       265
       265
       +
       end

     

       266
       266
       +
       

     

       267
       267
       +
       let next_id = ref 0

     

       268
       268
       +
       

     

       269
       269
       +
       let to_other_sink_as_well ~other

     

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

     

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

     

       272
       272
       +
         let copy_buf = Buffer.create 128 in

     

       273
       273
       +
         let copy () ~src =

     

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

     

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

     

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

     

       277
       277
       +
           Buffer.clear copy_buf

     

       278
       278
       +
         in

     

       279
       279
       +
         let single_write () x =

     

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

     

       281
       281
       +
           Sink.single_write t x

     

       282
       282
       +
         in

     

       283
       283
       +
         let module T = struct

     

       284
       284
       +
           type t = unit

     

       285
       285
       +
       

     

       286
       286
       +
           let single_write = single_write

     

       287
       287
       +
           let copy = copy

     

       288
       288
       +
         end in

     

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

     

       290
       290
       +
       

     

       291
       291
       +
       let spawn ~sw log env config dir =

     

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

     

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

     

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

     

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

     

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

     

       297
       297
       +
         Eio.Path.save ~create:(`If_missing 0o644) (eio_tmp / "hosts")

     

       298
       298
       +
           "127.0.0.1 localhost builder";

     

       299
       299
       +
         let id = string_of_int !next_id in

     

       300
       300
       +
         incr next_id;

     

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

     

       302
       302
       +
         let stdout =

     

       303
       303
       +
           to_other_sink_as_well ~other:env#stdout

     

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

     

       305
       305
       +
         in

     

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

     

       307
       307
       +
       

     

       308
       308
       +
       (* 

     

       309
       309
       +
                                        Apache License

     

       310
       310
       +
                                  Version 2.0, January 2004

     

       311
       311
       +
                               https://www.apache.org/licenses/

     

       312
       312
       +
       

     

       313
       313
       +
          TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION

     

       314
       314
       +
       

     

       315
       315
       +
          1. Definitions.

     

       316
       316
       +
       

     

       317
       317
       +
             "License" shall mean the terms and conditions for use, reproduction,

     

       318
       318
       +
             and distribution as defined by Sections 1 through 9 of this document.

     

       319
       319
       +
       

     

       320
       320
       +
             "Licensor" shall mean the copyright owner or entity authorized by

     

       321
       321
       +
             the copyright owner that is granting the License.

     

       322
       322
       +
       

     

       323
       323
       +
             "Legal Entity" shall mean the union of the acting entity and all

     

       324
       324
       +
             other entities that control, are controlled by, or are under common

     

       325
       325
       +
             control with that entity. For the purposes of this definition,

     

       326
       326
       +
             "control" means (i) the power, direct or indirect, to cause the

     

       327
       327
       +
             direction or management of such entity, whether by contract or

     

       328
       328
       +
             otherwise, or (ii) ownership of fifty percent (50%) or more of the

     

       329
       329
       +
             outstanding shares, or (iii) beneficial ownership of such entity.

     

       330
       330
       +
       

     

       331
       331
       +
             "You" (or "Your") shall mean an individual or Legal Entity

     

       332
       332
       +
             exercising permissions granted by this License.

     

       333
       333
       +
       

     

       334
       334
       +
             "Source" form shall mean the preferred form for making modifications,

     

       335
       335
       +
             including but not limited to software source code, documentation

     

       336
       336
       +
             source, and configuration files.

     

       337
       337
       +
       

     

       338
       338
       +
             "Object" form shall mean any form resulting from mechanical

     

       339
       339
       +
             transformation or translation of a Source form, including but

     

       340
       340
       +
             not limited to compiled object code, generated documentation,

     

       341
       341
       +
             and conversions to other media types.

     

       342
       342
       +
       

     

       343
       343
       +
             "Work" shall mean the work of authorship, whether in Source or

     

       344
       344
       +
             Object form, made available under the License, as indicated by a

     

       345
       345
       +
             copyright notice that is included in or attached to the work

     

       346
       346
       +
             (an example is provided in the Appendix below).

     

       347
       347
       +
       

     

       348
       348
       +
             "Derivative Works" shall mean any work, whether in Source or Object

     

       349
       349
       +
             form, that is based on (or derived from) the Work and for which the

     

       350
       350
       +
             editorial revisions, annotations, elaborations, or other modifications

     

       351
       351
       +
             represent, as a whole, an original work of authorship. For the purposes

     

       352
       352
       +
             of this License, Derivative Works shall not include works that remain

     

       353
       353
       +
             separable from, or merely link (or bind by name) to the interfaces of,

     

       354
       354
       +
             the Work and Derivative Works thereof.

     

       355
       355
       +
       

     

       356
       356
       +
             "Contribution" shall mean any work of authorship, including

     

       357
       357
       +
             the original version of the Work and any modifications or additions

     

       358
       358
       +
             to that Work or Derivative Works thereof, that is intentionally

     

       359
       359
       +
             submitted to Licensor for inclusion in the Work by the copyright owner

     

       360
       360
       +
             or by an individual or Legal Entity authorized to submit on behalf of

     

       361
       361
       +
             the copyright owner. For the purposes of this definition, "submitted"

     

       362
       362
       +
             means any form of electronic, verbal, or written communication sent

     

       363
       363
       +
             to the Licensor or its representatives, including but not limited to

     

       364
       364
       +
             communication on electronic mailing lists, source code control systems,

     

       365
       365
       +
             and issue tracking systems that are managed by, or on behalf of, the

     

       366
       366
       +
             Licensor for the purpose of discussing and improving the Work, but

     

       367
       367
       +
             excluding communication that is conspicuously marked or otherwise

     

       368
       368
       +
             designated in writing by the copyright owner as "Not a Contribution."

     

       369
       369
       +
       

     

       370
       370
       +
             "Contributor" shall mean Licensor and any individual or Legal Entity

     

       371
       371
       +
             on behalf of whom a Contribution has been received by Licensor and

     

       372
       372
       +
             subsequently incorporated within the Work.

     

       373
       373
       +
       

     

       374
       374
       +
          2. Grant of Copyright License. Subject to the terms and conditions of

     

       375
       375
       +
             this License, each Contributor hereby grants to You a perpetual,

     

       376
       376
       +
             worldwide, non-exclusive, no-charge, royalty-free, irrevocable

     

       377
       377
       +
             copyright license to reproduce, prepare Derivative Works of,

     

       378
       378
       +
             publicly display, publicly perform, sublicense, and distribute the

     

       379
       379
       +
             Work and such Derivative Works in Source or Object form.

     

       380
       380
       +
       

     

       381
       381
       +
          3. Grant of Patent License. Subject to the terms and conditions of

     

       382
       382
       +
             this License, each Contributor hereby grants to You a perpetual,

     

       383
       383
       +
             worldwide, non-exclusive, no-charge, royalty-free, irrevocable

     

       384
       384
       +
             (except as stated in this section) patent license to make, have made,

     

       385
       385
       +
             use, offer to sell, sell, import, and otherwise transfer the Work,

     

       386
       386
       +
             where such license applies only to those patent claims licensable

     

       387
       387
       +
             by such Contributor that are necessarily infringed by their

     

       388
       388
       +
             Contribution(s) alone or by combination of their Contribution(s)

     

       389
       389
       +
             with the Work to which such Contribution(s) was submitted. If You

     

       390
       390
       +
             institute patent litigation against any entity (including a

     

       391
       391
       +
             cross-claim or counterclaim in a lawsuit) alleging that the Work

     

       392
       392
       +
             or a Contribution incorporated within the Work constitutes direct

     

       393
       393
       +
             or contributory patent infringement, then any patent licenses

     

       394
       394
       +
             granted to You under this License for that Work shall terminate

     

       395
       395
       +
             as of the date such litigation is filed.

     

       396
       396
       +
       

     

       397
       397
       +
          4. Redistribution. You may reproduce and distribute copies of the

     

       398
       398
       +
             Work or Derivative Works thereof in any medium, with or without

     

       399
       399
       +
             modifications, and in Source or Object form, provided that You

     

       400
       400
       +
             meet the following conditions:

     

       401
       401
       +
       

     

       402
       402
       +
             (a) You must give any other recipients of the Work or

     

       403
       403
       +
                 Derivative Works a copy of this License; and

     

       404
       404
       +
       

     

       405
       405
       +
             (b) You must cause any modified files to carry prominent notices

     

       406
       406
       +
                 stating that You changed the files; and

     

       407
       407
       +
       

     

       408
       408
       +
             (c) You must retain, in the Source form of any Derivative Works

     

       409
       409
       +
                 that You distribute, all copyright, patent, trademark, and

     

       410
       410
       +
                 attribution notices from the Source form of the Work,

     

       411
       411
       +
                 excluding those notices that do not pertain to any part of

     

       412
       412
       +
                 the Derivative Works; and

     

       413
       413
       +
       

     

       414
       414
       +
             (d) If the Work includes a "NOTICE" text file as part of its

     

       415
       415
       +
                 distribution, then any Derivative Works that You distribute must

     

       416
       416
       +
                 include a readable copy of the attribution notices contained

     

       417
       417
       +
                 within such NOTICE file, excluding those notices that do not

     

       418
       418
       +
                 pertain to any part of the Derivative Works, in at least one

     

       419
       419
       +
                 of the following places: within a NOTICE text file distributed

     

       420
       420
       +
                 as part of the Derivative Works; within the Source form or

     

       421
       421
       +
                 documentation, if provided along with the Derivative Works; or,

     

       422
       422
       +
                 within a display generated by the Derivative Works, if and

     

       423
       423
       +
                 wherever such third-party notices normally appear. The contents

     

       424
       424
       +
                 of the NOTICE file are for informational purposes only and

     

       425
       425
       +
                 do not modify the License. You may add Your own attribution

     

       426
       426
       +
                 notices within Derivative Works that You distribute, alongside

     

       427
       427
       +
                 or as an addendum to the NOTICE text from the Work, provided

     

       428
       428
       +
                 that such additional attribution notices cannot be construed

     

       429
       429
       +
                 as modifying the License.

     

       430
       430
       +
       

     

       431
       431
       +
             You may add Your own copyright statement to Your modifications and

     

       432
       432
       +
             may provide additional or different license terms and conditions

     

       433
       433
       +
             for use, reproduction, or distribution of Your modifications, or

     

       434
       434
       +
             for any such Derivative Works as a whole, provided Your use,

     

       435
       435
       +
             reproduction, and distribution of the Work otherwise complies with

     

       436
       436
       +
             the conditions stated in this License.

     

       437
       437
       +
       

     

       438
       438
       +
          5. Submission of Contributions. Unless You explicitly state otherwise,

     

       439
       439
       +
             any Contribution intentionally submitted for inclusion in the Work

     

       440
       440
       +
             by You to the Licensor shall be under the terms and conditions of

     

       441
       441
       +
             this License, without any additional terms or conditions.

     

       442
       442
       +
             Notwithstanding the above, nothing herein shall supersede or modify

     

       443
       443
       +
             the terms of any separate license agreement you may have executed

     

       444
       444
       +
             with Licensor regarding such Contributions.

     

       445
       445
       +
       

     

       446
       446
       +
          6. Trademarks. This License does not grant permission to use the trade

     

       447
       447
       +
             names, trademarks, service marks, or product names of the Licensor,

     

       448
       448
       +
             except as required for reasonable and customary use in describing the

     

       449
       449
       +
             origin of the Work and reproducing the content of the NOTICE file.

     

       450
       450
       +
       

     

       451
       451
       +
          7. Disclaimer of Warranty. Unless required by applicable law or

     

       452
       452
       +
             agreed to in writing, Licensor provides the Work (and each

     

       453
       453
       +
             Contributor provides its Contributions) on an "AS IS" BASIS,

     

       454
       454
       +
             WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or

     

       455
       455
       +
             implied, including, without limitation, any warranties or conditions

     

       456
       456
       +
             of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A

     

       457
       457
       +
             PARTICULAR PURPOSE. You are solely responsible for determining the

     

       458
       458
       +
             appropriateness of using or redistributing the Work and assume any

     

       459
       459
       +
             risks associated with Your exercise of permissions under this License.

     

       460
       460
       +
       

     

       461
       461
       +
          8. Limitation of Liability. In no event and under no legal theory,

     

       462
       462
       +
             whether in tort (including negligence), contract, or otherwise,

     

       463
       463
       +
             unless required by applicable law (such as deliberate and grossly

     

       464
       464
       +
             negligent acts) or agreed to in writing, shall any Contributor be

     

       465
       465
       +
             liable to You for damages, including any direct, indirect, special,

     

       466
       466
       +
             incidental, or consequential damages of any character arising as a

     

       467
       467
       +
             result of this License or out of the use or inability to use the

     

       468
       468
       +
             Work (including but not limited to damages for loss of goodwill,

     

       469
       469
       +
             work stoppage, computer failure or malfunction, or any and all

     

       470
       470
       +
             other commercial damages or losses), even if such Contributor

     

       471
       471
       +
             has been advised of the possibility of such damages.

     

       472
       472
       +
       

     

       473
       473
       +
          9. Accepting Warranty or Additional Liability. While redistributing

     

       474
       474
       +
             the Work or Derivative Works thereof, You may choose to offer,

     

       475
       475
       +
             and charge a fee for, acceptance of support, warranty, indemnity,

     

       476
       476
       +
             or other liability obligations and/or rights consistent with this

     

       477
       477
       +
             License. However, in accepting such obligations, You may act only

     

       478
       478
       +
             on Your own behalf and on Your sole responsibility, not on behalf

     

       479
       479
       +
             of any other Contributor, and only if You agree to indemnify,

     

       480
       480
       +
             defend, and hold each Contributor harmless for any liability

     

       481
       481
       +
             incurred by, or claims asserted against, such Contributor by reason

     

       482
       482
       +
             of your accepting any such warranty or additional liability.

     

       483
       483
       +
       

     

       484
       484
       +
          END OF TERMS AND CONDITIONS

     

       485
       485
       +
       

     

       486
       486
       +
          Copyright 2020 Thomas Leonard

     

       487
       487
       +
       

     

       488
       488
       +
          Licensed under the Apache License, Version 2.0 (the "License");

     

       489
       489
       +
          you may not use this file except in compliance with the License.

     

       490
       490
       +
          You may obtain a copy of the License at

     

       491
       491
       +
       

     

       492
       492
       +
              https://www.apache.org/licenses/LICENSE-2.0

     

       493
       493
       +
       

     

       494
       494
       +
          Unless required by applicable law or agreed to in writing, software

     

       495
       495
       +
          distributed under the License is distributed on an "AS IS" BASIS,

     

       496
       496
       +
          WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.

     

       497
       497
       +
          See the License for the specific language governing permissions and

     

       498
       498
       +
          limitations under the License. *)

+391 -127

src/lib/shelter/shelter_main.ml

···

       2
       2
        
       module Store = Store

     

       3
       3
        
       module H = Shelter.History

     

       4
       4
        
       

     

       5
       5
       +
       type error = string

     

       6
       6
       +
       

     

       7
       7
       +
       let pp_error = Fmt.string

     

       8
       8
       +
       

     

       5
       9
        
       module History = struct

     

       6
       10
        
         type mode = Void.mode

     

       7
       11
        
       

     
···

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

     

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

     

       13
       17
        
       

     

       14
       14
       -
         type t = {

     

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

     

       19
       19
       +
       

     

       20
       20
       +
         type pre = {

     

       15
       21
        
           mode : mode;

     

       16
       22
        
           build : Store.Build.t;

     

       17
       23
        
           args : string list;

     

       18
       18
       -
           time : int64;

     

       19
       19
       -
           diff : Diff.t;

     

       24
       24
       +
           env : string list;

     

       25
       25
       +
           cwd : string;

     

       26
       26
       +
           user : int * int;

     

       20
       27
        
         }

     

       21
       28
        
         [@@deriving repr]

     

       29
       29
       +
         (** Needed for execution *)

     

       30
       30
       +
       

     

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

     

       22
       32
        
       

     

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

     

       24
       34
        
       end

     
···

       30
       40
        
       type entry = History.t

     

       31
       41
        
       

     

       32
       42
        
       type action =

     

       43
       43
       +
         (* Change modes *)

     

       33
       44
        
         | Set_mode of History.mode

     

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

     

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

     

       34
       47
        
         | Set_session of string

     

       48
       48
       +
         (* Run a command *)

     

       35
       49
        
         | Exec of string list

     

       36
       36
       -
         | Info

     

       50
       50
       +
         (* Undo the last command *)

     

       37
       51
        
         | Undo

     

       38
       38
       -
         | Fork of string

     

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

     

       39
       53
        
         | Replay of string

     

       54
       54
       +
         (* Display info *)

     

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

     

       56
       56
       +
         (* Error state *)

     

       40
       57
        
         | Unknown of string list

     

       41
       41
       -
         | History

     

       42
       58
        
       [@@deriving repr]

     

       43
       59
        
       

     

       44
       60
        
       let split_and_remove_empty s =

     
···

       48
       64
        
       

     

       49
       65
        
       let shelter_action = function

     

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

     

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

     

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

     

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

     

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

     

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

     

       55
       55
       -
         | [ "info" ] -> Info

     

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

     

       56
       71
        
         | [ "undo" ] -> Undo

     

       57
       57
       -
         | [ "history" ] -> History

     

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

     

       58
       73
        
         | other -> Unknown other

     

       59
       74
        
       

     

       60
       75
        
       let action_of_command cmd =

     
···

       66
       81
        
       let history_key = [ "history" ]

     

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

     

       68
       83
        
       

     

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

     

       70
       70
       -
         match S.list store history_key with

     

       71
       71
       -
         | [] -> []

     

       72
       72
       -
         | xs ->

     

       73
       73
       -
             let rec loop acc = function

     

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

     

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

     

       76
       76
       -
               | [] -> List.rev acc

     

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

     

       85
       85
       +
         let repo = S.repo store in

     

       86
       86
       +
         match S.Head.find store with

     

       87
       87
       +
         | None -> []

     

       88
       88
       +
         | Some hd ->

     

       89
       89
       +
             let rec linearize c =

     

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

     

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

     

       92
       92
       +
               | _ -> [ c ]

     

       77
       93
        
             in

     

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

     

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

     

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

     

       81
       81
       -
             |> List.rev

     

       94
       94
       +
             let commits = linearize hd in

     

       95
       95
       +
             let get_diff_content t1 t2 =

     

       96
       96
       +
               match S.Tree.diff t1 t2 with

     

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

     

       98
       98
       +
               | lst ->

     

       99
       99
       +
                   let pp_diff =

     

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

     

       101
       101
       +
                   in

     

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

     

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

     

       104
       104
       +
                     lst;

     

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

     

       106
       106
       +
             in

     

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

     

       108
       108
       +
             let rec diff_calc = function

     

       109
       109
       +
               | [] -> []

     

       110
       110
       +
               | [ x ] ->

     

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

     

       112
       112
       +
                   [ (hash x, diff) ]

     

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

     

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

     

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

     

       116
       116
       +
             in

     

       117
       117
       +
             diff_calc commits

     

       82
       118
        
       

     

       83
       119
        
       let with_latest ~default s f =

     

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

     

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

     

       85
       121
        
       

     

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

     

       87
       123
        
       

     
···

       97
       133
        
         let repo = S.repo session in

     

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

     

       99
       135
        
         let head = S.Head.find session in

     

       100
       100
       -
         List.assoc_opt head heads

     

       136
       136
       +
         let head_hash =

     

       137
       137
       +
           Option.map

     

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

     

       139
       139
       +
             head

     

       140
       140
       +
         in

     

       141
       141
       +
         (head_hash, List.assoc_opt head heads)

     

       101
       142
        
       

     

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

     

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

     
···

       124
       165
        
             Ok store

     

       125
       166
        
       

     

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

     

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

     

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

     

       129
       129
       -
         let content c =

     

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

     

       131
       131
       -
         in

     

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

     

       132
       169
        
         let pp_diff fmt d =

     

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

     

       134
       171
        
         in

     

       135
       172
        
         let pp_entry fmt (e : entry) =

     

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

     

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

     

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

     

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

     

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

     

       176
       176
       +
             pp_diff e.post.diff

     

       139
       177
        
         in

     

       140
       140
       -
         let linearize =

     

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

     

       142
       142
       -
         in

     

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

     

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

     

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

     

       144
       180
        
       

     

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

     

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

     

       182
       182
       +
         let head, sesh = which_branch store in

     

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

     

       147
       184
        
         let prompt () =

     

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

     

       149
       186
        
           Format.flush_str_formatter ()

     

       150
       187
        
         in

     

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

     

       188
       188
       +
         let pp_head fmt = function

     

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

     

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

     

       191
       191
       +
         in

     

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

     

       152
       193
        
         let pp_status fmt = function

     

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

     

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

     

       155
       196
        
           | _ -> Fmt.nop fmt ()

     

       156
       197
        
         in

     

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

     

       198
       198
       +
         let prompt_entry (e : entry) =

     

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

     

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

     

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

     

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

     

       161
       202
        
           Format.flush_str_formatter ()

     

       162
       203
        
         in

     

       163
       204
        
         with_latest store ~default:prompt prompt_entry

     

       164
       205
        
       

     

       165
       165
       -
       type ctx = Store.t

     

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

     

       207
       207
       +
       

     

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

     

       166
       209
        
       

     

       167
       210
        
       let init fs proc s =

     

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

     

       169
       212
        
         List.iter

     

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

     

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

     

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

     

       172
       172
       -
           (list s);

     

       173
       173
       -
         store

     

       215
       215
       +
           (history s);

     

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

     

       217
       217
       +
         let tools =

     

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

     

       219
       219
       +
           Eio.Fiber.List.iter

     

       220
       220
       +
             (fun (toolname, content) ->

     

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

     

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

     

       223
       223
       +
             tools;

     

       224
       224
       +
           tool_dir

     

       225
       225
       +
         in

     

       226
       226
       +
         { store; tool_dir = tools }

     

       227
       227
       +
       

     

       228
       228
       +
       (* Run a command:

     

       229
       229
       +
         

     

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

     

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

     

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

     

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

     

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

     

       235
       235
       +
           match entry.pre.build with

     

       236
       236
       +
           | Store.Build.Image img ->

     

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

     

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

     

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

     

       240
       240
       +
         in

     

       241
       241
       +
         let command = entry.pre.args in

     

       242
       242
       +
         let hash_entry =

     

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

     

       244
       244
       +
         in

     

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

     

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

     

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

     

       174
       248
        
       

     

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

     

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

     

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

     

       250
       250
       +
         let new_cid =

     

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

     

       252
       252
       +
         in

     

       253
       253
       +
         let with_rootfs fn =

     

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

     

       255
       255
       +
           else

     

       256
       256
       +
             let diff_path =

     

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

     

       258
       258
       +
             in

     

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

     

       260
       260
       +
         in

     

       261
       261
       +
         with_rootfs @@ function

     

       262
       262
       +
         | `Exists path ->

     

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

     

       264
       264
       +
             let () =

     

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

     

       266
       266
       +
               Eio.Flow.copy ic stdout

     

       267
       267
       +
             in

     

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

     

       269
       269
       +
             Ok (`Reset c)

     

       270
       270
       +
         | `Build rootfs ->

     

       271
       271
       +
             let spawn sw log =

     

       272
       272
       +
               if config.no_runc then

     

       273
       273
       +
                 (* Experiment Void Process *)

     

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

     

       275
       275
       +
                 let void =

     

       276
       276
       +
                   Void.empty

     

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

     

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

     

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

     

       280
       280
       +
                   |> Void.exec ~env

     

       281
       281
       +
                        [

     

       282
       282
       +
                          config.shell;

     

       283
       283
       +
                          "-c";

     

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

     

       285
       285
       +
                        ]

     

       286
       286
       +
                 in

     

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

     

       288
       288
       +
               else

     

       289
       289
       +
                 let tool_mount : Runc.Json_config.mount =

     

       290
       290
       +
                   {

     

       291
       291
       +
                     ty = `Bind;

     

       292
       292
       +
                     src = ctx.tool_dir;

     

       293
       293
       +
                     dst = "/shelter-tools";

     

       294
       294
       +
                     readonly = true;

     

       295
       295
       +
                   }

     

       296
       296
       +
                 in

     

       297
       297
       +
                 let config =

     

       298
       298
       +
                   Runc.Json_config.

     

       299
       299
       +
                     {

     

       300
       300
       +
                       cwd = entry.pre.cwd;

     

       301
       301
       +
                       argv =

     

       302
       302
       +
                         [

     

       303
       303
       +
                           config.shell;

     

       304
       304
       +
                           "-c";

     

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

     

       306
       306
       +
                         ];

     

       307
       307
       +
                       hostname = "builder";

     

       308
       308
       +
                       network = [ "host" ];

     

       309
       309
       +
                       user = (uid, gid);

     

       310
       310
       +
                       env = entry.pre.env;

     

       311
       311
       +
                       mounts = [ tool_mount ];

     

       312
       312
       +
                       entrypoint = None;

     

       313
       313
       +
                     }

     

       314
       314
       +
                 in

     

       315
       315
       +
                 let env =

     

       316
       316
       +
                   object

     

       317
       317
       +
                     method fs = fs

     

       318
       318
       +
                     method proc = proc

     

       319
       319
       +
                     method stdout = stdout

     

       320
       320
       +
                   end

     

       321
       321
       +
                 in

     

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

     

       323
       323
       +
             in

     

       324
       324
       +
             let start, res =

     

       325
       325
       +
               Switch.run @@ fun sw ->

     

       326
       326
       +
               let log =

     

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

     

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

     

       329
       329
       +
               in

     

       330
       330
       +
               let res = spawn sw log in

     

       331
       331
       +
               let start = Mtime_clock.now () in

     

       332
       332
       +
               match res with

     

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

     

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

     

       335
       335
       +
             in

     

       336
       336
       +
             let stop = Mtime_clock.now () in

     

       337
       337
       +
             let span = Mtime.span start stop in

     

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

     

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

     

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

     

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

     

       342
       342
       +
             in

     

       343
       343
       +
             if res = `Exited 0 then (

     

       344
       344
       +
               (* Extract env *)

     

       345
       345
       +
               let env_path =

     

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

     

       347
       347
       +
               in

     

       348
       348
       +
               let env =

     

       349
       349
       +
                 Eio.Path.(load env_path)

     

       350
       350
       +
                 |> String.split_on_char '\n'

     

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

     

       352
       352
       +
               in

     

       353
       353
       +
               Eio.Path.unlink env_path;

     

       354
       354
       +
               let cwd =

     

       355
       355
       +
                 List.find_map

     

       356
       356
       +
                   (fun v ->

     

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

     

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

     

       359
       359
       +
                     | _ -> None)

     

       360
       360
       +
                   env

     

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

     

       362
       362
       +
               in

     

       363
       363
       +
               if entry.pre.mode = RW then

     

       364
       364
       +
                 Ok

     

       365
       365
       +
                   (`Entry

     

       366
       366
       +
                      ( {

     

       367
       367
       +
                          hash_entry with

     

       368
       368
       +
                          History.pre =

     

       369
       369
       +
                            {

     

       370
       370
       +
                              hash_entry.pre with

     

       371
       371
       +
                              build = Build new_cid;

     

       372
       372
       +
                              env;

     

       373
       373
       +
                              cwd;

     

       374
       374
       +
                              user = (uid, gid);

     

       375
       375
       +
                            };

     

       376
       376
       +
                        },

     

       377
       377
       +
                        rootfs ))

     

       378
       378
       +
               else

     

       379
       379
       +
                 Ok

     

       380
       380
       +
                   (`Entry

     

       381
       381
       +
                      ( {

     

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

     

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

     

       384
       384
       +
                        },

     

       385
       385
       +
                        rootfs )))

     

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

     

       387
       387
       +
       

     

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

     

       389
       389
       +
           new_entry diff =

     

       390
       390
       +
         match new_entry with

     

       391
       391
       +
         | Error e -> Error e

     

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

     

       393
       393
       +
             match

     

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

     

       395
       395
       +
             with

     

       396
       396
       +
             | None ->

     

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

     

       398
       398
       +
                 Ok (s, ctx)

     

       399
       399
       +
             | Some c ->

     

       400
       400
       +
                 S.Head.set store c;

     

       401
       401
       +
                 Ok (s, ctx))

     

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

     

       403
       403
       +
             (* Set diff *)

     

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

     

       405
       405
       +
             (* Commit if RW *)

     

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

     

       407
       407
       +
               commit

     

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

     

       409
       409
       +
                 clock s entry;

     

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

     

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

     

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

     

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

     

       414
       414
       +
                 hash);

     

       415
       415
       +
             Ok (s, ctx)

     

       416
       416
       +
       

     

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

     

       418
       418
       +
           proc stdout existing_branch =

     

       419
       419
       +
         let seshes = sessions store in

     

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

     

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

     

       422
       422
       +
           Ok (store, ctx))

     

       423
       423
       +
         else

     

       424
       424
       +
           let repo = S.repo s in

     

       425
       425
       +
           let onto = S.of_branch repo existing_branch in

     

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

     

       427
       427
       +
           | Error lcas_error ->

     

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

     

       429
       429
       +
               Ok (store, ctx)

     

       430
       430
       +
           | Ok [ lcas ] -> (

     

       431
       431
       +
               let all_commits = history store in

     

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

     

       433
       433
       +
               let rec collect = function

     

       434
       434
       +
                 | [] -> []

     

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

     

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

     

       437
       437
       +
               in

     

       438
       438
       +
               let commits_to_apply = collect all_commits in

     

       439
       439
       +
               match commits_to_apply with

     

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

     

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

     

       442
       442
       +
                   let _, last_other =

     

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

     

       444
       444
       +
                   in

     

       445
       445
       +
                   let new_first =

     

       446
       446
       +
                     {

     

       447
       447
       +
                       first with

     

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

     

       449
       449
       +
                     }

     

       450
       450
       +
                   in

     

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

     

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

     

       453
       453
       +
                  and replay our commits onto it *)

     

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

     

       455
       455
       +
                   S.Head.set s other_head;

     

       456
       456
       +
                   let res =

     

       457
       457
       +
                     List.fold_left

     

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

     

       459
       459
       +
                         match last with

     

       460
       460
       +
                         | Error _ as e -> e

     

       461
       461
       +
                         | Ok (new_store, new_ctx) ->

     

       462
       462
       +
                             let new_entry, diff =

     

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

     

       464
       464
       +
                             in

     

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

     

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

     

       467
       467
       +
                       commits_to_apply

     

       468
       468
       +
                   in

     

       469
       469
       +
                   res)

     

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

     

       471
       471
       +
       

     

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

     

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

     

       177
       474
        
         | Set_mode mode ->

     

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

     

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

     

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

     

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

     

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

     

       180
       478
        
             Ok (s, ctx)

     

       181
       181
       -
         | Set_session m ->

     

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

     

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

     

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

     

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

     

       186
       186
       -
             Ok (new_full_store, ctx)

     

       479
       479
       +
         | Set_session m -> (

     

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

     

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

     

       482
       482
       +
             let sessions = sessions s in

     

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

     

       484
       484
       +
             | true ->

     

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

     

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

     

       487
       487
       +
             | false -> (

     

       488
       488
       +
                 match fork s m with

     

       489
       489
       +
                 | Error err ->

     

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

     

       491
       491
       +
                     Ok (s, ctx)

     

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

     

       187
       493
        
         | Unknown args ->

     

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

     

       189
       189
       -
               (String.concat " " args);

     

       190
       190
       -
             Ok (s, ctx)

     

       191
       191
       -
         | Info ->

     

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

     

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

     

       496
       496
       +
         | Info `Current ->

     

       192
       497
        
             let sessions = sessions s in

     

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

     

       194
       194
       -
             let history = S.history store in

     

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

     

       499
       499
       +
             let history = history s in

     

       195
       500
        
             let pp_commit fmt (hash, msg) =

     

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

     

       197
       502
        
             in

     

       503
       503
       +
             let repo = S.repo store in

     

       198
       504
        
             let commits =

     

       199
       199
       -
               S.History.fold_vertex

     

       200
       200
       -
                 (fun commit acc ->

     

       505
       505
       +
               List.fold_left

     

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

     

       507
       507
       +
                   let commit =

     

       508
       508
       +
                     S.Hash.unsafe_of_raw_string commit

     

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

     

       510
       510
       +
                   in

     

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

     

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

     

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

     

       204
       204
       -
                 history []

     

       514
       514
       +
                 [] history

     

       205
       515
        
             in

     

       206
       516
        
             let latest =

     

       207
       517
        
               with_latest

     

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

     

       209
       519
        
                 s

     

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

     

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

     

       211
       521
        
             in

     

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

     

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

     
···

       219
       529
        
             Ok (s, ctx)

     

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

     

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

     

       222
       222
       -
         | Fork new_branch -> (

     

       223
       223
       -
             match fork s new_branch with

     

       224
       224
       -
             | Error err ->

     

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

     

       226
       226
       -
                 Ok (s, ctx)

     

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

     

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

     

       229
       229
       -
         | History ->

     

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

     

       533
       533
       +
         | Info `History ->

     

       230
       534
        
             display_history s;

     

       231
       535
        
             Ok (s, ctx)

     

       232
       536
        
         | Exec command -> (

     
···

       235
       539
        
                 ~default:(fun () ->

     

       236
       540
        
                   History.

     

       237
       541
        
                     {

     

       238
       238
       -
                       mode = Void.RW;

     

       239
       239
       -
                       build = Store.Build.Image "alpine";

     

       240
       240
       -
                       args = command;

     

       241
       241
       -
                       time = 0L;

     

       242
       242
       -
                       diff = [];

     

       542
       542
       +
                       pre =

     

       543
       543
       +
                         {

     

       544
       544
       +
                           mode = Void.RW;

     

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

     

       546
       546
       +
                           args = command;

     

       547
       547
       +
                           (* TODO: extract with fetch *)

     

       548
       548
       +
                           env = [];

     

       549
       549
       +
                           cwd = "/";

     

       550
       550
       +
                           user = (0, 0);

     

       551
       551
       +
                         };

     

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

     

       243
       553
        
                     })

     

       244
       244
       -
                 s

     

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

     

       246
       246
       -
             in

     

       247
       247
       -
             let build =

     

       248
       248
       -
               match entry.build with

     

       249
       249
       -
               | Store.Build.Image img -> Store.fetch ctx img

     

       250
       250
       -
               | Store.Build.Build cid -> cid

     

       251
       251
       -
             in

     

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

     

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

     

       254
       254
       -
             let with_rootfs fn =

     

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

     

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

     

       554
       554
       +
                 s Fun.id

     

       257
       555
        
             in

     

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

     

       258
       557
        
             try

     

       259
       259
       -
               let new_entry, diff =

     

       260
       260
       -
                 with_rootfs @@ fun rootfs ->

     

       261
       261
       -
                 let void =

     

       262
       262
       -
                   Void.empty

     

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

     

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

     

       265
       265
       -
                 in

     

       266
       266
       -
                 Switch.run @@ fun sw ->

     

       267
       267
       -
                 let start = Mtime_clock.now () in

     

       268
       268
       -
                 let proc = Void.spawn ~sw void in

     

       269
       269
       -
                 let res =

     

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

     

       271
       271
       -
                 in

     

       272
       272
       -
                 let stop = Mtime_clock.now () in

     

       273
       273
       -
                 let span = Mtime.span start stop in

     

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

     

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

     

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

     

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

     

       278
       278
       -
                 in

     

       279
       279
       -
                 if res = `Exited 0 then

     

       280
       280
       -
                   if entry.mode = RW then

     

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

     

       282
       282
       -
                   else Ok hash_entry

     

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

     

       284
       284
       -
               in

     

       285
       285
       -
               match new_entry with

     

       286
       286
       -
               | Error e -> Error e

     

       287
       287
       -
               | Ok entry ->

     

       288
       288
       -
                   (* Set diff *)

     

       289
       289
       -
                   let entry = { entry with diff } in

     

       290
       290
       -
                   (* Commit if RW *)

     

       291
       291
       -
                   if entry.mode = RW then

     

       292
       292
       -
                     commit

     

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

     

       294
       294
       -
                       clock s entry;

     

       295
       295
       -
                   Ok (s, ctx)

     

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

     

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

     

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

     

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

+9 -3

src/lib/shelter/shelter_main.mli

···

       1
       1
        
       module Store = Store

     

       2
       2
        
       

     

       3
       3
        
       module History : sig

     

       4
       4
       -
         type t = {

     

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

     

       5
       5
       +
       

     

       6
       6
       +
         type pre = {

     

       5
       7
        
           mode : Void.mode;

     

       6
       8
        
           build : Store.Build.t;

     

       7
       9
        
           args : string list;

     

       8
       8
       -
           time : int64;

     

       9
       9
       -
           diff : Diff.t;

     

       10
       10
       +
           env : string list;

     

       11
       11
       +
           cwd : string;

     

       12
       12
       +
           user : int * int;

     

       10
       13
        
         }

     

       11
       14
        
         [@@deriving repr]

     

       15
       15
       +
         (** Needed for execution *)

     

       16
       16
       +
       

     

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

     

       12
       18
        
       

     

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

     

       14
       20
        
       end

+57 -25

src/lib/shelter/store.ml

···

       30
       30
        
         val builds : string -> dataset

     

       31
       31
        
         val build : string -> string -> dataset

     

       32
       32
        
         val snapshot : dataset -> snapshot

     

       33
       33
       +
         val tools : string -> dataset

     

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

     

       33
       35
        
       end = struct

     

       34
       36
        
         type dataset = string

     

       35
       37
        
         type snapshot = string

     
···

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

     

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

     

       40
       42
        
         let snapshot ds = ds ^ "@snappy"

     

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

     

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

     

       41
       45
        
       end

     

       42
       46
        
       

     

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

     
···

       78
       82
        
           }

     

       79
       83
        
         in

     

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

     

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

     

       81
       86
        
         t

     

       82
       87
        
       

     

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

     
···

       89
       94
        
         Zfs.clone src (tgt :> string)

     

       90
       95
        
       

     

       91
       96
        
       let read_all fd =

     

       92
       92
       -
         let buf = Buffer.create 128 in

     

       93
       93
       -
         let bytes = Bytes.create 4096 in

     

       97
       97
       +
         let buf = Buffer.create 10_000 in

     

       98
       98
       +
         let bytes = Bytes.create 10_000 in

     

       94
       99
        
         let rec loop () =

     

       95
       100
        
           match Unix.read fd bytes 0 4096 with

     

       96
       101
        
           | 0 | (exception End_of_file) -> Buffer.contents buf

     
···

       100
       105
        
         in

     

       101
       106
        
         loop ()

     

       102
       107
        
       

     

       103
       103
       -
       let diff t (data : Datasets.snapshot) (snap : Datasets.snapshot) =

     

       108
       108
       +
       let diff t (data : Datasets.snapshot) (snap : Datasets.snapshot) output =

     

       104
       109
        
         let data_fs =

     

       105
       110
        
           String.sub (data :> string) 0 (String.index (data :> string) '@')

     

       106
       111
        
         in

     

       107
       112
        
         let zh = Zfs.open_ t.zfs data_fs Zfs.Types.filesystem in

     

       108
       108
       -
         let diff =

     

       109
       109
       -
           let r, w = Unix.pipe ~cloexec:false () in

     

       113
       113
       +
         let () =

     

       110
       114
        
           try

     

       111
       111
       -
             Zfs.show_diff zh ~from_:(data :> string) ~to_:(snap :> string) w;

     

       112
       112
       -
             let f = read_all r in

     

       113
       113
       -
             Unix.close r;

     

       114
       114
       -
             f

     

       115
       115
       -
           with e ->

     

       116
       116
       -
             Unix.close r;

     

       117
       117
       -
             raise e

     

       115
       115
       +
             Eio.Path.with_open_out ~create:(`If_missing 0o644) output

     

       116
       116
       +
             @@ fun flow_fd ->

     

       117
       117
       +
             let eio_fd = Eio_unix.Resource.fd_opt flow_fd in

     

       118
       118
       +
             Eio_unix.Fd.use_exn_opt "zfs-diff" eio_fd @@ function

     

       119
       119
       +
             | None -> Fmt.failwith "Output needs to have an FD"

     

       120
       120
       +
             | Some fd ->

     

       121
       121
       +
                 Zfs.show_diff zh ~from_:(data :> string) ~to_:(snap :> string) fd

     

       122
       122
       +
           with Unix.Unix_error (Unix.EBADF, _, _) -> ()

     

       118
       123
        
         in

     

       119
       124
        
         Zfs.close zh;

     

       125
       125
       +
         let diff = Eio.Path.load output in

     

       120
       126
        
         Diff.of_zfs diff

     

       121
       127
        
       

     

       122
       128
        
       let cid s =

     
···

       126
       132
        
         in

     

       127
       133
        
         Cid.v ~version:`Cidv1 ~base:`Base32 ~codec:`Raw ~hash

     

       128
       134
        
       

     

       135
       135
       +
       let not_empty s = not String.(equal empty s)

     

       136
       136
       +
       

     

       137
       137
       +
       let get_uid_gid ~username rootfs =

     

       138
       138
       +
         let passwd =

     

       139
       139
       +
           Eio.Path.load Eio.Path.(rootfs / "etc" / "passwd")

     

       140
       140
       +
           |> String.split_on_char '\n'

     

       141
       141
       +
           |> List.map (String.split_on_char ':')

     

       142
       142
       +
           |> List.map (List.filter not_empty)

     

       143
       143
       +
         in

     

       144
       144
       +
         List.find_map

     

       145
       145
       +
           (function

     

       146
       146
       +
             | user :: _ :: uid :: gid :: _ when String.equal user username ->

     

       147
       147
       +
                 Some (int_of_string uid, int_of_string gid)

     

       148
       148
       +
             | _ -> None)

     

       149
       149
       +
           passwd

     

       150
       150
       +
       

     

       129
       151
        
       let fetch t image =

     

       130
       152
        
         let cid = cid image in

     

       131
       153
        
         let cids = cid |> Cid.to_string in

     

       132
       154
        
         let dataset = Datasets.build t.pool cids in

     

       133
       155
        
         let dir = Eio.Path.(t.fs / ("/" ^ (Datasets.build t.pool cids :> string))) in

     

       134
       134
       -
         if Zfs.exists t.zfs (dataset :> string) Zfs.Types.filesystem then cid

     

       135
       135
       -
         else (

     

       136
       136
       -
           create_and_mount t dataset;

     

       137
       137
       -
           let _dir : string = Fetch.get_image ~dir ~proc:t.proc image in

     

       138
       138
       -
           snapshot t (Datasets.snapshot dataset);

     

       139
       139
       -
           cid)

     

       156
       156
       +
         create_and_mount t dataset;

     

       157
       157
       +
         let _dir : string = Fetch.get_image ~dir ~proc:t.proc image in

     

       158
       158
       +
         snapshot t (Datasets.snapshot dataset);

     

       159
       159
       +
         let username = Fetch.get_user t.proc image in

     

       160
       160
       +
         ( cid,

     

       161
       161
       +
           Fetch.get_env t.proc image,

     

       162
       162
       +
           get_uid_gid ~username Eio.Path.(dir / "rootfs") )

     

       140
       163
        
       

     

       141
       164
        
       module Run = struct

     

       142
       165
        
         let with_build t cid fn =

     

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

     

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

     

       145
       168
        
           mount_dataset t ds;

     

       146
       146
       -
           fn ("/" ^ (ds :> string) ^ "/rootfs")

     

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

     

       170
       170
       +
       

     

       171
       171
       +
         let with_tool t cid fn =

     

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

     

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

     

       174
       174
       +
           mount_dataset t ds;

     

       175
       175
       +
           fn ("/" ^ (ds :> string))

     

       147
       176
        
       

     

       148
       148
       -
         let with_clone t ~src new_cid fn =

     

       177
       177
       +
         let with_clone t ~src new_cid output fn =

     

       149
       178
        
           let ds = Datasets.build t.pool (Cid.to_string src) in

     

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

     

       151
       180
        
           let src_snap = Datasets.snapshot ds in

     

       152
       181
        
           let tgt_snap = Datasets.snapshot tgt in

     

       153
       153
       -
           clone t src_snap tgt;

     

       154
       154
       -
           let v = with_build t new_cid fn in

     

       155
       155
       -
           snapshot t tgt_snap;

     

       156
       156
       -
           let d = diff t src_snap tgt_snap in

     

       157
       157
       -
           (v, d)

     

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

     

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

     

       184
       184
       +
           else (

     

       185
       185
       +
             clone t src_snap tgt;

     

       186
       186
       +
             let v = with_build t new_cid fn in

     

       187
       187
       +
             snapshot t tgt_snap;

     

       188
       188
       +
             let d = diff t src_snap tgt_snap output in

     

       189
       189
       +
             (v, d))

     

       158
       190
        
       end

src/lib/shelter/tools.ml

···

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

+24 -14

src/lib/shelter.ml

···

       2
       2
        
       module Engine = Engine

     

       3
       3
        
       module Script = Script

     

       4
       4
        
       

     

       5
       5
       +
       let process_error e = Error (`Process e)

     

       6
       6
       +
       let shell_error e = Error (`Shell e)

     

       7
       7
       +
       

     

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

     

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

     

       9
       9
       +
         module Store = Irmin_git_unix.FS.KV (H)

     

       7
       10
        
       

     

       8
       8
       -
         let run config fs clock proc store =

     

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

     

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

     

       10
       13
        
           let initial_ctx = Engine.init fs proc store in

     

       11
       14
        
           let rec loop store ctx exit_code =

     
···

       14
       17
        
             | None -> ()

     

       15
       18
        
             | Some input -> (

     

       16
       19
        
                 let action = Engine.action_of_command input in

     

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

     

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

     

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

     

       21
       21
       +
                 | Error (`Process (Eio.Process.Child_error exit_code)) ->

     

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

     

       20
       23
        
                     loop store ctx exit_code

     

       21
       21
       -
                 | Error (Eio.Process.Executable_not_found m) ->

     

       22
       22
       -
                     Fmt.epr "cshell: excutable not found %s\n%!" m;

     

       24
       24
       +
                 | Error (`Process (Eio.Process.Executable_not_found m)) ->

     

       25
       25
       +
                     Fmt.epr "shelter: excutable not found %s\n%!" m;

     

       23
       26
        
                     loop store ctx (`Exited 127)

     

       27
       27
       +
                 | Error (`Shell e) ->

     

       28
       28
       +
                     Fmt.epr "shelter: %a\n%!" Engine.pp_error e;

     

       29
       29
       +
                     loop store ctx (`Exited 255)

     

       24
       30
        
                 | Ok (store, ctx) -> loop store ctx (`Exited 0))

     

       25
       31
        
           in

     

       26
       32
        
           loop store initial_ctx (`Exited 0)

     
···

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

     

       30
       36
        
           |> List.map Engine.action_of_command

     

       31
       37
        
       

     

       32
       32
       -
         let main config fs clock proc directory command_file =

     

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

     

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

     

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

     

       39
       39
       +
           let conf = Irmin_git.config (Eio.Path.native_exn directory) in

     

       35
       40
        
           let repo = Store.Repo.v conf in

     

       36
       41
        
           let store = Store.main repo in

     

       37
       42
        
           match command_file with

     
···

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

     

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

     

       44
       49
        
                 else

     

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

     

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

     

       50
       50
       +
                   match

     

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

     

       52
       52
       +
                   with

     

       53
       53
       +
                   | Error (`Process (Eio.Process.Child_error exit_code)) ->

     

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

     

       48
       55
        
                       (store, ctx, exit_code)

     

       49
       49
       -
                   | Error (Eio.Process.Executable_not_found m) ->

     

       50
       50
       -
                       Fmt.epr "cshell: excutable not found %s\n%!" m;

     

       56
       56
       +
                   | Error (`Process (Eio.Process.Executable_not_found m)) ->

     

       57
       57
       +
                       Fmt.epr "shelter: excutable not found %s\n%!" m;

     

       51
       58
        
                       (store, ctx, `Exited 127)

     

       59
       59
       +
                   | Error (`Shell e) ->

     

       60
       60
       +
                       Fmt.epr "shelter: %a\n%!" Engine.pp_error e;

     

       61
       61
       +
                       (store, ctx, `Exited 255)

     

       52
       62
        
                   | Ok (store, ctx) -> (store, ctx, `Exited 0)

     

       53
       63
        
               in

     

       54
       64
        
               let _store, _ctx, exit_code =

     
···

       59
       69
        
               | `Exited n | `Signaled n ->

     

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

     

       61
       71
        
                   exit n)

     

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

     

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

     

       63
       73
        
       end

+24 -4

vendor/void/src/void.ml

···

       9
       9
        
       

     

       10
       10
        
       type void = {

     

       11
       11
        
         args : string list;

     

       12
       12
       +
         env : string list;

     

       13
       13
       +
         cwd : string;

     

       14
       14
       +
         uid : int;

     

       15
       15
       +
         (* TODO: gid *)

     

       12
       16
        
         rootfs : (string * mode) option;

     

       13
       17
        
         mounts : mount list;

     

       14
       18
        
       }

     
···

       58
       62
        
                      (action_pivot_root, new_root, new_root_flags, tmpfs, mounts)));

     

       59
       63
        
           }

     

       60
       64
        
       

     

       65
       65
       +
       external action_setuid : unit -> Fork_action.fork_fn

     

       66
       66
       +
         = "void_fork_setuid"

     

       67
       67
       +
       

     

       68
       68
       +
       let action_setuid = action_setuid ()

     

       69
       69
       +
       

     

       70
       70
       +
       let setuid (uid : int) =  Fork_action.

     

       71
       71
       +
           {

     

       72
       72
       +
             run =

     

       73
       73
       +
               (fun k ->

     

       74
       74
       +
                 k

     

       75
       75
       +
                   (Obj.repr

     

       76
       76
       +
                      (action_setuid, uid)));

     

       77
       77
       +
           }

     

       78
       78
       +
       

     

       61
       79
        
       external action_map_uid_gid : unit -> Fork_action.fork_fn

     

       62
       80
        
         = "void_fork_map_uid_gid"

     

       63
       81
        
       

     
···

       98
       116
        
       

     

       99
       117
        
       type path = string

     

       100
       118
        
       

     

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

     

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

     

       102
       120
        
       

     

       103
       121
        
       let actions v : Fork_action.t list =

     

       104
       122
        
         let root, tmpfs, root_mode =

     
···

       108
       126
        
         in

     

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

     

       110
       128
        
         let e =

     

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

     

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

     

       112
       130
        
             ~argv:(Array.of_list args)

     

       113
       131
        
         in

     

       114
       132
        
         (* Process mount point points *)

     
···

       126
       144
        
         let mounts = pivot_root root root_flags tmpfs mounts in

     

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

     

       128
       146
        
         let user_namespace = map_uid_gid ~uid ~gid in

     

       129
       129
       -
         [ user_namespace; mounts; e ]

     

       147
       147
       +
         [ user_namespace; mounts; setuid v.uid; Process.Fork_action.chdir v.cwd; e ]

     

       130
       148
        
       

     

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

     

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

     

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

     

       151
       151
       +
       let uid uid v = { v with uid }

     

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

     

       133
       153
        
       

     

       134
       154
        
       let mount ~mode ~src ~tgt v =

     

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

+8 -1

vendor/void/src/void.mli

···

       47
       47
        
       

     

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

     

       49
       49
        
       

     

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

     

       50
       50
       +
       

     

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

     

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

     

       53
       53
       +
       

     

       54
       54
       +
       val uid : int -> void -> void

     

       55
       55
       +
       (** Set the UID *)

     

       56
       56
       +
       

     

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

     

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

     

       52
       59
        
       

     

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

+25 -4

vendor/void/src/void_action.c

···

       20
       20
        
       #include <string.h>

     

       21
       21
        
       

     

       22
       22
        
       

     

       23
       23
       +
       #define CAML_INTERNALS

     

       23
       24
        
       #include <caml/mlvalues.h>

     

       24
       25
        
       #include <caml/unixsupport.h>

     

       25
       26
        
       #include <caml/memory.h>

     

       26
       27
        
       #include <caml/custom.h>

     

       28
       28
       +
       #include <caml/signals.h>

     

       27
       29
        
       #include <caml/fail.h>

     

       30
       30
       +
       #undef CAML_INTERNALS

     

       28
       31
        
       

     

       29
       32
        
       // From Eio

     

       30
       33
        
       #include <include/fork_action.h>

     
···

       228
       231
        
         return Val_fork_fn (action_map_uid_gid);

     

       229
       232
        
       }

     

       230
       233
        
       

     

       234
       234
       +
       static void

     

       235
       235
       +
       action_setuid (int errors, value v_config)

     

       236
       236
       +
       {

     

       237
       237
       +
         value v_uid = Field(v_config, 1);

     

       238
       238
       +
       

     

       239
       239
       +
         // if (setuid(1000)) {

     

       240
       240
       +
         //     eio_unix_fork_error (errors, "setuid", strerror (errno));

     

       241
       241
       +
         //     _exit (1);

     

       242
       242
       +
         // }

     

       243
       243
       +
       }

     

       244
       244
       +
       

     

       245
       245
       +
       // SETUID

     

       246
       246
       +
       CAMLprim value

     

       247
       247
       +
       void_fork_setuid (value v_unit)

     

       248
       248
       +
       {

     

       249
       249
       +
         return Val_fork_fn (action_setuid);

     

       250
       250
       +
       }

     

       251
       251
       +
       

     

       231
       252
        
       // PIVOT ROOT

     

       232
       253
        
       //

     

       233
       254
        
       static int

     
···

       267
       288
        
             //}

     

       268
       289
        
       

     

       269
       290
        
             if (mount ("tmpfs", new_root, "tmpfs", 0, NULL) <= -1)

     

       270
       270
       -
       	{

     

       271
       271
       -
       	  eio_unix_fork_error (errors, "pivot_root-tmpfs", strerror (errno));

     

       272
       272
       -
       	  _exit (1);

     

       273
       273
       -
       	}

     

       291
       291
       +
       		{

     

       292
       292
       +
       		  eio_unix_fork_error (errors, "pivot_root-tmpfs", strerror (errno));

     

       293
       293
       +
       		  _exit (1);

     

       294
       294
       +
       		}

     

       274
       295
        
           }

     

       275
       296
        
         else

     

       276
       297
        
           {

-1

vendor/zfs/src/zfs.ml

···

       137
       137
        
         (* TODO: Other Diff Flags https://github.com/openzfs/zfs/blob/5b0c27cd14bbc07d50304c97735cc105d0258673/include/libzfs.h#L917? *)

     

       138
       138
        
         let res = C.Functions.diff handle (Obj.magic fd : int) from_ to_ 1 in

     

       139
       139
        
         if res = 0 then () else begin

     

       140
       140
       -
           Format.printf "Diff got %i\n%!" res;

     

       141
       140
        
           invalid_arg "show_diff"

     

       142
       141
        
         end

Compare changes