comparing 04da6d3d2f92032d30985c992f9afc48dfa9faa6 and main on patrick.sirref.org/shelter

.gitignore

···

       3
       3
        
       *.sjson

     

       4
       4
        
       *.json

     

       5
       5
        
       *.shl

     

       6
       6
       +
       

     

       7
       7
       +
       docs/trees

     

       8
       8
       +
       docs/output

-2

shelter.opam

···

       39
       39
        
       ]

     

       40
       40
        
       dev-repo: "git+https://github.com/username/reponame.git"

     

       41
       41
        
       pin-depends:[

     

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

     

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

     

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

     

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

     

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

-2

shelter.opam.template

···

       1
       1
        
       pin-depends:[

     

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

     

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

     

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

     

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

     

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

-5

src/bin/dune

···

       1
       1
       -
       (executable

     

       2
       2
       -
        (public_name shelter)

     

       3
       3
       -
        (package shelter)

     

       4
       4
       -
        (name main)

     

       5
       5
       -
        (libraries shelter fmt.tty shelter.main shelter.passthrough eio void))

-83

src/bin/main.ml

···

       1
       1
       -
       module History = struct

     

       2
       2
       -
         type t = string

     

       3
       3
       -
       

     

       4
       4
       -
         let t = Repr.string

     

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

     

       6
       6
       -
       end

     

       7
       7
       -
       

     

       8
       8
       -
       module Pass = Shelter.Make (History) (Shelter_passthrough)

     

       9
       9
       -
       module Main = Shelter.Make (Shelter_main.History) (Shelter_main)

     

       10
       10
       -
       

     

       11
       11
       -
       let home = Unix.getenv "HOME"

     

       12
       12
       -
       

     

       13
       13
       -
       let state_dir fs type' =

     

       14
       14
       -
         let path = Eio.Path.(fs / home / ".cache/shelter" / type') in

     

       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
       -
       

     

       24
       24
       -
       (* Command Line *)

     

       25
       25
       -
       open Cmdliner

     

       26
       26
       -
       

     

       27
       27
       -
       let cmd_file =

     

       28
       28
       -
         let doc = "Path to a file containing a series of commands." in

     

       29
       29
       -
         Arg.(

     

       30
       30
       -
           value

     

       31
       31
       -
           & opt (some file) None

     

       32
       32
       -
           & info [ "f"; "file" ] ~docv:"COMMAND_FILE" ~doc)

     

       33
       33
       -
       

     

       34
       34
       -
       let main =

     

       35
       35
       -
         let run config cmd_file =

     

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

     

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

     

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

     

       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

     

       41
       41
       -
         in

     

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

     

       43
       43
       -
         let man =

     

       44
       44
       -
           [

     

       45
       45
       -
             `P

     

       46
       46
       -
               "Shelter is a shell session shim to help control uncertainty when \

     

       47
       47
       -
                working from the terminal";

     

       48
       48
       -
           ]

     

       49
       49
       -
         in

     

       50
       50
       -
         let doc = "Shelter: version-controlled shell sessions" in

     

       51
       51
       -
         let info = Cmd.info ~man ~doc "main" in

     

       52
       52
       -
         (Cmd.v info t, t, info)

     

       53
       53
       -
       

     

       54
       54
       -
       let passthrough =

     

       55
       55
       -
         let run config cmd_file =

     

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

     

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

     

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

     

       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

     

       61
       61
       -
         in

     

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

     

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

     

       64
       64
       -
         Cmd.v info t

     

       65
       65
       -
       

     

       66
       66
       -
       let extract_commands =

     

       67
       67
       -
         let run cmd_file =

     

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

     

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

     

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

     

       71
       71
       -
         in

     

       72
       72
       -
         let t = Term.(const run $ cmd_file) in

     

       73
       73
       -
         let info = Cmd.info "extract" in

     

       74
       74
       -
         Cmd.v info t

     

       75
       75
       -
       

     

       76
       76
       -
       let cmds =

     

       77
       77
       -
         let cmd, term, info = main in

     

       78
       78
       -
         let cmds = [ cmd; passthrough; extract_commands ] in

     

       79
       79
       -
         Cmd.group ~default:term info cmds

     

       80
       80
       -
       

     

       81
       81
       -
       let () =

     

       82
       82
       -
         Fmt_tty.setup_std_outputs ();

     

       83
       83
       -
         exit (Cmd.eval cmds)

+44

src/common/admin.ml

···

       1
       1
       +
       open Capnp_rpc

     

       2
       2
       +
       

     

       3
       3
       +
       let v sr ~add_user ~remove_user =

     

       4
       4
       +
         let module X = Raw.Service.Admin in

     

       5
       5
       +
         Capnp_rpc.Persistence.with_sturdy_ref sr X.local

     

       6
       6
       +
         @@ object

     

       7
       7
       +
              inherit X.service

     

       8
       8
       +
       

     

       9
       9
       +
              method add_user_impl params release_param_caps =

     

       10
       10
       +
                let open X.AddUser in

     

       11
       11
       +
                let id = Params.user_get params in

     

       12
       12
       +
                release_param_caps ();

     

       13
       13
       +
                let cap = add_user id in

     

       14
       14
       +
                let response, results = Service.Response.create Results.init_pointer in

     

       15
       15
       +
                Results.cap_set results (Some cap);

     

       16
       16
       +
                Capability.dec_ref cap;

     

       17
       17
       +
                Service.return response

     

       18
       18
       +
       

     

       19
       19
       +
              method remove_user_impl params release_param_caps =

     

       20
       20
       +
                let open X.RemoveUser in

     

       21
       21
       +
                let id = Params.user_get params in

     

       22
       22
       +
                release_param_caps ();

     

       23
       23
       +
                remove_user id;

     

       24
       24
       +
                Service.return @@ Service.Response.create_empty ()

     

       25
       25
       +
            end

     

       26
       26
       +
       

     

       27
       27
       +
       module X = Raw.Client.Admin

     

       28
       28
       +
       

     

       29
       29
       +
       type t = X.t Capability.t

     

       30
       30
       +
       

     

       31
       31
       +
       let add_user t user =

     

       32
       32
       +
         let open X.AddUser in

     

       33
       33
       +
         let request, params = Capability.Request.create Params.init_pointer in

     

       34
       34
       +
         Params.user_set params user;

     

       35
       35
       +
         Capability.call_for_caps t method_id request Results.cap_get_pipelined

     

       36
       36
       +
       

     

       37
       37
       +
       let remove_user t user =

     

       38
       38
       +
         let open X.RemoveUser in

     

       39
       39
       +
         let request, params = Capability.Request.create Params.init_pointer in

     

       40
       40
       +
         Params.user_set params user;

     

       41
       41
       +
         let _ : _ StructStorage.reader_t =

     

       42
       42
       +
           Capability.call_for_value_exn t method_id request

     

       43
       43
       +
         in

     

       44
       44
       +
         ()

src/common/config.ml

···

       1
       1
       +
       type t = { shell : string; default_image : string } [@@deriving yojson]

+13

src/common/dune

···

       1
       1
       +
       (rule

     

       2
       2
       +
        (targets schema.ml schema.mli)

     

       3
       3
       +
        (deps schema.capnp)

     

       4
       4
       +
        (action

     

       5
       5
       +
         (run capnpc -o %{bin:capnpc-ocaml} %{deps})))

     

       6
       6
       +
       

     

       7
       7
       +
       (library

     

       8
       8
       +
        (name shelter_common)

     

       9
       9
       +
        (preprocess

     

       10
       10
       +
         (pps ppx_deriving_yojson))

     

       11
       11
       +
        (flags

     

       12
       12
       +
         (:standard -w -53-55))

     

       13
       13
       +
        (libraries capnp-rpc-net))

src/common/raw.ml

···

       1
       1
       +
       include Schema.MakeRPC (Capnp_rpc)

+22

src/common/schema.capnp

···

       1
       1
       +
       @0x91b3108e7ebb3830;

     

       2
       2
       +
       interface Session {

     

       3
       3
       +
         stdin  @0 (input :Text) -> ();

     

       4
       4
       +
         stdout @1 () -> (output :Text);

     

       5
       5
       +
         stderr @2 () -> (output :Text);

     

       6
       6
       +
       }

     

       7
       7
       +
       

     

       8
       8
       +
       interface User {

     

       9
       9
       +
         connect @0 (config :Text) -> (cap :Session);

     

       10
       10
       +
         # Connect to the daemon and get a live session.

     

       11
       11
       +
       }

     

       12
       12
       +
       

     

       13
       13
       +
       

     

       14
       14
       +
       interface Admin {

     

       15
       15
       +
         addUser @0 (user :Text) -> (cap :User);

     

       16
       16
       +
         # Add a new user, returning a capability to act as a full

     

       17
       17
       +
         # Shelter user.

     

       18
       18
       +
       

     

       19
       19
       +
         removeUser @1 (user :Text) -> ();

     

       20
       20
       +
         # Remove a user, this will also cancel existing connections

     

       21
       21
       +
         # this user may have to the daemon.

     

       22
       22
       +
       }

+57

src/common/session.ml

···

       1
       1
       +
       open Capnp_rpc

     

       2
       2
       +
       

     

       3
       3
       +
       let or_fail = function

     

       4
       4
       +
         | Ok v -> v

     

       5
       5
       +
         | Error (`Capnp e) -> Fmt.failwith "%a" Capnp_rpc.Error.pp e

     

       6
       6
       +
       

     

       7
       7
       +
       let local ~stdin ~stdout ~stderr =

     

       8
       8
       +
         let module X = Raw.Service.Session in

     

       9
       9
       +
         X.local

     

       10
       10
       +
         @@ object

     

       11
       11
       +
              inherit X.service

     

       12
       12
       +
       

     

       13
       13
       +
              method stdout_impl _ release_param_caps =

     

       14
       14
       +
                let open X.Stdout in

     

       15
       15
       +
                release_param_caps ();

     

       16
       16
       +
                let s = stdout () in

     

       17
       17
       +
                let response, results = Service.Response.create Results.init_pointer in

     

       18
       18
       +
                Results.output_set results s;

     

       19
       19
       +
                Service.return response

     

       20
       20
       +
       

     

       21
       21
       +
              method stderr_impl _ release_param_caps =

     

       22
       22
       +
                let open X.Stderr in

     

       23
       23
       +
                release_param_caps ();

     

       24
       24
       +
                let s = stderr () in

     

       25
       25
       +
                let response, results = Service.Response.create Results.init_pointer in

     

       26
       26
       +
                Results.output_set results s;

     

       27
       27
       +
                Service.return response

     

       28
       28
       +
       

     

       29
       29
       +
              method stdin_impl params release_param_caps =

     

       30
       30
       +
                let open X.Stdin in

     

       31
       31
       +
                let data = Params.input_get params in

     

       32
       32
       +
                release_param_caps ();

     

       33
       33
       +
                stdin data;

     

       34
       34
       +
                Service.return_empty ()

     

       35
       35
       +
            end

     

       36
       36
       +
       

     

       37
       37
       +
       module X = Raw.Client.Session

     

       38
       38
       +
       

     

       39
       39
       +
       type t = X.t Capability.t

     

       40
       40
       +
       

     

       41
       41
       +
       let stdout t () =

     

       42
       42
       +
         let open X.Stdout in

     

       43
       43
       +
         let request = Capability.Request.create_no_args () in

     

       44
       44
       +
         let result = Capability.call_for_value t method_id request |> or_fail in

     

       45
       45
       +
         Results.output_get result

     

       46
       46
       +
       

     

       47
       47
       +
       let stderr t () =

     

       48
       48
       +
         let open X.Stderr in

     

       49
       49
       +
         let request = Capability.Request.create_no_args () in

     

       50
       50
       +
         let result = Capability.call_for_value t method_id request |> or_fail in

     

       51
       51
       +
         Results.output_get result

     

       52
       52
       +
       

     

       53
       53
       +
       let stdin t input =

     

       54
       54
       +
         let open X.Stdin in

     

       55
       55
       +
         let request, params = Capability.Request.create Params.init_pointer in

     

       56
       56
       +
         Params.input_set params input;

     

       57
       57
       +
         Capability.call_for_unit t method_id request |> or_fail

src/common/shelter_common.ml

···

       1
       1
       +
       let or_fail = function Ok v -> v | Error (`Msg m) -> failwith m

     

       2
       2
       +
       

     

       3
       3
       +
       module Raw = Raw

     

       4
       4
       +
       module Admin = Admin

     

       5
       5
       +
       module User = User

     

       6
       6
       +
       module Session = Session

+31

src/common/user.ml

···

       1
       1
       +
       open Capnp_rpc

     

       2
       2
       +
       

     

       3
       3
       +
       let v sr connect =

     

       4
       4
       +
         let module X = Raw.Service.User in

     

       5
       5
       +
         Capnp_rpc.Persistence.with_sturdy_ref sr X.local

     

       6
       6
       +
         @@ object

     

       7
       7
       +
              inherit X.service

     

       8
       8
       +
       

     

       9
       9
       +
              method connect_impl params release_param_caps =

     

       10
       10
       +
                let open X.Connect in

     

       11
       11
       +
                let config =

     

       12
       12
       +
                  Params.config_get params |> Yojson.Safe.from_string

     

       13
       13
       +
                  |> Config.of_yojson |> Result.get_ok

     

       14
       14
       +
                in

     

       15
       15
       +
                release_param_caps ();

     

       16
       16
       +
                let cap = connect config in

     

       17
       17
       +
                let response, results = Service.Response.create Results.init_pointer in

     

       18
       18
       +
                Results.cap_set results (Some cap);

     

       19
       19
       +
                Capability.dec_ref cap;

     

       20
       20
       +
                Service.return response

     

       21
       21
       +
            end

     

       22
       22
       +
       

     

       23
       23
       +
       module X = Raw.Client.User

     

       24
       24
       +
       

     

       25
       25
       +
       type t = X.t Capability.t

     

       26
       26
       +
       

     

       27
       27
       +
       let connect t config =

     

       28
       28
       +
         let open X.Connect in

     

       29
       29
       +
         let request, params = Capability.Request.create Params.init_pointer in

     

       30
       30
       +
         Params.config_set params (Config.to_yojson config |> Yojson.Safe.to_string);

     

       31
       31
       +
         Capability.call_for_caps t method_id request Results.cap_get_pipelined

-4

src/lib/dune

···

       1
       1
       -
       (library

     

       2
       2
       -
        (name shelter)

     

       3
       3
       -
        (public_name shelter)

     

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

-50

src/lib/engine.ml

···

       1
       1
       -
       module type S = sig

     

       2
       2
       -
         type config

     

       3
       3
       -
         (** A configuration *)

     

       4
       4
       -
       

     

       5
       5
       -
         val config_term : config Cmdliner.Term.t

     

       6
       6
       -
         (** A cmdliner term for constructing a config *)

     

       7
       7
       -
       

     

       8
       8
       -
         type action

     

       9
       9
       -
         (** An action to run *)

     

       10
       10
       -
       

     

       11
       11
       -
         val action : action Repr.t

     

       12
       12
       -
         val action_of_command : string -> action

     

       13
       13
       -
       

     

       14
       14
       -
         type entry

     

       15
       15
       -
       

     

       16
       16
       -
         type ctx

     

       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
       -
       

     

       25
       25
       -
         val init :

     

       26
       26
       -
           _ Eio.Path.t ->

     

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

     

       28
       28
       -
           entry History.t ->

     

       29
       29
       -
           ctx

     

       30
       30
       -
         (** [init store] will be called before entering the shell loop. You may wish

     

       31
       31
       -
             to setup history completions etc. with LNoise. *)

     

       32
       32
       -
       

     

       33
       33
       -
         val run :

     

       34
       34
       -
           config ->

     

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

     

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

     

       37
       37
       -
           _ Eio.Time.clock ->

     

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

     

       39
       39
       -
           entry History.t * ctx ->

     

       40
       40
       -
           action ->

     

       41
       41
       -
           ( entry History.t * ctx,

     

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

     

       43
       43
       -
           result

     

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

     

       45
       45
       -
             that can be persisted *)

     

       46
       46
       -
       

     

       47
       47
       -
         val prompt : Eio.Process.exit_status -> entry History.t -> string

     

       48
       48
       -
         (** [prompt previous_exit_code history] generates a prompt from the current

     

       49
       49
       -
             [history] *)

     

       50
       50
       -
       end

-17

src/lib/history.ml

···

       1
       1
       -
       module type S = sig

     

       2
       2
       -
         type t

     

       3
       3
       -
         (** A single history entry *)

     

       4
       4
       -
       

     

       5
       5
       -
         include Irmin.Contents.S with type t := t

     

       6
       6
       -
       end

     

       7
       7
       -
       

     

       8
       8
       -
       type 'entry t =

     

       9
       9
       -
         | Store :

     

       10
       10
       -
             ((module Irmin.S

     

       11
       11
       -
                 with type t = 'a

     

       12
       12
       -
                  and type Schema.Branch.t = string

     

       13
       13
       -
                  and type Schema.Contents.t = 'entry

     

       14
       14
       -
                  and type Schema.Path.t = string list

     

       15
       15
       -
                  and type Schema.Path.step = string)

     

       16
       16
       -
             * 'a)

     

       17
       17
       -
             -> 'entry t

-6

src/lib/passthrough/dune

···

       1
       1
       -
       (library

     

       2
       2
       -
        (name shelter_passthrough)

     

       3
       3
       -
        (public_name shelter.passthrough)

     

       4
       4
       -
        (preprocess

     

       5
       5
       -
         (pps ppx_repr))

     

       6
       6
       -
        (libraries shelter))

-64

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
       -
       

     

       7
       7
       -
       type config = unit

     

       8
       8
       -
       

     

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

     

       10
       10
       -
       

     

       11
       11
       -
       type action = Exec of string [@@deriving repr]

     

       12
       12
       -
       

     

       13
       13
       -
       let action = action_t

     

       14
       14
       -
       let action_of_command cmd = Exec cmd

     

       15
       15
       -
       

     

       16
       16
       -
       type entry = string [@@derviving repr]

     

       17
       17
       -
       

     

       18
       18
       -
       let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty

     

       19
       19
       -
       

     

       20
       20
       -
       let prompt _ _ =

     

       21
       21
       -
         Fmt.(styled (`Fg `Red) string) Format.str_formatter "shelter-p> ";

     

       22
       22
       -
         Format.flush_str_formatter ()

     

       23
       23
       -
       

     

       24
       24
       -
       let history_key = [ "history" ]

     

       25
       25
       -
       let key () = history_key @ [ string_of_float @@ Unix.gettimeofday () ]

     

       26
       26
       -
       

     

       27
       27
       -
       type ctx = unit

     

       28
       28
       -
       

     

       29
       29
       -
       let init _ _

     

       30
       30
       -
           (Shelter.History.Store ((module S), store) : entry Shelter.History.t) =

     

       31
       31
       -
         match S.list store history_key with

     

       32
       32
       -
         | [] -> ()

     

       33
       33
       -
         | xs ->

     

       34
       34
       -
             let rec loop acc = function

     

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

     

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

     

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

     

       38
       38
       -
             in

     

       39
       39
       -
             let entries =

     

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

     

       41
       41
       -
             in

     

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

     

       43
       43
       -
       

     

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

     

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

     

       46
       46
       -
              full_store),

     

       47
       47
       -
             () ) (Exec command) =

     

       48
       48
       -
         let info () =

     

       49
       49
       -
           S.Info.v ~message:"shelter" (Eio.Time.now clock |> Int64.of_float)

     

       50
       50
       -
         in

     

       51
       51
       -
         let cmd =

     

       52
       52
       -
           String.split_on_char ' ' command

     

       53
       53
       -
           |> List.filter (fun v -> not (String.equal "" v))

     

       54
       54
       -
         in

     

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

     

       56
       56
       -
         try

     

       57
       57
       -
           let proc = Eio.Process.spawn ~sw proc cmd in

     

       58
       58
       -
           let res = Eio.Process.await proc in

     

       59
       59
       -
           if res = `Exited 0 then (

     

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

     

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

     

       62
       62
       -
             Ok (full_store, ()))

     

       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

-1

src/lib/passthrough/shelter_passthrough.mli

···

       1
       1
       -
       include Shelter.Engine.S with type entry = string

-57

src/lib/script.ml

···

       1
       1
       -
       module Cst = Morbig.CST

     

       2
       2
       -
       

     

       3
       3
       -
       let redirect_to_string = function

     

       4
       4
       -
         | Cst.IoRedirect_IoFile { value = io_file; _ } -> (

     

       5
       5
       -
             match io_file with

     

       6
       6
       -
             | Cst.IoFile_Great_FileName

     

       7
       7
       -
                 { value = Cst.Filename_Word { value = Cst.Word (w, _); _ }; _ } ->

     

       8
       8
       -
                 Fmt.str "> %s" w

     

       9
       9
       -
             | Cst.IoFile_DGreat_FileName

     

       10
       10
       -
                 { value = Cst.Filename_Word { value = Cst.Word (w, _); _ }; _ } ->

     

       11
       11
       -
                 Fmt.str ">> %s" w

     

       12
       12
       -
             | _ -> failwith "Redirect Unsupported")

     

       13
       13
       -
         | _ -> failwith "IO Redirect Unsupported"

     

       14
       14
       -
       

     

       15
       15
       -
       let cmd_suffix_to_list s =

     

       16
       16
       -
         let rec loop = function

     

       17
       17
       -
           | Cst.CmdSuffix_Word { value = Cst.Word (s, _); _ } -> [ s ]

     

       18
       18
       -
           | Cst.CmdSuffix_CmdSuffix_Word (suff, { value = Cst.Word (s, _); _ }) ->

     

       19
       19
       -
               s :: loop suff.value

     

       20
       20
       -
           | Cst.CmdSuffix_CmdSuffix_IoRedirect (suff, { value = redirect; _ }) ->

     

       21
       21
       -
               let sf = loop suff.value in

     

       22
       22
       -
               redirect_to_string redirect :: sf

     

       23
       23
       -
           | _ -> failwith "Unsupported!"

     

       24
       24
       -
         in

     

       25
       25
       -
         loop s |> List.rev |> String.concat " "

     

       26
       26
       -
       

     

       27
       27
       -
       let of_cmd (c : Cst.command) =

     

       28
       28
       -
         match c with

     

       29
       29
       -
         | Cst.Command_SimpleCommand simple -> (

     

       30
       30
       -
             match simple.value with

     

       31
       31
       -
             | Cst.SimpleCommand_CmdName

     

       32
       32
       -
                 { value = Cst.CmdName_Word { value = Cst.Word (w, _); _ }; _ } ->

     

       33
       33
       -
                 w

     

       34
       34
       -
             | Cst.SimpleCommand_CmdName_CmdSuffix

     

       35
       35
       -
                 ( { value = Cst.CmdName_Word { value = Cst.Word (w, _); _ }; _ },

     

       36
       36
       -
                   { value = suff; _ } ) ->

     

       37
       37
       -
                 let s = cmd_suffix_to_list suff in

     

       38
       38
       -
                 w ^ " " ^ s

     

       39
       39
       -
             | _ -> failwith "Unsupported")

     

       40
       40
       -
         | _ -> failwith "Unsupported"

     

       41
       41
       -
       

     

       42
       42
       -
       let cmds_to_strings =

     

       43
       43
       -
         let v =

     

       44
       44
       -
           object

     

       45
       45
       -
             inherit [_] Morbig.CSTVisitors.reduce

     

       46
       46
       -
             method zero = []

     

       47
       47
       -
             method plus = List.append

     

       48
       48
       -
             method! visit_command acc c = of_cmd c :: acc

     

       49
       49
       -
           end

     

       50
       50
       -
         in

     

       51
       51
       -
         v#visit_program []

     

       52
       52
       -
       

     

       53
       53
       -
       let to_commands file =

     

       54
       54
       -
         let contents = Eio.Path.load file in

     

       55
       55
       -
         let name = Eio.Path.native_exn file |> Filename.basename in

     

       56
       56
       -
         let ast = Morbig.parse_string name contents in

     

       57
       57
       -
         cmds_to_strings ast

-34

src/lib/shelter/config.ml

···

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

     

       8
       8
       -
       

     

       9
       9
       -
       let cmdliner =

     

       10
       10
       -
         let open Cmdliner in

     

       11
       11
       -
         let no_diffing =

     

       12
       12
       -
           let doc = "Disable diffing." in

     

       13
       13
       -
           Arg.(value & flag & info [ "no-diffing" ] ~doc)

     

       14
       14
       -
         in

     

       15
       15
       -
         let no_ebpf =

     

       16
       16
       -
           let doc = "Disable eBPF." in

     

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

     

       18
       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

     

       31
       31
       -
         Term.(

     

       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)

-105

src/lib/shelter/diff.ml

···

       1
       1
       -
       type diff =

     

       2
       2
       -
         | Modified of string

     

       3
       3
       -
         | Created of string

     

       4
       4
       -
         | Renamed of string * string

     

       5
       5
       -
         | Removed of string

     

       6
       6
       -
       [@@deriving repr]

     

       7
       7
       -
       

     

       8
       8
       -
       let path = function

     

       9
       9
       -
         | Modified p -> p

     

       10
       10
       -
         | Created p -> p

     

       11
       11
       -
         | Renamed (p, _) -> p

     

       12
       12
       -
         | Removed p -> p

     

       13
       13
       -
       

     

       14
       14
       -
       type t = diff list [@@deriving repr]

     

       15
       15
       -
       

     

       16
       16
       -
       let truncate_path s =

     

       17
       17
       -
         match Astring.String.cut ~sep:"rootfs" s with Some (_, p) -> p | None -> s

     

       18
       18
       -
       

     

       19
       19
       -
       let parse_row = function

     

       20
       20
       -
         | [ "M"; s ] ->

     

       21
       21
       -
             let path = truncate_path s in

     

       22
       22
       -
             if String.equal path "" then None else Some (Modified path)

     

       23
       23
       -
         | [ "+"; s ] ->

     

       24
       24
       -
             let path = truncate_path s in

     

       25
       25
       -
             if String.equal path "" then None else Some (Created path)

     

       26
       26
       -
         | [ "R"; a; b ] ->

     

       27
       27
       -
             let a_path = truncate_path a in

     

       28
       28
       -
             let b_path = truncate_path b in

     

       29
       29
       -
             Some (Renamed (a_path, b_path))

     

       30
       30
       -
         | [ "-"; s ] ->

     

       31
       31
       -
             let path = truncate_path s in

     

       32
       32
       -
             if String.equal path "" then None else Some (Removed path)

     

       33
       33
       -
         | s ->

     

       34
       34
       -
             Fmt.invalid_arg "Unknown ZFS diff: %a"

     

       35
       35
       -
               (Fmt.list ~sep:Fmt.comma Fmt.string)

     

       36
       36
       -
               s

     

       37
       37
       -
       

     

       38
       38
       -
       let of_zfs s : t =

     

       39
       39
       -
         let lines = String.split_on_char '\n' s in

     

       40
       40
       -
         let tsv =

     

       41
       41
       -
           List.map (String.split_on_char '\t') lines

     

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

     

       43
       43
       -
           |> List.filter (function [] -> false | _ -> true)

     

       44
       44
       -
         in

     

       45
       45
       -
         List.filter_map parse_row tsv

     

       46
       46
       -
       

     

       47
       47
       -
       type tree = Leaf of diff | Dir of string * tree list

     

       48
       48
       -
       

     

       49
       49
       -
       let rec insert modified path_components tree =

     

       50
       50
       -
         match (path_components, tree) with

     

       51
       51
       -
         | [], _ -> tree

     

       52
       52
       -
         | [ file ], nodes ->

     

       53
       53
       -
             if List.exists (function Leaf f -> path f = file | _ -> false) nodes

     

       54
       54
       -
             then nodes

     

       55
       55
       -
             else

     

       56
       56
       -
               let diff =

     

       57
       57
       -
                 match modified with

     

       58
       58
       -
                 | Modified _ -> Modified file

     

       59
       59
       -
                 | Created _ -> Created file

     

       60
       60
       -
                 | Renamed (_, to_) -> Renamed (file, to_)

     

       61
       61
       -
                 | Removed _ -> Removed file

     

       62
       62
       -
               in

     

       63
       63
       -
               Leaf diff :: nodes

     

       64
       64
       -
         | dir :: rest, nodes ->

     

       65
       65
       -
             let rec insert_into_dir acc = function

     

       66
       66
       -
               | [] -> Dir (dir, insert modified rest []) :: List.rev acc

     

       67
       67
       -
               | Dir (name, children) :: tl when name = dir ->

     

       68
       68
       -
                   List.rev_append acc (Dir (name, insert modified rest children) :: tl)

     

       69
       69
       -
               | x :: tl -> insert_into_dir (x :: acc) tl

     

       70
       70
       -
             in

     

       71
       71
       -
             insert_into_dir [] nodes

     

       72
       72
       -
       

     

       73
       73
       -
       let to_tree (diffs : diff list) =

     

       74
       74
       -
         let paths =

     

       75
       75
       -
           List.map (fun v -> (v, String.split_on_char '/' (path v))) diffs

     

       76
       76
       -
         in

     

       77
       77
       -
         List.fold_left (fun acc (m, p) -> insert m p acc) [] paths

     

       78
       78
       -
       

     

       79
       79
       -
       let leaves =

     

       80
       80
       -
         let rec loop acc acc2 = function

     

       81
       81
       -
           | Leaf (Modified v) -> Modified (Filename.concat acc v) :: acc2

     

       82
       82
       -
           | Leaf (Created v) -> Created (Filename.concat acc v) :: acc2

     

       83
       83
       -
           | Leaf (Removed v) -> Removed (Filename.concat acc v) :: acc2

     

       84
       84
       -
           | Leaf (Renamed (r1, r2)) -> Renamed (Filename.concat acc r1, r2) :: acc2

     

       85
       85
       -
           | Dir (p, cs) ->

     

       86
       86
       -
               List.fold_left (fun lvs v -> loop (Filename.concat acc p) lvs v) acc2 cs

     

       87
       87
       -
         in

     

       88
       88
       -
         loop "" []

     

       89
       89
       -
       

     

       90
       90
       -
       let pp_diff fmt = function

     

       91
       91
       -
         | Modified v -> Fmt.(styled (`Fg `Yellow) string) fmt ("~ /" ^ v)

     

       92
       92
       -
         | Created v -> Fmt.(styled (`Fg `Green) string) fmt ("+ /" ^ v)

     

       93
       93
       -
         | Removed v -> Fmt.(styled (`Fg `Red) string) fmt ("- /" ^ v)

     

       94
       94
       -
         | Renamed (v, _) -> Fmt.(styled (`Fg `Magenta) string) fmt ("| /" ^ v)

     

       95
       95
       -
       

     

       96
       96
       -
       let pp fmt diffs =

     

       97
       97
       -
         let tree = to_tree diffs in

     

       98
       98
       -
         let lvs =

     

       99
       99
       -
           List.fold_left (fun acc v -> leaves v @ acc) [] tree

     

       100
       100
       -
           |> List.filter (fun v ->

     

       101
       101
       -
                  not

     

       102
       102
       -
                    (String.starts_with ~prefix:"shelter" (path v)

     

       103
       103
       -
                    || String.starts_with ~prefix:"tmp" (path v)))

     

       104
       104
       -
         in

     

       105
       105
       -
         Fmt.pf fmt "%a" Fmt.(list ~sep:Format.pp_force_newline pp_diff) lvs

-13

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
       -
       

     

       6
       6
       -
       (library

     

       7
       7
       -
        (name shelter_main)

     

       8
       8
       -
        (public_name shelter.main)

     

       9
       9
       -
        (preprocessor_deps

     

       10
       10
       -
         (file opentrace))

     

       11
       11
       -
        (preprocess

     

       12
       12
       -
         (pps ppx_repr ppx_blob))

     

       13
       13
       -
        (libraries shelter cid void zfs))

-53

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'

     

       29
       29
       -
       

     

       30
       30
       -
       let get_image ~dir ~proc image =

     

       31
       31
       -
         let container_id =

     

       32
       32
       -
           Eio.Process.parse_out proc Eio.Buf_read.take_all

     

       33
       33
       -
             [ "docker"; "create"; "--"; image ]

     

       34
       34
       -
           |> String.trim

     

       35
       35
       -
         in

     

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

     

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

     

       38
       38
       -
         let () =

     

       39
       39
       -
           Eio.Process.run proc

     

       40
       40
       -
             [ "docker"; "export"; container_id; "-o"; Filename.concat dir_s tar ]

     

       41
       41
       -
         in

     

       42
       42
       -
         Eio.Path.mkdir ~perm:0o777 (dir / "rootfs");

     

       43
       43
       -
         let () =

     

       44
       44
       -
           Eio.Process.run proc

     

       45
       45
       -
             [

     

       46
       46
       -
               "tar";

     

       47
       47
       -
               "-xf";

     

       48
       48
       -
               Filename.concat dir_s tar;

     

       49
       49
       -
               "-C";

     

       50
       50
       -
               Filename.concat dir_s "rootfs";

     

       51
       51
       -
             ]

     

       52
       52
       -
         in

     

       53
       53
       -
         Filename.concat dir_s "rootfs"

src/lib/shelter/opentrace

This is a binary file and will not be displayed.

-509

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
       -
             "CAP_BPF";

     

       77
       77
       -
             "CAP_PERFMON";

     

       78
       78
       -
             (* BPF operations *)

     

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

     

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

     

       81
       81
       -
           "CAP_NET_BIND_SERVICE";     (* Bind a socket to Internet domain privileged ports. *)

     

       82
       82
       -
           *)

     

       83
       83
       -
           ]

     

       84
       84
       -
       

     

       85
       85
       -
         let seccomp_syscalls ~fast_sync =

     

       86
       86
       -
           if fast_sync then

     

       87
       87
       -
             [

     

       88
       88
       -
               `Assoc

     

       89
       89
       -
                 [

     

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

     

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

     

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

     

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

     

       94
       94
       -
                   ( "names",

     

       95
       95
       -
                     strings

     

       96
       96
       -
                       [

     

       97
       97
       -
                         "fsync";

     

       98
       98
       -
                         "fdatasync";

     

       99
       99
       -
                         "msync";

     

       100
       100
       -
                         "sync";

     

       101
       101
       -
                         "syncfs";

     

       102
       102
       -
                         "sync_file_range";

     

       103
       103
       -
                       ] );

     

       104
       104
       -
                   ("action", `String "SCMP_ACT_ERRNO");

     

       105
       105
       -
                   ("errnoRet", `Int 0);

     

       106
       106
       -
                   (* Return error "success" *)

     

       107
       107
       -
                 ];

     

       108
       108
       -
             ]

     

       109
       109
       -
           else []

     

       110
       110
       -
       

     

       111
       111
       -
         let seccomp_policy =

     

       112
       112
       -
           let fields =

     

       113
       113
       -
             [

     

       114
       114
       -
               ("defaultAction", `String "SCMP_ACT_ALLOW");

     

       115
       115
       -
               ("syscalls", `List (seccomp_syscalls ~fast_sync:true));

     

       116
       116
       -
             ]

     

       117
       117
       -
           in

     

       118
       118
       -
           `Assoc fields

     

       119
       119
       -
       

     

       120
       120
       -
         type config = {

     

       121
       121
       -
           cwd : string;

     

       122
       122
       -
           argv : string list;

     

       123
       123
       -
           hostname : string;

     

       124
       124
       -
           network : string list;

     

       125
       125
       -
           user : int * int;

     

       126
       126
       -
           env : string list;

     

       127
       127
       -
           mounts : mount list;

     

       128
       128
       -
           entrypoint : string option;

     

       129
       129
       -
         }

     

       130
       130
       -
       

     

       131
       131
       -
         let make { cwd; argv; hostname; network; user; env; mounts; entrypoint }

     

       132
       132
       -
             ~config_dir ~results_dir : Yojson.Safe.t =

     

       133
       133
       -
           assert (entrypoint = None);

     

       134
       134
       -
           let user =

     

       135
       135
       -
             let uid, gid = user in

     

       136
       136
       -
             `Assoc [ ("uid", `Int uid); ("gid", `Int gid) ]

     

       137
       137
       -
           in

     

       138
       138
       -
           let network_ns =

     

       139
       139
       -
             match network with

     

       140
       140
       -
             | [ "host" ] -> []

     

       141
       141
       -
             | [] -> [ "network" ]

     

       142
       142
       -
             | xs ->

     

       143
       143
       -
                 Fmt.failwith "Unsupported network configuration %a"

     

       144
       144
       -
                   Fmt.Dump.(list string)

     

       145
       145
       -
                   xs

     

       146
       146
       -
           in

     

       147
       147
       -
           let namespaces = network_ns @ [ "pid"; "ipc"; "uts"; "mount" ] in

     

       148
       148
       -
           `Assoc

     

       149
       149
       -
             [

     

       150
       150
       -
               ("ociVersion", `String "1.0.1-dev");

     

       151
       151
       -
               ( "process",

     

       152
       152
       -
                 `Assoc

     

       153
       153
       -
                   [

     

       154
       154
       -
                     ("terminal", `Bool true);

     

       155
       155
       -
                     ("user", user);

     

       156
       156
       -
                     ("args", strings argv);

     

       157
       157
       -
                     ("env", strings env);

     

       158
       158
       -
                     ("cwd", `String cwd);

     

       159
       159
       -
                     ( "capabilities",

     

       160
       160
       -
                       `Assoc

     

       161
       161
       -
                         [

     

       162
       162
       -
                           ("bounding", strings default_linux_caps);

     

       163
       163
       -
                           (* Limits capabilities gained on execve. *)

     

       164
       164
       -
                           ("effective", strings default_linux_caps);

     

       165
       165
       -
                           (* Checked by kernel to decide access *)

     

       166
       166
       -
                           ("inheritable", strings default_linux_caps);

     

       167
       167
       -
                           (* Preserved across an execve (if root, or cap in ambient set) *)

     

       168
       168
       -
                           ("permitted", strings default_linux_caps);

     

       169
       169
       -
                           (* Limiting superset for the effective capabilities *)

     

       170
       170
       -
                         ] );

     

       171
       171
       -
                     ( "rlimits",

     

       172
       172
       -
                       `List

     

       173
       173
       -
                         [

     

       174
       174
       -
                           `Assoc

     

       175
       175
       -
                             [

     

       176
       176
       -
                               ("type", `String "RLIMIT_NOFILE");

     

       177
       177
       -
                               ("hard", `Int 10_024);

     

       178
       178
       -
                               ("soft", `Int 10_024);

     

       179
       179
       -
                             ];

     

       180
       180
       -
                           `Assoc

     

       181
       181
       -
                             [

     

       182
       182
       -
                               ("type", `String "RLIMIT_MEMLOCK");

     

       183
       183
       -
                               ("hard", `Int 1_000_000);

     

       184
       184
       -
                               ("soft", `Int 1_000_000);

     

       185
       185
       -
                             ];

     

       186
       186
       -
                         ] );

     

       187
       187
       -
                     ("noNewPrivileges", `Bool false);

     

       188
       188
       -
                   ] );

     

       189
       189
       -
               ( "root",

     

       190
       190
       -
                 `Assoc

     

       191
       191
       -
                   [

     

       192
       192
       -
                     ("path", `String (results_dir // "rootfs"));

     

       193
       193
       -
                     ("readonly", `Bool false);

     

       194
       194
       -
                   ] );

     

       195
       195
       -
               ("hostname", `String hostname);

     

       196
       196
       -
               ( "mounts",

     

       197
       197
       -
                 `List

     

       198
       198
       -
                   (mount "/proc"

     

       199
       199
       -
                      ~options:

     

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

     

       201
       201
       -
                      ~ty:"proc" ~src:"proc"

     

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

     

       203
       203
       -
                         ~options:

     

       204
       204
       -
                           [ "nosuid"; "strictatime"; "mode=755"; "size=65536k" ]

     

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

     

       206
       206
       -
                         ~options:

     

       207
       207
       -
                           [

     

       208
       208
       -
                             "nosuid";

     

       209
       209
       -
                             "noexec";

     

       210
       210
       -
                             "newinstance";

     

       211
       211
       -
                             "ptmxmode=0666";

     

       212
       212
       -
                             "mode=0620";

     

       213
       213
       -
                             "gid=5";

     

       214
       214
       -
                             (* tty *)

     

       215
       215
       -
                           ]

     

       216
       216
       -
                    :: mount

     

       217
       217
       -
                         "/sys"

     

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

     

       219
       219
       -
                         ~ty:"sysfs" ~src:"sysfs"

     

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

     

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

     

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

     

       223
       223
       -
                    :: mount "/sys/kernel/debug" ~ty:"debugfs" ~src:"debug"

     

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

     

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

     

       226
       226
       -
                         ~options:

     

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

     

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

     

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

     

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

     

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

     

       232
       232
       -
                    ::

     

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

     

       234
       234
       -
                       [

     

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

     

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

     

       237
       237
       -
                       ]

     

       238
       238
       -
                     else [])

     

       239
       239
       -
                   @ user_mounts mounts) );

     

       240
       240
       -
               ( "linux",

     

       241
       241
       -
                 `Assoc

     

       242
       242
       -
                   [

     

       243
       243
       -
                     ("namespaces", `List (List.map namespace namespaces));

     

       244
       244
       -
                     ( "maskedPaths",

     

       245
       245
       -
                       strings

     

       246
       246
       -
                         [

     

       247
       247
       -
                           "/proc/acpi";

     

       248
       248
       -
                           "/proc/asound";

     

       249
       249
       -
                           "/proc/kcore";

     

       250
       250
       -
                           "/proc/keys";

     

       251
       251
       -
                           "/proc/latency_stats";

     

       252
       252
       -
                           "/proc/timer_list";

     

       253
       253
       -
                           "/proc/timer_stats";

     

       254
       254
       -
                           "/proc/sched_debug";

     

       255
       255
       -
                           "/sys/firmware";

     

       256
       256
       -
                           "/proc/scsi";

     

       257
       257
       -
                         ] );

     

       258
       258
       -
                     ( "readonlyPaths",

     

       259
       259
       -
                       strings

     

       260
       260
       -
                         [

     

       261
       261
       -
                           "/proc/bus";

     

       262
       262
       -
                           "/proc/fs";

     

       263
       263
       -
                           "/proc/irq";

     

       264
       264
       -
                           "/proc/sys";

     

       265
       265
       -
                           "/proc/sysrq-trigger";

     

       266
       266
       -
                         ] );

     

       267
       267
       -
                     ("seccomp", seccomp_policy);

     

       268
       268
       -
                   ] );

     

       269
       269
       -
             ]

     

       270
       270
       -
       end

     

       271
       271
       -
       

     

       272
       272
       -
       let next_id = ref 0

     

       273
       273
       -
       

     

       274
       274
       -
       let to_other_sink_as_well ~other

     

       275
       275
       -
           (Eio.Resource.T (t, handler) : Eio.Flow.sink_ty Eio.Flow.sink) =

     

       276
       276
       -
         let module Sink = (val Eio.Resource.get handler Eio.Flow.Pi.Sink) in

     

       277
       277
       -
         let buf = Cstruct.create 4096 in

     

       278
       278
       -
         let copy () ~src =

     

       279
       279
       -
           try

     

       280
       280
       -
             while true do

     

       281
       281
       -
               match Eio.Flow.single_read src buf with

     

       282
       282
       -
               | i ->

     

       283
       283
       -
                   let bufs = [ Cstruct.sub buf 0 i ] in

     

       284
       284
       -
                   Eio.Fiber.both

     

       285
       285
       -
                     (fun () -> Eio.Flow.write other bufs)

     

       286
       286
       -
                     (fun () -> Sink.copy ~src:(Eio.Flow.cstruct_source bufs) t)

     

       287
       287
       -
             done

     

       288
       288
       -
           with End_of_file -> ()

     

       289
       289
       -
         in

     

       290
       290
       -
         let single_write () x =

     

       291
       291
       -
           let _ : int = Eio.Flow.single_write other x in

     

       292
       292
       -
           Sink.single_write t x

     

       293
       293
       -
         in

     

       294
       294
       -
         let module T = struct

     

       295
       295
       -
           type t = unit

     

       296
       296
       -
       

     

       297
       297
       -
           let single_write = single_write

     

       298
       298
       -
           let copy = copy

     

       299
       299
       -
         end in

     

       300
       300
       -
         Eio.Resource.T ((), Eio.Flow.Pi.sink (module T))

     

       301
       301
       -
       

     

       302
       302
       -
       let spawn ~sw log env config dir =

     

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

     

       304
       304
       -
         let eio_tmp = Eio.Path.(env#fs / tmp) in

     

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

     

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

     

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

     

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

     

       309
       309
       -
           "127.0.0.1 localhost builder";

     

       310
       310
       -
         let id = string_of_int !next_id in

     

       311
       311
       -
         incr next_id;

     

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

     

       313
       313
       -
         let stdout =

     

       314
       314
       -
           to_other_sink_as_well ~other:env#stdout

     

       315
       315
       -
             (log :> Eio.Flow.sink_ty Eio.Flow.sink)

     

       316
       316
       -
         in

     

       317
       317
       -
         Eio.Process.spawn ~sw ~stdout ~stderr:env#stdout env#proc ~cwd:eio_tmp cmd

     

       318
       318
       -
       

     

       319
       319
       -
       (* 

     

       320
       320
       -
                                        Apache License

     

       321
       321
       -
                                  Version 2.0, January 2004

     

       322
       322
       -
                               https://www.apache.org/licenses/

     

       323
       323
       -
       

     

       324
       324
       -
          TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION

     

       325
       325
       -
       

     

       326
       326
       -
          1. Definitions.

     

       327
       327
       -
       

     

       328
       328
       -
             "License" shall mean the terms and conditions for use, reproduction,

     

       329
       329
       -
             and distribution as defined by Sections 1 through 9 of this document.

     

       330
       330
       -
       

     

       331
       331
       -
             "Licensor" shall mean the copyright owner or entity authorized by

     

       332
       332
       -
             the copyright owner that is granting the License.

     

       333
       333
       -
       

     

       334
       334
       -
             "Legal Entity" shall mean the union of the acting entity and all

     

       335
       335
       -
             other entities that control, are controlled by, or are under common

     

       336
       336
       -
             control with that entity. For the purposes of this definition,

     

       337
       337
       -
             "control" means (i) the power, direct or indirect, to cause the

     

       338
       338
       -
             direction or management of such entity, whether by contract or

     

       339
       339
       -
             otherwise, or (ii) ownership of fifty percent (50%) or more of the

     

       340
       340
       -
             outstanding shares, or (iii) beneficial ownership of such entity.

     

       341
       341
       -
       

     

       342
       342
       -
             "You" (or "Your") shall mean an individual or Legal Entity

     

       343
       343
       -
             exercising permissions granted by this License.

     

       344
       344
       -
       

     

       345
       345
       -
             "Source" form shall mean the preferred form for making modifications,

     

       346
       346
       -
             including but not limited to software source code, documentation

     

       347
       347
       -
             source, and configuration files.

     

       348
       348
       -
       

     

       349
       349
       -
             "Object" form shall mean any form resulting from mechanical

     

       350
       350
       -
             transformation or translation of a Source form, including but

     

       351
       351
       -
             not limited to compiled object code, generated documentation,

     

       352
       352
       -
             and conversions to other media types.

     

       353
       353
       -
       

     

       354
       354
       -
             "Work" shall mean the work of authorship, whether in Source or

     

       355
       355
       -
             Object form, made available under the License, as indicated by a

     

       356
       356
       -
             copyright notice that is included in or attached to the work

     

       357
       357
       -
             (an example is provided in the Appendix below).

     

       358
       358
       -
       

     

       359
       359
       -
             "Derivative Works" shall mean any work, whether in Source or Object

     

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

     

       361
       361
       -
             editorial revisions, annotations, elaborations, or other modifications

     

       362
       362
       -
             represent, as a whole, an original work of authorship. For the purposes

     

       363
       363
       -
             of this License, Derivative Works shall not include works that remain

     

       364
       364
       -
             separable from, or merely link (or bind by name) to the interfaces of,

     

       365
       365
       -
             the Work and Derivative Works thereof.

     

       366
       366
       -
       

     

       367
       367
       -
             "Contribution" shall mean any work of authorship, including

     

       368
       368
       -
             the original version of the Work and any modifications or additions

     

       369
       369
       -
             to that Work or Derivative Works thereof, that is intentionally

     

       370
       370
       -
             submitted to Licensor for inclusion in the Work by the copyright owner

     

       371
       371
       -
             or by an individual or Legal Entity authorized to submit on behalf of

     

       372
       372
       -
             the copyright owner. For the purposes of this definition, "submitted"

     

       373
       373
       -
             means any form of electronic, verbal, or written communication sent

     

       374
       374
       -
             to the Licensor or its representatives, including but not limited to

     

       375
       375
       -
             communication on electronic mailing lists, source code control systems,

     

       376
       376
       -
             and issue tracking systems that are managed by, or on behalf of, the

     

       377
       377
       -
             Licensor for the purpose of discussing and improving the Work, but

     

       378
       378
       -
             excluding communication that is conspicuously marked or otherwise

     

       379
       379
       -
             designated in writing by the copyright owner as "Not a Contribution."

     

       380
       380
       -
       

     

       381
       381
       -
             "Contributor" shall mean Licensor and any individual or Legal Entity

     

       382
       382
       -
             on behalf of whom a Contribution has been received by Licensor and

     

       383
       383
       -
             subsequently incorporated within the Work.

     

       384
       384
       -
       

     

       385
       385
       -
          2. Grant of Copyright License. Subject to the terms and conditions of

     

       386
       386
       -
             this License, each Contributor hereby grants to You a perpetual,

     

       387
       387
       -
             worldwide, non-exclusive, no-charge, royalty-free, irrevocable

     

       388
       388
       -
             copyright license to reproduce, prepare Derivative Works of,

     

       389
       389
       -
             publicly display, publicly perform, sublicense, and distribute the

     

       390
       390
       -
             Work and such Derivative Works in Source or Object form.

     

       391
       391
       -
       

     

       392
       392
       -
          3. Grant of Patent License. Subject to the terms and conditions of

     

       393
       393
       -
             this License, each Contributor hereby grants to You a perpetual,

     

       394
       394
       -
             worldwide, non-exclusive, no-charge, royalty-free, irrevocable

     

       395
       395
       -
             (except as stated in this section) patent license to make, have made,

     

       396
       396
       -
             use, offer to sell, sell, import, and otherwise transfer the Work,

     

       397
       397
       -
             where such license applies only to those patent claims licensable

     

       398
       398
       -
             by such Contributor that are necessarily infringed by their

     

       399
       399
       -
             Contribution(s) alone or by combination of their Contribution(s)

     

       400
       400
       -
             with the Work to which such Contribution(s) was submitted. If You

     

       401
       401
       -
             institute patent litigation against any entity (including a

     

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

     

       403
       403
       -
             or a Contribution incorporated within the Work constitutes direct

     

       404
       404
       -
             or contributory patent infringement, then any patent licenses

     

       405
       405
       -
             granted to You under this License for that Work shall terminate

     

       406
       406
       -
             as of the date such litigation is filed.

     

       407
       407
       -
       

     

       408
       408
       -
          4. Redistribution. You may reproduce and distribute copies of the

     

       409
       409
       -
             Work or Derivative Works thereof in any medium, with or without

     

       410
       410
       -
             modifications, and in Source or Object form, provided that You

     

       411
       411
       -
             meet the following conditions:

     

       412
       412
       -
       

     

       413
       413
       -
             (a) You must give any other recipients of the Work or

     

       414
       414
       -
                 Derivative Works a copy of this License; and

     

       415
       415
       -
       

     

       416
       416
       -
             (b) You must cause any modified files to carry prominent notices

     

       417
       417
       -
                 stating that You changed the files; and

     

       418
       418
       -
       

     

       419
       419
       -
             (c) You must retain, in the Source form of any Derivative Works

     

       420
       420
       -
                 that You distribute, all copyright, patent, trademark, and

     

       421
       421
       -
                 attribution notices from the Source form of the Work,

     

       422
       422
       -
                 excluding those notices that do not pertain to any part of

     

       423
       423
       -
                 the Derivative Works; and

     

       424
       424
       -
       

     

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

     

       426
       426
       -
                 distribution, then any Derivative Works that You distribute must

     

       427
       427
       -
                 include a readable copy of the attribution notices contained

     

       428
       428
       -
                 within such NOTICE file, excluding those notices that do not

     

       429
       429
       -
                 pertain to any part of the Derivative Works, in at least one

     

       430
       430
       -
                 of the following places: within a NOTICE text file distributed

     

       431
       431
       -
                 as part of the Derivative Works; within the Source form or

     

       432
       432
       -
                 documentation, if provided along with the Derivative Works; or,

     

       433
       433
       -
                 within a display generated by the Derivative Works, if and

     

       434
       434
       -
                 wherever such third-party notices normally appear. The contents

     

       435
       435
       -
                 of the NOTICE file are for informational purposes only and

     

       436
       436
       -
                 do not modify the License. You may add Your own attribution

     

       437
       437
       -
                 notices within Derivative Works that You distribute, alongside

     

       438
       438
       -
                 or as an addendum to the NOTICE text from the Work, provided

     

       439
       439
       -
                 that such additional attribution notices cannot be construed

     

       440
       440
       -
                 as modifying the License.

     

       441
       441
       -
       

     

       442
       442
       -
             You may add Your own copyright statement to Your modifications and

     

       443
       443
       -
             may provide additional or different license terms and conditions

     

       444
       444
       -
             for use, reproduction, or distribution of Your modifications, or

     

       445
       445
       -
             for any such Derivative Works as a whole, provided Your use,

     

       446
       446
       -
             reproduction, and distribution of the Work otherwise complies with

     

       447
       447
       -
             the conditions stated in this License.

     

       448
       448
       -
       

     

       449
       449
       -
          5. Submission of Contributions. Unless You explicitly state otherwise,

     

       450
       450
       -
             any Contribution intentionally submitted for inclusion in the Work

     

       451
       451
       -
             by You to the Licensor shall be under the terms and conditions of

     

       452
       452
       -
             this License, without any additional terms or conditions.

     

       453
       453
       -
             Notwithstanding the above, nothing herein shall supersede or modify

     

       454
       454
       -
             the terms of any separate license agreement you may have executed

     

       455
       455
       -
             with Licensor regarding such Contributions.

     

       456
       456
       -
       

     

       457
       457
       -
          6. Trademarks. This License does not grant permission to use the trade

     

       458
       458
       -
             names, trademarks, service marks, or product names of the Licensor,

     

       459
       459
       -
             except as required for reasonable and customary use in describing the

     

       460
       460
       -
             origin of the Work and reproducing the content of the NOTICE file.

     

       461
       461
       -
       

     

       462
       462
       -
          7. Disclaimer of Warranty. Unless required by applicable law or

     

       463
       463
       -
             agreed to in writing, Licensor provides the Work (and each

     

       464
       464
       -
             Contributor provides its Contributions) on an "AS IS" BASIS,

     

       465
       465
       -
             WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or

     

       466
       466
       -
             implied, including, without limitation, any warranties or conditions

     

       467
       467
       -
             of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A

     

       468
       468
       -
             PARTICULAR PURPOSE. You are solely responsible for determining the

     

       469
       469
       -
             appropriateness of using or redistributing the Work and assume any

     

       470
       470
       -
             risks associated with Your exercise of permissions under this License.

     

       471
       471
       -
       

     

       472
       472
       -
          8. Limitation of Liability. In no event and under no legal theory,

     

       473
       473
       -
             whether in tort (including negligence), contract, or otherwise,

     

       474
       474
       -
             unless required by applicable law (such as deliberate and grossly

     

       475
       475
       -
             negligent acts) or agreed to in writing, shall any Contributor be

     

       476
       476
       -
             liable to You for damages, including any direct, indirect, special,

     

       477
       477
       -
             incidental, or consequential damages of any character arising as a

     

       478
       478
       -
             result of this License or out of the use or inability to use the

     

       479
       479
       -
             Work (including but not limited to damages for loss of goodwill,

     

       480
       480
       -
             work stoppage, computer failure or malfunction, or any and all

     

       481
       481
       -
             other commercial damages or losses), even if such Contributor

     

       482
       482
       -
             has been advised of the possibility of such damages.

     

       483
       483
       -
       

     

       484
       484
       -
          9. Accepting Warranty or Additional Liability. While redistributing

     

       485
       485
       -
             the Work or Derivative Works thereof, You may choose to offer,

     

       486
       486
       -
             and charge a fee for, acceptance of support, warranty, indemnity,

     

       487
       487
       -
             or other liability obligations and/or rights consistent with this

     

       488
       488
       -
             License. However, in accepting such obligations, You may act only

     

       489
       489
       -
             on Your own behalf and on Your sole responsibility, not on behalf

     

       490
       490
       -
             of any other Contributor, and only if You agree to indemnify,

     

       491
       491
       -
             defend, and hold each Contributor harmless for any liability

     

       492
       492
       -
             incurred by, or claims asserted against, such Contributor by reason

     

       493
       493
       -
             of your accepting any such warranty or additional liability.

     

       494
       494
       -
       

     

       495
       495
       -
          END OF TERMS AND CONDITIONS

     

       496
       496
       -
       

     

       497
       497
       -
          Copyright 2020 Thomas Leonard

     

       498
       498
       -
       

     

       499
       499
       -
          Licensed under the Apache License, Version 2.0 (the "License");

     

       500
       500
       -
          you may not use this file except in compliance with the License.

     

       501
       501
       -
          You may obtain a copy of the License at

     

       502
       502
       -
       

     

       503
       503
       -
              https://www.apache.org/licenses/LICENSE-2.0

     

       504
       504
       -
       

     

       505
       505
       -
          Unless required by applicable law or agreed to in writing, software

     

       506
       506
       -
          distributed under the License is distributed on an "AS IS" BASIS,

     

       507
       507
       -
          WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.

     

       508
       508
       -
          See the License for the specific language governing permissions and

     

       509
       509
       -
          limitations under the License. *)

-592

src/lib/shelter/shelter_main.ml

···

       1
       1
       -
       open Eio

     

       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
       -
       

     

       9
       9
       -
       module History = struct

     

       10
       10
       -
         type mode = Void.mode

     

       11
       11
       -
       

     

       12
       12
       -
         let mode_t =

     

       13
       13
       -
           Repr.map Repr.string

     

       14
       14
       -
             (function

     

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

     

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

     

       17
       17
       -
       

     

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

     

       19
       19
       -
       

     

       20
       20
       -
         type pre = {

     

       21
       21
       -
           mode : mode;

     

       22
       22
       -
           build : Store.Build.t;

     

       23
       23
       -
           args : string list;

     

       24
       24
       -
           env : string list;

     

       25
       25
       -
           cwd : string;

     

       26
       26
       -
           user : int * int;

     

       27
       27
       -
         }

     

       28
       28
       -
         [@@deriving repr]

     

       29
       29
       -
         (** Needed for execution *)

     

       30
       30
       -
       

     

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

     

       32
       32
       -
       

     

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

     

       34
       34
       -
       end

     

       35
       35
       -
       

     

       36
       36
       -
       type config = Config.t

     

       37
       37
       -
       

     

       38
       38
       -
       let config_term = Config.cmdliner

     

       39
       39
       -
       

     

       40
       40
       -
       type entry = History.t

     

       41
       41
       -
       

     

       42
       42
       -
       type action =

     

       43
       43
       -
         (* Change modes *)

     

       44
       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 *)

     

       47
       47
       -
         | Set_session of string

     

       48
       48
       -
         (* Run a command *)

     

       49
       49
       -
         | Exec of string list

     

       50
       50
       -
         (* Undo the last command *)

     

       51
       51
       -
         | Undo

     

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

     

       53
       53
       -
         | Replay of string

     

       54
       54
       -
         (* Display info *)

     

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

     

       56
       56
       -
         (* Error state *)

     

       57
       57
       -
         | Unknown of string list

     

       58
       58
       -
       [@@deriving repr]

     

       59
       59
       -
       

     

       60
       60
       -
       let split_and_remove_empty s =

     

       61
       61
       -
         String.split_on_char ' ' s |> List.filter (fun v -> not (String.equal "" v))

     

       62
       62
       -
       

     

       63
       63
       -
       let action = action_t

     

       64
       64
       -
       

     

       65
       65
       -
       let shelter_action = function

     

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

     

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

     

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

     

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

     

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

     

       71
       71
       -
         | [ "undo" ] -> Undo

     

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

     

       73
       73
       -
         | other -> Unknown other

     

       74
       74
       -
       

     

       75
       75
       -
       let action_of_command cmd =

     

       76
       76
       -
         match split_and_remove_empty cmd with

     

       77
       77
       -
         | "@" :: rest -> shelter_action rest

     

       78
       78
       -
         | args -> Exec args

     

       79
       79
       -
       

     

       80
       80
       -
       let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty

     

       81
       81
       -
       let history_key = [ "history" ]

     

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

     

       83
       83
       -
       

     

       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 ]

     

       93
       93
       -
             in

     

       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

     

       118
       118
       -
       

     

       119
       119
       -
       let with_latest ~default s f =

     

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

     

       121
       121
       -
       

     

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

     

       123
       123
       -
       

     

       124
       124
       -
       let sessions (H.Store ((module S), store) : entry H.t) =

     

       125
       125
       -
         S.Branch.list (S.repo store)

     

       126
       126
       -
       

     

       127
       127
       -
       let commit ~message clock (H.Store ((module S), store) : entry H.t) v =

     

       128
       128
       -
         let info () = S.Info.v ~message (Eio.Time.now clock |> Int64.of_float) in

     

       129
       129
       -
         S.set_exn ~info store (key clock) v

     

       130
       130
       -
       

     

       131
       131
       -
       let which_branch ((H.Store ((module S), session) : entry H.t) as s) =

     

       132
       132
       -
         let branches = sessions s in

     

       133
       133
       -
         let repo = S.repo session in

     

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

     

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

     

       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)

     

       142
       142
       -
       

     

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

     

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

     

       145
       145
       -
         match

     

       146
       146
       -
           List.filter_map (S.Commit.of_hash (S.repo session))

     

       147
       147
       -
           @@ S.Commit.parents (S.Head.get session)

     

       148
       148
       -
         with

     

       149
       149
       -
         | [] -> s

     

       150
       150
       -
         | p :: _ ->

     

       151
       151
       -
             S.Head.set session p;

     

       152
       152
       -
             s

     

       153
       153
       -
       

     

       154
       154
       -
       (* Fork a new session from an existing one *)

     

       155
       155
       -
       let fork (H.Store ((module S), session) : entry H.t) new_branch =

     

       156
       156
       -
         let repo = S.repo session in

     

       157
       157
       -
         match (S.Head.find session, S.Branch.find repo new_branch) with

     

       158
       158
       -
         | _, Some _ ->

     

       159
       159
       -
             Error (new_branch ^ " already exists, try @ session " ^ new_branch)

     

       160
       160
       -
         | None, _ -> Error "Current branch needs at least one commit"

     

       161
       161
       -
         | Some commit, None ->

     

       162
       162
       -
             let new_store = S.of_branch (S.repo session) new_branch in

     

       163
       163
       -
             S.Branch.set repo new_branch commit;

     

       164
       164
       -
             let store = H.Store ((module S), new_store) in

     

       165
       165
       -
             Ok store

     

       166
       166
       -
       

     

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

     

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

     

       169
       169
       -
         let pp_diff fmt d = if d = [] then () else Fmt.pf fmt "\n%a%!" Diff.pp d in

     

       170
       170
       -
         let pp_entry fmt (e : entry) =

     

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

     

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

     

       173
       173
       -
             (String.concat " " e.pre.args)

     

       174
       174
       -
             pp_diff e.post.diff

     

       175
       175
       -
         in

     

       176
       176
       -
         let entries = history s |> List.rev in

     

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

     

       178
       178
       -
       

     

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

     

       180
       180
       -
         let head, sesh = which_branch store in

     

       181
       181
       -
         let sesh = Option.value ~default:"main" sesh in

     

       182
       182
       -
         let prompt () =

     

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

     

       184
       184
       -
           Format.flush_str_formatter ()

     

       185
       185
       -
         in

     

       186
       186
       -
         let pp_head fmt = function

     

       187
       187
       -
           | None -> Fmt.nop fmt ()

     

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

     

       189
       189
       -
         in

     

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

     

       191
       191
       -
         let pp_status fmt = function

     

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

     

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

     

       194
       194
       -
           | _ -> Fmt.nop fmt ()

     

       195
       195
       -
         in

     

       196
       196
       -
         let prompt_entry (e : entry) =

     

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

     

       198
       198
       -
             (text `Yellow) "shelter" pp_sesh sesh (text `Red)

     

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

     

       200
       200
       -
           Format.flush_str_formatter ()

     

       201
       201
       -
         in

     

       202
       202
       -
         with_latest store ~default:prompt prompt_entry

     

       203
       203
       -
       

     

       204
       204
       -
       type ctx = { store : Store.t; tool_dir : string }

     

       205
       205
       -
       

     

       206
       206
       -
       let tools = [ ("opentrace", Tools.opentrace) ]

     

       207
       207
       -
       

     

       208
       208
       -
       let init fs proc s =

     

       209
       209
       -
         let store = Store.init fs proc "shelter" in

     

       210
       210
       -
         List.iter

     

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

     

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

     

       213
       213
       -
           (history s);

     

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

     

       215
       215
       -
         let tools =

     

       216
       216
       -
           Store.Run.with_tool store tool_cid @@ fun tool_dir ->

     

       217
       217
       -
           Eio.Fiber.List.iter

     

       218
       218
       -
             (fun (toolname, content) ->

     

       219
       219
       -
               let new_path = Eio.Path.(fs / tool_dir / toolname) in

     

       220
       220
       -
               Eio.Path.save ~create:(`If_missing 0o755) new_path content)

     

       221
       221
       -
             tools;

     

       222
       222
       -
           tool_dir

     

       223
       223
       -
         in

     

       224
       224
       -
         { store; tool_dir = tools }

     

       225
       225
       -
       

     

       226
       226
       -
       (* Run a command:

     

       227
       227
       -
         

     

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

     

       229
       229
       -
            thing we are building (e.g. the build field and the args field... *)

     

       230
       230
       -
       let exec (config : config) ~stdout fs proc

     

       231
       231
       -
           ((H.Store ((module S), _) : entry H.t), (ctx : ctx)) (entry : entry) =

     

       232
       232
       -
         let build, env, (uid, gid) =

     

       233
       233
       -
           match entry.pre.build with

     

       234
       234
       -
           | Store.Build.Image img ->

     

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

     

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

     

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

     

       238
       238
       -
         in

     

       239
       239
       -
         let command = entry.pre.args in

     

       240
       240
       -
         let hash_entry =

     

       241
       241
       -
           { entry with pre = { entry.pre with build = Build build } }

     

       242
       242
       -
         in

     

       243
       243
       -
         (* Store things under History.pre, this makes it possible to rediscover

     

       244
       244
       -
            the hash for something purely from the arguments needed to execute something

     

       245
       245
       -
            rather than needing, for example, the time it took to execute!

     

       246
       246
       -
       

     

       247
       247
       -
            Also, combine it with previous build step. *)

     

       248
       248
       -
         let new_cid =

     

       249
       249
       -
           Store.cid (Cid.to_string build ^ Repr.to_string History.pre_t hash_entry.pre)

     

       250
       250
       -
         in

     

       251
       251
       -
         let with_rootfs fn =

     

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

     

       253
       253
       -
           else

     

       254
       254
       -
             let diff_path =

     

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

     

       256
       256
       -
             in

     

       257
       257
       -
             Store.Run.with_clone ctx.store ~src:build new_cid diff_path fn

     

       258
       258
       -
         in

     

       259
       259
       -
         with_rootfs @@ function

     

       260
       260
       -
         | `Exists path ->

     

       261
       261
       -
             (* Copy the stdout log to stdout *)

     

       262
       262
       -
             let () =

     

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

     

       264
       264
       -
               Eio.Flow.copy ic stdout

     

       265
       265
       -
             in

     

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

     

       267
       267
       -
             Ok (`Reset c)

     

       268
       268
       -
         | `Build rootfs ->

     

       269
       269
       -
             let spawn sw log =

     

       270
       270
       -
               if config.no_runc then

     

       271
       271
       -
                 (* Experiment Void Process *)

     

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

     

       273
       273
       -
                 let void =

     

       274
       274
       -
                   Void.empty

     

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

     

       276
       276
       -
                   |> Void.cwd entry.pre.cwd

     

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

     

       278
       278
       -
                   |> Void.exec ~env

     

       279
       279
       -
                        [

     

       280
       280
       -
                          config.shell;

     

       281
       281
       -
                          "-c";

     

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

     

       283
       283
       -
                        ]

     

       284
       284
       -
                 in

     

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

     

       286
       286
       -
               else

     

       287
       287
       -
                 let tool_mount : Runc.Json_config.mount =

     

       288
       288
       -
                   {

     

       289
       289
       -
                     ty = `Bind;

     

       290
       290
       -
                     src = ctx.tool_dir;

     

       291
       291
       -
                     dst = "/shelter-tools";

     

       292
       292
       -
                     readonly = true;

     

       293
       293
       -
                   }

     

       294
       294
       -
                 in

     

       295
       295
       -
                 let config =

     

       296
       296
       -
                   Runc.Json_config.

     

       297
       297
       -
                     {

     

       298
       298
       -
                       cwd = entry.pre.cwd;

     

       299
       299
       -
                       argv =

     

       300
       300
       -
                         [

     

       301
       301
       -
                           config.shell;

     

       302
       302
       -
                           "-c";

     

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

     

       304
       304
       -
                         ];

     

       305
       305
       -
                       hostname = "builder";

     

       306
       306
       -
                       network = [ "host" ];

     

       307
       307
       -
                       user = (uid, gid);

     

       308
       308
       -
                       env = entry.pre.env;

     

       309
       309
       -
                       mounts = [ tool_mount ];

     

       310
       310
       -
                       entrypoint = None;

     

       311
       311
       -
                     }

     

       312
       312
       -
                 in

     

       313
       313
       -
                 let env =

     

       314
       314
       -
                   object

     

       315
       315
       -
                     method fs = fs

     

       316
       316
       -
                     method proc = proc

     

       317
       317
       -
                     method stdout = stdout

     

       318
       318
       -
                   end

     

       319
       319
       -
                 in

     

       320
       320
       -
                 `Runc (Runc.spawn ~sw log env config rootfs)

     

       321
       321
       -
             in

     

       322
       322
       -
             let savedTio = Unix.tcgetattr Unix.stdin in

     

       323
       323
       -
             let tio =

     

       324
       324
       -
               {

     

       325
       325
       -
                 savedTio with

     

       326
       326
       -
                 (* input modes *)

     

       327
       327
       -
                 c_ignpar = true;

     

       328
       328
       -
                 c_istrip = false;

     

       329
       329
       -
                 c_inlcr = false;

     

       330
       330
       -
                 c_igncr = false;

     

       331
       331
       -
                 c_ixon = false;

     

       332
       332
       -
                 (* c_ixany = false; *)

     

       333
       333
       -
                 (* c_iuclc = false; *)

     

       334
       334
       -
                 c_ixoff = false;

     

       335
       335
       -
                 (* output modes *)

     

       336
       336
       -
                 c_opost = false;

     

       337
       337
       -
                 (* control modes *)

     

       338
       338
       -
                 c_isig = false;

     

       339
       339
       -
                 c_icanon = false;

     

       340
       340
       -
                 c_echo = false;

     

       341
       341
       -
                 c_echoe = false;

     

       342
       342
       -
                 c_echok = false;

     

       343
       343
       -
                 c_echonl = false;

     

       344
       344
       -
                 (* c_iexten = false; *)

     

       345
       345
       -
       

     

       346
       346
       -
                 (* special characters *)

     

       347
       347
       -
                 c_vmin = 1;

     

       348
       348
       -
                 c_vtime = 0;

     

       349
       349
       -
               }

     

       350
       350
       -
             in

     

       351
       351
       -
             Unix.tcsetattr Unix.stdin TCSADRAIN tio;

     

       352
       352
       -
             let start, res =

     

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

     

       354
       354
       -
               let log =

     

       355
       355
       -
                 Eio.Path.open_out ~sw ~create:(`Or_truncate 0o644)

     

       356
       356
       -
                   Eio.Path.(fs / rootfs / "log")

     

       357
       357
       -
               in

     

       358
       358
       -
               let res = spawn sw log in

     

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

     

       360
       360
       -
               match res with

     

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

     

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

     

       363
       363
       -
             in

     

       364
       364
       -
       

     

       365
       365
       -
             (* restore tio *)

     

       366
       366
       -
             Unix.tcsetattr Unix.stdin TCSADRAIN savedTio;

     

       367
       367
       -
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       374
       374
       -
             in

     

       375
       375
       -
             if res = `Exited 0 then (

     

       376
       376
       -
               (* Extract env *)

     

       377
       377
       -
               let env_path =

     

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

     

       379
       379
       -
               in

     

       380
       380
       -
               let env =

     

       381
       381
       -
                 Eio.Path.(load env_path)

     

       382
       382
       -
                 |> String.split_on_char '\n'

     

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

     

       384
       384
       -
               in

     

       385
       385
       -
               Eio.Path.unlink env_path;

     

       386
       386
       -
               let cwd =

     

       387
       387
       -
                 List.find_map

     

       388
       388
       -
                   (fun v ->

     

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

     

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

     

       391
       391
       -
                     | _ -> None)

     

       392
       392
       -
                   env

     

       393
       393
       -
                 |> Option.value ~default:hash_entry.pre.cwd

     

       394
       394
       -
               in

     

       395
       395
       -
               if entry.pre.mode = RW then

     

       396
       396
       -
                 Ok

     

       397
       397
       -
                   (`Entry

     

       398
       398
       -
                      ( {

     

       399
       399
       -
                          hash_entry with

     

       400
       400
       -
                          History.pre =

     

       401
       401
       -
                            {

     

       402
       402
       -
                              hash_entry.pre with

     

       403
       403
       -
                              build = Build new_cid;

     

       404
       404
       -
                              env;

     

       405
       405
       -
                              cwd;

     

       406
       406
       -
                              user = (uid, gid);

     

       407
       407
       -
                            };

     

       408
       408
       -
                        },

     

       409
       409
       -
                        rootfs ))

     

       410
       410
       -
               else

     

       411
       411
       -
                 Ok

     

       412
       412
       -
                   (`Entry

     

       413
       413
       -
                      ( {

     

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

     

       415
       415
       -
                          post = { hash_entry.post with time };

     

       416
       416
       -
                        },

     

       417
       417
       -
                        rootfs )))

     

       418
       418
       -
             else Shelter.process_error (Eio.Process.Child_error res)

     

       419
       419
       -
       

     

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

     

       421
       421
       -
           new_entry diff =

     

       422
       422
       -
         match new_entry with

     

       423
       423
       -
         | Error e -> Error e

     

       424
       424
       -
         | Ok (`Reset c) -> (

     

       425
       425
       -
             match

     

       426
       426
       -
               S.Hash.unsafe_of_raw_string c |> S.Commit.of_hash (S.repo store)

     

       427
       427
       -
             with

     

       428
       428
       -
             | None ->

     

       429
       429
       -
                 Fmt.epr "Resetting to existing entry failed...\n%!";

     

       430
       430
       -
                 Ok (s, ctx)

     

       431
       431
       -
             | Some c ->

     

       432
       432
       -
                 S.Head.set store c;

     

       433
       433
       -
                 Ok (s, ctx))

     

       434
       434
       -
         | Ok (`Entry (entry, path)) ->

     

       435
       435
       -
             (* Set diff *)

     

       436
       436
       -
             let entry = History.{ entry with post = { entry.post with diff } } in

     

       437
       437
       -
             (* Commit if RW *)

     

       438
       438
       -
             if entry.pre.mode = RW then (

     

       439
       439
       -
               commit

     

       440
       440
       -
                 ~message:("exec " ^ String.concat " " entry.pre.args)

     

       441
       441
       -
                 clock s entry;

     

       442
       442
       -
               (* Save the commit hash for easy restoring later *)

     

       443
       443
       -
               let hash = S.Head.get store |> S.Commit.hash |> S.Hash.to_raw_string in

     

       444
       444
       -
               Eio.Path.save ~create:(`If_missing 0o644)

     

       445
       445
       -
                 Eio.Path.(fs / path / "hash")

     

       446
       446
       -
                 hash);

     

       447
       447
       -
             Ok (s, ctx)

     

       448
       448
       -
       

     

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

     

       450
       450
       -
           proc stdout existing_branch =

     

       451
       451
       -
         let seshes = sessions store in

     

       452
       452
       -
         if not (List.exists (String.equal existing_branch) seshes) then (

     

       453
       453
       -
           Fmt.epr "%s does not exist!" existing_branch;

     

       454
       454
       -
           Ok (store, ctx))

     

       455
       455
       -
         else

     

       456
       456
       -
           let repo = S.repo s in

     

       457
       457
       -
           let onto = S.of_branch repo existing_branch in

     

       458
       458
       -
           match S.lcas ~n:1 s onto with

     

       459
       459
       -
           | Error lcas_error ->

     

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

     

       461
       461
       -
               Ok (store, ctx)

     

       462
       462
       -
           | Ok [ lcas ] -> (

     

       463
       463
       -
               let all_commits = history store in

     

       464
       464
       -
               let lcas_hash = S.Commit.hash lcas |> S.Hash.to_raw_string in

     

       465
       465
       -
               let rec collect = function

     

       466
       466
       -
                 | [] -> []

     

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

     

       468
       468
       -
                 | v :: vs -> v :: collect vs

     

       469
       469
       -
               in

     

       470
       470
       -
               let commits_to_apply = collect all_commits in

     

       471
       471
       -
               match commits_to_apply with

     

       472
       472
       -
               | [] -> Shelter.shell_error ""

     

       473
       473
       -
               | (h, first) :: rest ->

     

       474
       474
       -
                   let _, last_other =

     

       475
       475
       -
                     history (H.Store ((module S), onto)) |> List.hd

     

       476
       476
       -
                   in

     

       477
       477
       -
                   let new_first =

     

       478
       478
       -
                     {

     

       479
       479
       -
                       first with

     

       480
       480
       -
                       pre = { first.pre with build = last_other.pre.build };

     

       481
       481
       -
                     }

     

       482
       482
       -
                   in

     

       483
       483
       -
                   let commits_to_apply = (h, new_first) :: rest in

     

       484
       484
       -
                   (* Now we reset our head to point to the other store's head

     

       485
       485
       -
                  and replay our commits onto it *)

     

       486
       486
       -
                   let other_head = S.Head.get onto in

     

       487
       487
       -
                   S.Head.set s other_head;

     

       488
       488
       -
                   let res =

     

       489
       489
       -
                     List.fold_left

     

       490
       490
       -
                       (fun last (_, (entry : entry)) ->

     

       491
       491
       -
                         match last with

     

       492
       492
       -
                         | Error _ as e -> e

     

       493
       493
       -
                         | Ok (new_store, new_ctx) ->

     

       494
       494
       -
                             let new_entry, diff =

     

       495
       495
       -
                               exec config ~stdout fs proc (new_store, new_ctx) entry

     

       496
       496
       -
                             in

     

       497
       497
       -
                             complete_exec (new_store, new_ctx) clock fs new_entry diff)

     

       498
       498
       -
                       (Ok (H.Store ((module S), s), ctx))

     

       499
       499
       -
                       commits_to_apply

     

       500
       500
       -
                   in

     

       501
       501
       -
                   res)

     

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

     

       503
       503
       -
       

     

       504
       504
       -
       let run (config : config) ~stdout fs clock proc

     

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

     

       506
       506
       -
         | Set_mode mode ->

     

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

     

       508
       508
       -
             commit ~message:"mode change" clock s

     

       509
       509
       -
               { entry with pre = { entry.pre with mode } };

     

       510
       510
       -
             Ok (s, ctx)

     

       511
       511
       -
         | Set_session m -> (

     

       512
       512
       -
             (* Either set the session if the branch exists or create a new branch

     

       513
       513
       -
                from the latest commit of the current branch *)

     

       514
       514
       -
             let sessions = sessions s in

     

       515
       515
       -
             match List.exists (String.equal m) sessions with

     

       516
       516
       -
             | true ->

     

       517
       517
       -
                 let sesh = S.of_branch (S.repo store) m in

     

       518
       518
       -
                 Ok (H.Store ((module S), sesh), ctx)

     

       519
       519
       -
             | false -> (

     

       520
       520
       -
                 match fork s m with

     

       521
       521
       -
                 | Error err ->

     

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

     

       523
       523
       -
                     Ok (s, ctx)

     

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

     

       525
       525
       -
         | Unknown args ->

     

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

     

       527
       527
       -
             Shelter.shell_error (String.concat " " args)

     

       528
       528
       -
         | Info `Current ->

     

       529
       529
       -
             let sessions = sessions s in

     

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

     

       531
       531
       -
             let history = history s in

     

       532
       532
       -
             let pp_commit fmt (hash, msg) =

     

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

     

       534
       534
       -
             in

     

       535
       535
       -
             let repo = S.repo store in

     

       536
       536
       -
             let commits =

     

       537
       537
       -
               List.fold_left

     

       538
       538
       -
                 (fun acc (commit, _) ->

     

       539
       539
       -
                   let commit =

     

       540
       540
       -
                     S.Hash.unsafe_of_raw_string commit

     

       541
       541
       -
                     |> S.Commit.of_hash repo |> Option.get

     

       542
       542
       -
                   in

     

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

     

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

     

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

     

       546
       546
       -
                 [] history

     

       547
       547
       -
             in

     

       548
       548
       -
             let latest =

     

       549
       549
       -
               with_latest

     

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

     

       551
       551
       -
                 s

     

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

     

       553
       553
       -
             in

     

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

     

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

     

       556
       556
       -
               sessions (text `Green) sesh

     

       557
       557
       -
               Fmt.(option string)

     

       558
       558
       -
               latest

     

       559
       559
       -
               Fmt.(vbox ~indent:2 @@ list pp_commit)

     

       560
       560
       -
               commits;

     

       561
       561
       -
             Ok (s, ctx)

     

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

     

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

     

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

     

       565
       565
       -
         | Info `History ->

     

       566
       566
       -
             display_history s;

     

       567
       567
       -
             Ok (s, ctx)

     

       568
       568
       -
         | Exec command -> (

     

       569
       569
       -
             let entry =

     

       570
       570
       -
               with_latest

     

       571
       571
       -
                 ~default:(fun () ->

     

       572
       572
       -
                   History.

     

       573
       573
       -
                     {

     

       574
       574
       -
                       pre =

     

       575
       575
       -
                         {

     

       576
       576
       -
                           mode = Void.RW;

     

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

     

       578
       578
       -
                           args = command;

     

       579
       579
       -
                           (* TODO: extract with fetch *)

     

       580
       580
       -
                           env = [];

     

       581
       581
       -
                           cwd = "/";

     

       582
       582
       -
                           user = (0, 0);

     

       583
       583
       -
                         };

     

       584
       584
       -
                       post = { diff = []; time = 0L };

     

       585
       585
       -
                     })

     

       586
       586
       -
                 s Fun.id

     

       587
       587
       -
             in

     

       588
       588
       -
             let entry = { entry with pre = { entry.pre with args = command } } in

     

       589
       589
       -
             try

     

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

     

       591
       591
       -
               complete_exec (s, ctx) clock fs new_entry diff

     

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

-41

src/lib/shelter/shelter_main.mli

···

       1
       1
       -
       module Store = Store

     

       2
       2
       -
       

     

       3
       3
       -
       module History : sig

     

       4
       4
       -
         type mode = Void.mode

     

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

     

       6
       6
       -
       

     

       7
       7
       -
         type pre = {

     

       8
       8
       -
           mode : Void.mode;

     

       9
       9
       -
           build : Store.Build.t;

     

       10
       10
       -
           args : string list;

     

       11
       11
       -
           env : string list;

     

       12
       12
       -
           cwd : string;

     

       13
       13
       -
           user : int * int;

     

       14
       14
       -
         }

     

       15
       15
       -
         [@@deriving repr]

     

       16
       16
       -
         (** Needed for execution *)

     

       17
       17
       -
       

     

       18
       18
       -
         type t = { pre : pre; post : post } [@@deriving repr]

     

       19
       19
       -
       

     

       20
       20
       -
         include Irmin.Contents.S with type t := t

     

       21
       21
       -
       end

     

       22
       22
       -
       

     

       23
       23
       -
       type action =

     

       24
       24
       -
         (* Change modes *)

     

       25
       25
       -
         | Set_mode of History.mode

     

       26
       26
       -
         (* Fork a new branch from an existing one,

     

       27
       27
       -
            or switch to a branch if it exists *)

     

       28
       28
       -
         | Set_session of string

     

       29
       29
       -
         (* Run a command *)

     

       30
       30
       -
         | Exec of string list

     

       31
       31
       -
         (* Undo the last command *)

     

       32
       32
       -
         | Undo

     

       33
       33
       -
         (* Replay the current branch onto another *)

     

       34
       34
       -
         | Replay of string

     

       35
       35
       -
         (* Display info *)

     

       36
       36
       -
         | Info of [ `Current | `History ]

     

       37
       37
       -
         (* Error state *)

     

       38
       38
       -
         | Unknown of string list

     

       39
       39
       -
       [@@deriving repr]

     

       40
       40
       -
       

     

       41
       41
       -
       include Shelter.Engine.S with type entry = History.t and type action := action

-212

src/lib/shelter/store.ml

···

       1
       1
       -
       (* A store a bit like OBuilder's but a little simplified

     

       2
       2
       -
          for our purposes *)

     

       3
       3
       -
       module Build = struct

     

       4
       4
       -
         type cid = Cid.t

     

       5
       5
       -
       

     

       6
       6
       -
         let cid_of_string s =

     

       7
       7
       -
           match Cid.of_string s with

     

       8
       8
       -
           | Ok v -> v

     

       9
       9
       -
           | Error (`Msg m) -> failwith m

     

       10
       10
       -
           | Error (`Unsupported _) -> failwith "unsupported cid"

     

       11
       11
       -
       

     

       12
       12
       -
         let cid_t = Repr.map Repr.string cid_of_string Cid.to_string

     

       13
       13
       -
       

     

       14
       14
       -
         type t = Image of string | Build of cid [@@deriving repr]

     

       15
       15
       -
       end

     

       16
       16
       -
       

     

       17
       17
       -
       type path = string list

     

       18
       18
       -
       

     

       19
       19
       -
       type t = {

     

       20
       20
       -
         fs : Eio.Fs.dir_ty Eio.Path.t;

     

       21
       21
       -
         proc : Eio_unix.Process.mgr_ty Eio_unix.Process.mgr;

     

       22
       22
       -
         zfs : Zfs.Handle.t;

     

       23
       23
       -
         pool : string;

     

       24
       24
       -
       }

     

       25
       25
       -
       

     

       26
       26
       -
       module Datasets : sig

     

       27
       27
       -
         type dataset = private string

     

       28
       28
       -
         type snapshot = private string

     

       29
       29
       -
       

     

       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

     

       35
       35
       -
       end = struct

     

       36
       36
       -
         type dataset = string

     

       37
       37
       -
         type snapshot = string

     

       38
       38
       -
       

     

       39
       39
       -
         let ( / ) a b = a ^ "/" ^ b

     

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

     

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

     

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

     

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

     

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

     

       45
       45
       -
       end

     

       46
       46
       -
       

     

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

     

       48
       48
       -
         let exists = Zfs.exists t.zfs (dataset :> string) typ in

     

       49
       49
       -
         if not exists then Zfs.create t.zfs dataset typ;

     

       50
       50
       -
         let dataset = Zfs.open_ t.zfs dataset typ in

     

       51
       51
       -
         Fun.protect ~finally:(fun () -> Zfs.close dataset) (fun () -> f dataset)

     

       52
       52
       -
       

     

       53
       53
       -
       let mount_dataset ?(typ = Zfs.Types.dataset) t (dataset : Datasets.dataset) =

     

       54
       54
       -
         match Zfs.is_mounted t.zfs (dataset :> string) with

     

       55
       55
       -
         | Some _ -> ()

     

       56
       56
       -
         | None -> with_dataset ~typ t (dataset :> string) @@ fun d -> Zfs.mount d

     

       57
       57
       -
       

     

       58
       58
       -
       let mount_snapshot ?(typ = Zfs.Types.snapshot) t (dataset : Datasets.snapshot) =

     

       59
       59
       -
         match Zfs.is_mounted t.zfs (dataset :> string) with

     

       60
       60
       -
         | Some _ -> ()

     

       61
       61
       -
         | None -> with_dataset ~typ t (dataset :> string) @@ fun d -> Zfs.mount d

     

       62
       62
       -
       

     

       63
       63
       -
       let unmount_dataset t (dataset : Datasets.dataset) =

     

       64
       64
       -
         match Zfs.is_mounted t.zfs (dataset :> string) with

     

       65
       65
       -
         | None -> ()

     

       66
       66
       -
         | Some _ ->

     

       67
       67
       -
             with_dataset t (dataset :> string) @@ fun d ->

     

       68
       68
       -
             let () = Zfs.unmount d in

     

       69
       69
       -
             ()

     

       70
       70
       -
       

     

       71
       71
       -
       let create_dataset t (dataset : Datasets.dataset) =

     

       72
       72
       -
         with_dataset t (dataset :> string) (fun _ -> ())

     

       73
       73
       -
       

     

       74
       74
       -
       let create_and_mount t (dataset : Datasets.dataset) =

     

       75
       75
       -
         create_dataset t dataset;

     

       76
       76
       -
         mount_dataset t dataset

     

       77
       77
       -
       

     

       78
       78
       -
       let init fs proc pool =

     

       79
       79
       -
         let zfs = Zfs.init () in

     

       80
       80
       -
         Zfs.debug zfs true;

     

       81
       81
       -
         let t =

     

       82
       82
       -
           {

     

       83
       83
       -
             fs :> Eio.Fs.dir_ty Eio.Path.t;

     

       84
       84
       -
             proc :> Eio_unix.Process.mgr_ty Eio_unix.Process.mgr;

     

       85
       85
       -
             zfs;

     

       86
       86
       -
             pool;

     

       87
       87
       -
           }

     

       88
       88
       -
         in

     

       89
       89
       -
         create_and_mount t (Datasets.builds t.pool);

     

       90
       90
       -
         create_and_mount t (Datasets.tools t.pool);

     

       91
       91
       -
         t

     

       92
       92
       -
       

     

       93
       93
       -
       let snapshot t (snap : Datasets.snapshot) =

     

       94
       94
       -
         let exists = Zfs.exists t.zfs (snap :> string) Zfs.Types.snapshot in

     

       95
       95
       -
         if not exists then Zfs.snapshot t.zfs (snap :> string) true

     

       96
       96
       -
       

     

       97
       97
       -
       let destroy t (d : Datasets.dataset) =

     

       98
       98
       -
         with_dataset t (d :> string) @@ fun ds -> Zfs.destroy ds false

     

       99
       99
       -
       

     

       100
       100
       -
       let clone t (snap : Datasets.snapshot) (tgt : Datasets.dataset) =

     

       101
       101
       -
         with_dataset ~typ:Zfs.Types.snapshot t (snap :> string) @@ fun src ->

     

       102
       102
       -
         Zfs.clone src (tgt :> string)

     

       103
       103
       -
       

     

       104
       104
       -
       let read_all fd =

     

       105
       105
       -
         let buf = Buffer.create 10_000 in

     

       106
       106
       -
         let bytes = Bytes.create 10_000 in

     

       107
       107
       -
         let rec loop () =

     

       108
       108
       -
           match Unix.read fd bytes 0 4096 with

     

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

     

       110
       110
       -
           | n ->

     

       111
       111
       -
               Buffer.add_bytes buf (Bytes.sub bytes 0 n);

     

       112
       112
       -
               loop ()

     

       113
       113
       -
         in

     

       114
       114
       -
         loop ()

     

       115
       115
       -
       

     

       116
       116
       -
       let cid s =

     

       117
       117
       -
         let hash =

     

       118
       118
       -
           Multihash_digestif.of_cstruct `Sha2_256 (Cstruct.of_string s)

     

       119
       119
       -
           |> Result.get_ok

     

       120
       120
       -
         in

     

       121
       121
       -
         Cid.v ~version:`Cidv1 ~base:`Base32 ~codec:`Raw ~hash

     

       122
       122
       -
       

     

       123
       123
       -
       let not_empty s = not String.(equal empty s)

     

       124
       124
       -
       

     

       125
       125
       -
       let get_uid_gid ~username rootfs =

     

       126
       126
       -
         let passwd =

     

       127
       127
       -
           Eio.Path.load Eio.Path.(rootfs / "etc" / "passwd")

     

       128
       128
       -
           |> String.split_on_char '\n'

     

       129
       129
       -
           |> List.map (String.split_on_char ':')

     

       130
       130
       -
           |> List.map (List.filter not_empty)

     

       131
       131
       -
         in

     

       132
       132
       -
         List.find_map

     

       133
       133
       -
           (function

     

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

     

       135
       135
       -
                 Some (int_of_string uid, int_of_string gid)

     

       136
       136
       -
             | _ -> None)

     

       137
       137
       -
           passwd

     

       138
       138
       -
       

     

       139
       139
       -
       let fetch t image =

     

       140
       140
       -
         let cid = cid image in

     

       141
       141
       -
         let cids = cid |> Cid.to_string in

     

       142
       142
       -
         let dataset = Datasets.build t.pool cids in

     

       143
       143
       -
         let username = Fetch.get_user t.proc image in

     

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

     

       145
       145
       -
         if Zfs.exists t.zfs (dataset :> string) Zfs.Types.dataset then

     

       146
       146
       -
           ( cid,

     

       147
       147
       -
             Fetch.get_env t.proc image,

     

       148
       148
       -
             get_uid_gid ~username Eio.Path.(dir / "rootfs") )

     

       149
       149
       -
         else (

     

       150
       150
       -
           create_and_mount t dataset;

     

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

     

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

     

       153
       153
       -
           ( cid,

     

       154
       154
       -
             Fetch.get_env t.proc image,

     

       155
       155
       -
             get_uid_gid ~username Eio.Path.(dir / "rootfs") ))

     

       156
       156
       -
       

     

       157
       157
       -
       module Run = struct

     

       158
       158
       -
         let with_build t cid fn =

     

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

     

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

     

       161
       161
       -
           mount_dataset t ds;

     

       162
       162
       -
           fn (`Build ("/" ^ (ds :> string)))

     

       163
       163
       -
       

     

       164
       164
       -
         let with_tool t cid fn =

     

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

     

       166
       166
       -
           mount_dataset t ds;

     

       167
       167
       -
           fn ("/" ^ (ds :> string))

     

       168
       168
       -
       

     

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

     

       170
       170
       -
           let data_fs =

     

       171
       171
       -
             String.sub (data :> string) 0 (String.index (data :> string) '@')

     

       172
       172
       -
           in

     

       173
       173
       -
           let snap_fs =

     

       174
       174
       -
             String.sub (snap :> string) 0 (String.index (snap :> string) '@')

     

       175
       175
       -
           in

     

       176
       176
       -
           if Option.is_none (Zfs.is_mounted t.zfs data_fs) then

     

       177
       177
       -
             with_dataset t data_fs Zfs.mount;

     

       178
       178
       -
           if Option.is_none (Zfs.is_mounted t.zfs snap_fs) then

     

       179
       179
       -
             with_dataset t snap_fs Zfs.mount;

     

       180
       180
       -
           with_dataset ~typ:Zfs.Types.filesystem t data_fs @@ fun zh ->

     

       181
       181
       -
           let () =

     

       182
       182
       -
             try

     

       183
       183
       -
               Eio.Path.with_open_out ~create:(`If_missing 0o644) output

     

       184
       184
       -
               @@ fun flow_fd ->

     

       185
       185
       -
               let eio_fd = Eio_unix.Resource.fd_opt flow_fd in

     

       186
       186
       -
               Eio_unix.Fd.use_exn_opt "zfs-diff" eio_fd @@ function

     

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

     

       188
       188
       -
               | Some fd ->

     

       189
       189
       -
                   Zfs.show_diff zh ~from_:(data :> string) ~to_:(snap :> string) fd

     

       190
       190
       -
             with Unix.Unix_error (Unix.EBADF, _, _) -> ()

     

       191
       191
       -
           in

     

       192
       192
       -
           let diff = Eio.Path.load output in

     

       193
       193
       -
           Diff.of_zfs diff

     

       194
       194
       -
       

     

       195
       195
       -
         let with_clone t ~src new_cid output fn =

     

       196
       196
       -
           let ds = Datasets.build t.pool (Cid.to_string src) in

     

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

     

       198
       198
       -
           let src_snap = Datasets.snapshot ds in

     

       199
       199
       -
           let tgt_snap = Datasets.snapshot tgt in

     

       200
       200
       -
           if Zfs.exists t.zfs (tgt :> string) Zfs.Types.dataset then

     

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

     

       202
       202
       -
           else (

     

       203
       203
       -
             clone t src_snap tgt;

     

       204
       204
       -
             match with_build t new_cid fn with

     

       205
       205
       -
             | Error _ as v ->

     

       206
       206
       -
                 destroy t tgt;

     

       207
       207
       -
                 (v, [])

     

       208
       208
       -
             | Ok _ as v ->

     

       209
       209
       -
                 snapshot t tgt_snap;

     

       210
       210
       -
                 let d = diff t src_snap tgt_snap output in

     

       211
       211
       -
                 (v, d))

     

       212
       212
       -
       end

-1

src/lib/shelter/tools.ml

···

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

-73

src/lib/shelter.ml

···

       1
       1
       -
       module History = History

     

       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
       -
       

     

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

     

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

     

       10
       10
       -
       

     

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

     

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

     

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

     

       14
       14
       -
           let rec loop store ctx exit_code =

     

       15
       15
       -
             let prompt = Engine.prompt exit_code store in

     

       16
       16
       -
             match LNoise.linenoise prompt with

     

       17
       17
       -
             | None -> ()

     

       18
       18
       -
             | Some input -> (

     

       19
       19
       -
                 let action = Engine.action_of_command input in

     

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

     

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

     

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

     

       23
       23
       -
                     loop store ctx exit_code

     

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

     

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

     

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

     

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

     

       31
       31
       -
           in

     

       32
       32
       -
           loop store initial_ctx (`Exited 0)

     

       33
       33
       -
       

     

       34
       34
       -
         let command_file_to_actions cf =

     

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

     

       36
       36
       -
           |> List.map Engine.action_of_command

     

       37
       37
       -
       

     

       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

     

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

     

       41
       41
       -
           let store = Store.main repo in

     

       42
       42
       -
           match command_file with

     

       43
       43
       -
           | Some file -> (

     

       44
       44
       -
               let actions = command_file_to_actions file in

     

       45
       45
       -
               let store = History.Store ((module Store), store) in

     

       46
       46
       -
               let initial_ctx = Engine.init fs proc store in

     

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

     

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

     

       49
       49
       -
                 else

     

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

     

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

     

       55
       55
       -
                       (store, ctx, exit_code)

     

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

     

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

     

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

     

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

     

       63
       63
       -
               in

     

       64
       64
       -
               let _store, _ctx, exit_code =

     

       65
       65
       -
                 List.fold_left folder (store, initial_ctx, `Exited 0) actions

     

       66
       66
       -
               in

     

       67
       67
       -
               match exit_code with

     

       68
       68
       -
               | `Exited 0 -> ()

     

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

     

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

     

       71
       71
       -
                   exit n)

     

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

     

       73
       73
       -
       end

src/shelter/bin/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (public_name shelter)

     

       3
       3
       +
        (package shelter)

     

       4
       4
       +
        (name main)

     

       5
       5
       +
        (libraries shelter fmt.tty shelter.main shelter.passthrough eio void))

+83

src/shelter/bin/main.ml

···

       1
       1
       +
       module History = struct

     

       2
       2
       +
         type t = string

     

       3
       3
       +
       

     

       4
       4
       +
         let t = Repr.string

     

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

     

       6
       6
       +
       end

     

       7
       7
       +
       

     

       8
       8
       +
       module Pass = Shelter.Make (History) (Shelter_passthrough)

     

       9
       9
       +
       module Main = Shelter.Make (Shelter_main.History) (Shelter_main)

     

       10
       10
       +
       

     

       11
       11
       +
       let home = Unix.getenv "HOME"

     

       12
       12
       +
       

     

       13
       13
       +
       let state_dir fs type' =

     

       14
       14
       +
         let path = Eio.Path.(fs / home / ".cache/shelter" / type') in

     

       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
       +
       

     

       24
       24
       +
       (* Command Line *)

     

       25
       25
       +
       open Cmdliner

     

       26
       26
       +
       

     

       27
       27
       +
       let cmd_file =

     

       28
       28
       +
         let doc = "Path to a file containing a series of commands." in

     

       29
       29
       +
         Arg.(

     

       30
       30
       +
           value

     

       31
       31
       +
           & opt (some file) None

     

       32
       32
       +
           & info [ "f"; "file" ] ~docv:"COMMAND_FILE" ~doc)

     

       33
       33
       +
       

     

       34
       34
       +
       let main =

     

       35
       35
       +
         let run config cmd_file =

     

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

     

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

     

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

     

       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

     

       41
       41
       +
         in

     

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

     

       43
       43
       +
         let man =

     

       44
       44
       +
           [

     

       45
       45
       +
             `P

     

       46
       46
       +
               "Shelter is a shell session shim to help control uncertainty when \

     

       47
       47
       +
                working from the terminal";

     

       48
       48
       +
           ]

     

       49
       49
       +
         in

     

       50
       50
       +
         let doc = "Shelter: version-controlled shell sessions" in

     

       51
       51
       +
         let info = Cmd.info ~man ~doc "main" in

     

       52
       52
       +
         (Cmd.v info t, t, info)

     

       53
       53
       +
       

     

       54
       54
       +
       let passthrough =

     

       55
       55
       +
         let run config cmd_file =

     

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

     

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

     

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

     

       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

     

       61
       61
       +
         in

     

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

     

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

     

       64
       64
       +
         Cmd.v info t

     

       65
       65
       +
       

     

       66
       66
       +
       let extract_commands =

     

       67
       67
       +
         let run cmd_file =

     

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

     

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

     

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

     

       71
       71
       +
         in

     

       72
       72
       +
         let t = Term.(const run $ cmd_file) in

     

       73
       73
       +
         let info = Cmd.info "extract" in

     

       74
       74
       +
         Cmd.v info t

     

       75
       75
       +
       

     

       76
       76
       +
       let cmds =

     

       77
       77
       +
         let cmd, term, info = main in

     

       78
       78
       +
         let cmds = [ cmd; passthrough; extract_commands ] in

     

       79
       79
       +
         Cmd.group ~default:term info cmds

     

       80
       80
       +
       

     

       81
       81
       +
       let () =

     

       82
       82
       +
         Fmt_tty.setup_std_outputs ();

     

       83
       83
       +
         exit (Cmd.eval cmds)

src/shelter/lib/dune

···

       1
       1
       +
       (library

     

       2
       2
       +
        (name shelter)

     

       3
       3
       +
        (public_name shelter)

     

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

+50

src/shelter/lib/engine.ml

···

       1
       1
       +
       module type S = sig

     

       2
       2
       +
         type config

     

       3
       3
       +
         (** A configuration *)

     

       4
       4
       +
       

     

       5
       5
       +
         val config_term : config Cmdliner.Term.t

     

       6
       6
       +
         (** A cmdliner term for constructing a config *)

     

       7
       7
       +
       

     

       8
       8
       +
         type action

     

       9
       9
       +
         (** An action to run *)

     

       10
       10
       +
       

     

       11
       11
       +
         val action : action Repr.t

     

       12
       12
       +
         val action_of_command : string -> action

     

       13
       13
       +
       

     

       14
       14
       +
         type entry

     

       15
       15
       +
       

     

       16
       16
       +
         type ctx

     

       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
       +
       

     

       25
       25
       +
         val init :

     

       26
       26
       +
           _ Eio.Path.t ->

     

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

     

       28
       28
       +
           entry History.t ->

     

       29
       29
       +
           ctx

     

       30
       30
       +
         (** [init store] will be called before entering the shell loop. You may wish

     

       31
       31
       +
             to setup history completions etc. with LNoise. *)

     

       32
       32
       +
       

     

       33
       33
       +
         val run :

     

       34
       34
       +
           config ->

     

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

     

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

     

       37
       37
       +
           _ Eio.Time.clock ->

     

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

     

       39
       39
       +
           entry History.t * ctx ->

     

       40
       40
       +
           action ->

     

       41
       41
       +
           ( entry History.t * ctx,

     

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

     

       43
       43
       +
           result

     

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

     

       45
       45
       +
             that can be persisted *)

     

       46
       46
       +
       

     

       47
       47
       +
         val prompt : Eio.Process.exit_status -> entry History.t -> string

     

       48
       48
       +
         (** [prompt previous_exit_code history] generates a prompt from the current

     

       49
       49
       +
             [history] *)

     

       50
       50
       +
       end

+17

src/shelter/lib/history.ml

···

       1
       1
       +
       module type S = sig

     

       2
       2
       +
         type t

     

       3
       3
       +
         (** A single history entry *)

     

       4
       4
       +
       

     

       5
       5
       +
         include Irmin.Contents.S with type t := t

     

       6
       6
       +
       end

     

       7
       7
       +
       

     

       8
       8
       +
       type 'entry t =

     

       9
       9
       +
         | Store :

     

       10
       10
       +
             ((module Irmin.S

     

       11
       11
       +
                 with type t = 'a

     

       12
       12
       +
                  and type Schema.Branch.t = string

     

       13
       13
       +
                  and type Schema.Contents.t = 'entry

     

       14
       14
       +
                  and type Schema.Path.t = string list

     

       15
       15
       +
                  and type Schema.Path.step = string)

     

       16
       16
       +
             * 'a)

     

       17
       17
       +
             -> 'entry t

src/shelter/lib/passthrough/dune

···

       1
       1
       +
       (library

     

       2
       2
       +
        (name shelter_passthrough)

     

       3
       3
       +
        (public_name shelter.passthrough)

     

       4
       4
       +
        (preprocess

     

       5
       5
       +
         (pps ppx_repr))

     

       6
       6
       +
        (libraries shelter))

+64

src/shelter/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
       +
       

     

       7
       7
       +
       type config = unit

     

       8
       8
       +
       

     

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

     

       10
       10
       +
       

     

       11
       11
       +
       type action = Exec of string [@@deriving repr]

     

       12
       12
       +
       

     

       13
       13
       +
       let action = action_t

     

       14
       14
       +
       let action_of_command cmd = Exec cmd

     

       15
       15
       +
       

     

       16
       16
       +
       type entry = string [@@derviving repr]

     

       17
       17
       +
       

     

       18
       18
       +
       let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty

     

       19
       19
       +
       

     

       20
       20
       +
       let prompt _ _ =

     

       21
       21
       +
         Fmt.(styled (`Fg `Red) string) Format.str_formatter "shelter-p> ";

     

       22
       22
       +
         Format.flush_str_formatter ()

     

       23
       23
       +
       

     

       24
       24
       +
       let history_key = [ "history" ]

     

       25
       25
       +
       let key () = history_key @ [ string_of_float @@ Unix.gettimeofday () ]

     

       26
       26
       +
       

     

       27
       27
       +
       type ctx = unit

     

       28
       28
       +
       

     

       29
       29
       +
       let init _ _

     

       30
       30
       +
           (Shelter.History.Store ((module S), store) : entry Shelter.History.t) =

     

       31
       31
       +
         match S.list store history_key with

     

       32
       32
       +
         | [] -> ()

     

       33
       33
       +
         | xs ->

     

       34
       34
       +
             let rec loop acc = function

     

       35
       35
       +
               | `Contents (v, _meta) :: next -> loop (v :: acc) next

     

       36
       36
       +
               | _ :: next -> loop acc next

     

       37
       37
       +
               | [] -> List.rev acc

     

       38
       38
       +
             in

     

       39
       39
       +
             let entries =

     

       40
       40
       +
               loop [] (List.map (fun (_, tree) -> S.Tree.to_concrete tree) xs)

     

       41
       41
       +
             in

     

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

     

       43
       43
       +
       

     

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

     

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

     

       46
       46
       +
              full_store),

     

       47
       47
       +
             () ) (Exec command) =

     

       48
       48
       +
         let info () =

     

       49
       49
       +
           S.Info.v ~message:"shelter" (Eio.Time.now clock |> Int64.of_float)

     

       50
       50
       +
         in

     

       51
       51
       +
         let cmd =

     

       52
       52
       +
           String.split_on_char ' ' command

     

       53
       53
       +
           |> List.filter (fun v -> not (String.equal "" v))

     

       54
       54
       +
         in

     

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

     

       56
       56
       +
         try

     

       57
       57
       +
           let proc = Eio.Process.spawn ~sw proc cmd in

     

       58
       58
       +
           let res = Eio.Process.await proc in

     

       59
       59
       +
           if res = `Exited 0 then (

     

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

     

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

     

       62
       62
       +
             Ok (full_store, ()))

     

       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

src/shelter/lib/passthrough/shelter_passthrough.mli

···

       1
       1
       +
       include Shelter.Engine.S with type entry = string

+57

src/shelter/lib/script.ml

···

       1
       1
       +
       module Cst = Morbig.CST

     

       2
       2
       +
       

     

       3
       3
       +
       let redirect_to_string = function

     

       4
       4
       +
         | Cst.IoRedirect_IoFile { value = io_file; _ } -> (

     

       5
       5
       +
             match io_file with

     

       6
       6
       +
             | Cst.IoFile_Great_FileName

     

       7
       7
       +
                 { value = Cst.Filename_Word { value = Cst.Word (w, _); _ }; _ } ->

     

       8
       8
       +
                 Fmt.str "> %s" w

     

       9
       9
       +
             | Cst.IoFile_DGreat_FileName

     

       10
       10
       +
                 { value = Cst.Filename_Word { value = Cst.Word (w, _); _ }; _ } ->

     

       11
       11
       +
                 Fmt.str ">> %s" w

     

       12
       12
       +
             | _ -> failwith "Redirect Unsupported")

     

       13
       13
       +
         | _ -> failwith "IO Redirect Unsupported"

     

       14
       14
       +
       

     

       15
       15
       +
       let cmd_suffix_to_list s =

     

       16
       16
       +
         let rec loop = function

     

       17
       17
       +
           | Cst.CmdSuffix_Word { value = Cst.Word (s, _); _ } -> [ s ]

     

       18
       18
       +
           | Cst.CmdSuffix_CmdSuffix_Word (suff, { value = Cst.Word (s, _); _ }) ->

     

       19
       19
       +
               s :: loop suff.value

     

       20
       20
       +
           | Cst.CmdSuffix_CmdSuffix_IoRedirect (suff, { value = redirect; _ }) ->

     

       21
       21
       +
               let sf = loop suff.value in

     

       22
       22
       +
               redirect_to_string redirect :: sf

     

       23
       23
       +
           | _ -> failwith "Unsupported!"

     

       24
       24
       +
         in

     

       25
       25
       +
         loop s |> List.rev |> String.concat " "

     

       26
       26
       +
       

     

       27
       27
       +
       let of_cmd (c : Cst.command) =

     

       28
       28
       +
         match c with

     

       29
       29
       +
         | Cst.Command_SimpleCommand simple -> (

     

       30
       30
       +
             match simple.value with

     

       31
       31
       +
             | Cst.SimpleCommand_CmdName

     

       32
       32
       +
                 { value = Cst.CmdName_Word { value = Cst.Word (w, _); _ }; _ } ->

     

       33
       33
       +
                 w

     

       34
       34
       +
             | Cst.SimpleCommand_CmdName_CmdSuffix

     

       35
       35
       +
                 ( { value = Cst.CmdName_Word { value = Cst.Word (w, _); _ }; _ },

     

       36
       36
       +
                   { value = suff; _ } ) ->

     

       37
       37
       +
                 let s = cmd_suffix_to_list suff in

     

       38
       38
       +
                 w ^ " " ^ s

     

       39
       39
       +
             | _ -> failwith "Unsupported")

     

       40
       40
       +
         | _ -> failwith "Unsupported"

     

       41
       41
       +
       

     

       42
       42
       +
       let cmds_to_strings =

     

       43
       43
       +
         let v =

     

       44
       44
       +
           object

     

       45
       45
       +
             inherit [_] Morbig.CSTVisitors.reduce

     

       46
       46
       +
             method zero = []

     

       47
       47
       +
             method plus = List.append

     

       48
       48
       +
             method! visit_command acc c = of_cmd c :: acc

     

       49
       49
       +
           end

     

       50
       50
       +
         in

     

       51
       51
       +
         v#visit_program []

     

       52
       52
       +
       

     

       53
       53
       +
       let to_commands file =

     

       54
       54
       +
         let contents = Eio.Path.load file in

     

       55
       55
       +
         let name = Eio.Path.native_exn file |> Filename.basename in

     

       56
       56
       +
         let ast = Morbig.parse_string name contents in

     

       57
       57
       +
         cmds_to_strings ast

+34

src/shelter/lib/shelter/config.ml

···

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

     

       8
       8
       +
       

     

       9
       9
       +
       let cmdliner =

     

       10
       10
       +
         let open Cmdliner in

     

       11
       11
       +
         let no_diffing =

     

       12
       12
       +
           let doc = "Disable diffing." in

     

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

     

       14
       14
       +
         in

     

       15
       15
       +
         let no_ebpf =

     

       16
       16
       +
           let doc = "Disable eBPF." in

     

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

     

       18
       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

     

       31
       31
       +
         Term.(

     

       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)

+105

src/shelter/lib/shelter/diff.ml

···

       1
       1
       +
       type diff =

     

       2
       2
       +
         | Modified of string

     

       3
       3
       +
         | Created of string

     

       4
       4
       +
         | Renamed of string * string

     

       5
       5
       +
         | Removed of string

     

       6
       6
       +
       [@@deriving repr]

     

       7
       7
       +
       

     

       8
       8
       +
       let path = function

     

       9
       9
       +
         | Modified p -> p

     

       10
       10
       +
         | Created p -> p

     

       11
       11
       +
         | Renamed (p, _) -> p

     

       12
       12
       +
         | Removed p -> p

     

       13
       13
       +
       

     

       14
       14
       +
       type t = diff list [@@deriving repr]

     

       15
       15
       +
       

     

       16
       16
       +
       let truncate_path s =

     

       17
       17
       +
         match Astring.String.cut ~sep:"rootfs" s with Some (_, p) -> p | None -> s

     

       18
       18
       +
       

     

       19
       19
       +
       let parse_row = function

     

       20
       20
       +
         | [ "M"; s ] ->

     

       21
       21
       +
             let path = truncate_path s in

     

       22
       22
       +
             if String.equal path "" then None else Some (Modified path)

     

       23
       23
       +
         | [ "+"; s ] ->

     

       24
       24
       +
             let path = truncate_path s in

     

       25
       25
       +
             if String.equal path "" then None else Some (Created path)

     

       26
       26
       +
         | [ "R"; a; b ] ->

     

       27
       27
       +
             let a_path = truncate_path a in

     

       28
       28
       +
             let b_path = truncate_path b in

     

       29
       29
       +
             Some (Renamed (a_path, b_path))

     

       30
       30
       +
         | [ "-"; s ] ->

     

       31
       31
       +
             let path = truncate_path s in

     

       32
       32
       +
             if String.equal path "" then None else Some (Removed path)

     

       33
       33
       +
         | s ->

     

       34
       34
       +
             Fmt.invalid_arg "Unknown ZFS diff: %a"

     

       35
       35
       +
               (Fmt.list ~sep:Fmt.comma Fmt.string)

     

       36
       36
       +
               s

     

       37
       37
       +
       

     

       38
       38
       +
       let of_zfs s : t =

     

       39
       39
       +
         let lines = String.split_on_char '\n' s in

     

       40
       40
       +
         let tsv =

     

       41
       41
       +
           List.map (String.split_on_char '\t') lines

     

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

     

       43
       43
       +
           |> List.filter (function [] -> false | _ -> true)

     

       44
       44
       +
         in

     

       45
       45
       +
         List.filter_map parse_row tsv

     

       46
       46
       +
       

     

       47
       47
       +
       type tree = Leaf of diff | Dir of string * tree list

     

       48
       48
       +
       

     

       49
       49
       +
       let rec insert modified path_components tree =

     

       50
       50
       +
         match (path_components, tree) with

     

       51
       51
       +
         | [], _ -> tree

     

       52
       52
       +
         | [ file ], nodes ->

     

       53
       53
       +
             if List.exists (function Leaf f -> path f = file | _ -> false) nodes

     

       54
       54
       +
             then nodes

     

       55
       55
       +
             else

     

       56
       56
       +
               let diff =

     

       57
       57
       +
                 match modified with

     

       58
       58
       +
                 | Modified _ -> Modified file

     

       59
       59
       +
                 | Created _ -> Created file

     

       60
       60
       +
                 | Renamed (_, to_) -> Renamed (file, to_)

     

       61
       61
       +
                 | Removed _ -> Removed file

     

       62
       62
       +
               in

     

       63
       63
       +
               Leaf diff :: nodes

     

       64
       64
       +
         | dir :: rest, nodes ->

     

       65
       65
       +
             let rec insert_into_dir acc = function

     

       66
       66
       +
               | [] -> Dir (dir, insert modified rest []) :: List.rev acc

     

       67
       67
       +
               | Dir (name, children) :: tl when name = dir ->

     

       68
       68
       +
                   List.rev_append acc (Dir (name, insert modified rest children) :: tl)

     

       69
       69
       +
               | x :: tl -> insert_into_dir (x :: acc) tl

     

       70
       70
       +
             in

     

       71
       71
       +
             insert_into_dir [] nodes

     

       72
       72
       +
       

     

       73
       73
       +
       let to_tree (diffs : diff list) =

     

       74
       74
       +
         let paths =

     

       75
       75
       +
           List.map (fun v -> (v, String.split_on_char '/' (path v))) diffs

     

       76
       76
       +
         in

     

       77
       77
       +
         List.fold_left (fun acc (m, p) -> insert m p acc) [] paths

     

       78
       78
       +
       

     

       79
       79
       +
       let leaves =

     

       80
       80
       +
         let rec loop acc acc2 = function

     

       81
       81
       +
           | Leaf (Modified v) -> Modified (Filename.concat acc v) :: acc2

     

       82
       82
       +
           | Leaf (Created v) -> Created (Filename.concat acc v) :: acc2

     

       83
       83
       +
           | Leaf (Removed v) -> Removed (Filename.concat acc v) :: acc2

     

       84
       84
       +
           | Leaf (Renamed (r1, r2)) -> Renamed (Filename.concat acc r1, r2) :: acc2

     

       85
       85
       +
           | Dir (p, cs) ->

     

       86
       86
       +
               List.fold_left (fun lvs v -> loop (Filename.concat acc p) lvs v) acc2 cs

     

       87
       87
       +
         in

     

       88
       88
       +
         loop "" []

     

       89
       89
       +
       

     

       90
       90
       +
       let pp_diff fmt = function

     

       91
       91
       +
         | Modified v -> Fmt.(styled (`Fg `Yellow) string) fmt ("~ /" ^ v)

     

       92
       92
       +
         | Created v -> Fmt.(styled (`Fg `Green) string) fmt ("+ /" ^ v)

     

       93
       93
       +
         | Removed v -> Fmt.(styled (`Fg `Red) string) fmt ("- /" ^ v)

     

       94
       94
       +
         | Renamed (v, _) -> Fmt.(styled (`Fg `Magenta) string) fmt ("| /" ^ v)

     

       95
       95
       +
       

     

       96
       96
       +
       let pp fmt diffs =

     

       97
       97
       +
         let tree = to_tree diffs in

     

       98
       98
       +
         let lvs =

     

       99
       99
       +
           List.fold_left (fun acc v -> leaves v @ acc) [] tree

     

       100
       100
       +
           |> List.filter (fun v ->

     

       101
       101
       +
                  not

     

       102
       102
       +
                    (String.starts_with ~prefix:"shelter" (path v)

     

       103
       103
       +
                    || String.starts_with ~prefix:"tmp" (path v)))

     

       104
       104
       +
         in

     

       105
       105
       +
         Fmt.pf fmt "%a" Fmt.(list ~sep:Format.pp_force_newline pp_diff) lvs

+13

src/shelter/lib/shelter/dune

···

       1
       1
       +
       ; (rule

     

       2
       2
       +
       ;   (target opentrace)

     

       3
       3
       +
       ;   (action

     

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

     

       5
       5
       +
       

     

       6
       6
       +
       (library

     

       7
       7
       +
        (name shelter_main)

     

       8
       8
       +
        (public_name shelter.main)

     

       9
       9
       +
        (preprocessor_deps

     

       10
       10
       +
         (file opentrace))

     

       11
       11
       +
        (preprocess

     

       12
       12
       +
         (pps ppx_repr ppx_blob))

     

       13
       13
       +
        (libraries shelter cid void zfs))

+53

src/shelter/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'

     

       29
       29
       +
       

     

       30
       30
       +
       let get_image ~dir ~proc image =

     

       31
       31
       +
         let container_id =

     

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

     

       33
       33
       +
             [ "docker"; "create"; "--"; image ]

     

       34
       34
       +
           |> String.trim

     

       35
       35
       +
         in

     

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

     

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

     

       38
       38
       +
         let () =

     

       39
       39
       +
           Eio.Process.run proc

     

       40
       40
       +
             [ "docker"; "export"; container_id; "-o"; Filename.concat dir_s tar ]

     

       41
       41
       +
         in

     

       42
       42
       +
         Eio.Path.mkdir ~perm:0o777 (dir / "rootfs");

     

       43
       43
       +
         let () =

     

       44
       44
       +
           Eio.Process.run proc

     

       45
       45
       +
             [

     

       46
       46
       +
               "tar";

     

       47
       47
       +
               "-xf";

     

       48
       48
       +
               Filename.concat dir_s tar;

     

       49
       49
       +
               "-C";

     

       50
       50
       +
               Filename.concat dir_s "rootfs";

     

       51
       51
       +
             ]

     

       52
       52
       +
         in

     

       53
       53
       +
         Filename.concat dir_s "rootfs"

src/shelter/lib/shelter/opentrace

This is a binary file and will not be displayed.

+509

src/shelter/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
       +
             "CAP_BPF";

     

       77
       77
       +
             "CAP_PERFMON";

     

       78
       78
       +
             (* BPF operations *)

     

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

     

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

     

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

     

       82
       82
       +
           *)

     

       83
       83
       +
           ]

     

       84
       84
       +
       

     

       85
       85
       +
         let seccomp_syscalls ~fast_sync =

     

       86
       86
       +
           if fast_sync then

     

       87
       87
       +
             [

     

       88
       88
       +
               `Assoc

     

       89
       89
       +
                 [

     

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

     

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

     

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

     

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

     

       94
       94
       +
                   ( "names",

     

       95
       95
       +
                     strings

     

       96
       96
       +
                       [

     

       97
       97
       +
                         "fsync";

     

       98
       98
       +
                         "fdatasync";

     

       99
       99
       +
                         "msync";

     

       100
       100
       +
                         "sync";

     

       101
       101
       +
                         "syncfs";

     

       102
       102
       +
                         "sync_file_range";

     

       103
       103
       +
                       ] );

     

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

     

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

     

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

     

       107
       107
       +
                 ];

     

       108
       108
       +
             ]

     

       109
       109
       +
           else []

     

       110
       110
       +
       

     

       111
       111
       +
         let seccomp_policy =

     

       112
       112
       +
           let fields =

     

       113
       113
       +
             [

     

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

     

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

     

       116
       116
       +
             ]

     

       117
       117
       +
           in

     

       118
       118
       +
           `Assoc fields

     

       119
       119
       +
       

     

       120
       120
       +
         type config = {

     

       121
       121
       +
           cwd : string;

     

       122
       122
       +
           argv : string list;

     

       123
       123
       +
           hostname : string;

     

       124
       124
       +
           network : string list;

     

       125
       125
       +
           user : int * int;

     

       126
       126
       +
           env : string list;

     

       127
       127
       +
           mounts : mount list;

     

       128
       128
       +
           entrypoint : string option;

     

       129
       129
       +
         }

     

       130
       130
       +
       

     

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

     

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

     

       133
       133
       +
           assert (entrypoint = None);

     

       134
       134
       +
           let user =

     

       135
       135
       +
             let uid, gid = user in

     

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

     

       137
       137
       +
           in

     

       138
       138
       +
           let network_ns =

     

       139
       139
       +
             match network with

     

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

     

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

     

       142
       142
       +
             | xs ->

     

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

     

       144
       144
       +
                   Fmt.Dump.(list string)

     

       145
       145
       +
                   xs

     

       146
       146
       +
           in

     

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

     

       148
       148
       +
           `Assoc

     

       149
       149
       +
             [

     

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

     

       151
       151
       +
               ( "process",

     

       152
       152
       +
                 `Assoc

     

       153
       153
       +
                   [

     

       154
       154
       +
                     ("terminal", `Bool true);

     

       155
       155
       +
                     ("user", user);

     

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

     

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

     

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

     

       159
       159
       +
                     ( "capabilities",

     

       160
       160
       +
                       `Assoc

     

       161
       161
       +
                         [

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       170
       170
       +
                         ] );

     

       171
       171
       +
                     ( "rlimits",

     

       172
       172
       +
                       `List

     

       173
       173
       +
                         [

     

       174
       174
       +
                           `Assoc

     

       175
       175
       +
                             [

     

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

     

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

     

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

     

       179
       179
       +
                             ];

     

       180
       180
       +
                           `Assoc

     

       181
       181
       +
                             [

     

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

     

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

     

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

     

       185
       185
       +
                             ];

     

       186
       186
       +
                         ] );

     

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

     

       188
       188
       +
                   ] );

     

       189
       189
       +
               ( "root",

     

       190
       190
       +
                 `Assoc

     

       191
       191
       +
                   [

     

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

     

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

     

       194
       194
       +
                   ] );

     

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

     

       196
       196
       +
               ( "mounts",

     

       197
       197
       +
                 `List

     

       198
       198
       +
                   (mount "/proc"

     

       199
       199
       +
                      ~options:

     

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

     

       201
       201
       +
                      ~ty:"proc" ~src:"proc"

     

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

     

       203
       203
       +
                         ~options:

     

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

     

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

     

       206
       206
       +
                         ~options:

     

       207
       207
       +
                           [

     

       208
       208
       +
                             "nosuid";

     

       209
       209
       +
                             "noexec";

     

       210
       210
       +
                             "newinstance";

     

       211
       211
       +
                             "ptmxmode=0666";

     

       212
       212
       +
                             "mode=0620";

     

       213
       213
       +
                             "gid=5";

     

       214
       214
       +
                             (* tty *)

     

       215
       215
       +
                           ]

     

       216
       216
       +
                    :: mount

     

       217
       217
       +
                         "/sys"

     

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

     

       219
       219
       +
                         ~ty:"sysfs" ~src:"sysfs"

     

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

     

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

     

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

     

       223
       223
       +
                    :: mount "/sys/kernel/debug" ~ty:"debugfs" ~src:"debug"

     

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

     

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

     

       226
       226
       +
                         ~options:

     

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

     

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

     

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

     

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

     

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

     

       232
       232
       +
                    ::

     

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

     

       234
       234
       +
                       [

     

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

     

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

     

       237
       237
       +
                       ]

     

       238
       238
       +
                     else [])

     

       239
       239
       +
                   @ user_mounts mounts) );

     

       240
       240
       +
               ( "linux",

     

       241
       241
       +
                 `Assoc

     

       242
       242
       +
                   [

     

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

     

       244
       244
       +
                     ( "maskedPaths",

     

       245
       245
       +
                       strings

     

       246
       246
       +
                         [

     

       247
       247
       +
                           "/proc/acpi";

     

       248
       248
       +
                           "/proc/asound";

     

       249
       249
       +
                           "/proc/kcore";

     

       250
       250
       +
                           "/proc/keys";

     

       251
       251
       +
                           "/proc/latency_stats";

     

       252
       252
       +
                           "/proc/timer_list";

     

       253
       253
       +
                           "/proc/timer_stats";

     

       254
       254
       +
                           "/proc/sched_debug";

     

       255
       255
       +
                           "/sys/firmware";

     

       256
       256
       +
                           "/proc/scsi";

     

       257
       257
       +
                         ] );

     

       258
       258
       +
                     ( "readonlyPaths",

     

       259
       259
       +
                       strings

     

       260
       260
       +
                         [

     

       261
       261
       +
                           "/proc/bus";

     

       262
       262
       +
                           "/proc/fs";

     

       263
       263
       +
                           "/proc/irq";

     

       264
       264
       +
                           "/proc/sys";

     

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

     

       266
       266
       +
                         ] );

     

       267
       267
       +
                     ("seccomp", seccomp_policy);

     

       268
       268
       +
                   ] );

     

       269
       269
       +
             ]

     

       270
       270
       +
       end

     

       271
       271
       +
       

     

       272
       272
       +
       let next_id = ref 0

     

       273
       273
       +
       

     

       274
       274
       +
       let to_other_sink_as_well ~other

     

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

     

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

     

       277
       277
       +
         let buf = Cstruct.create 4096 in

     

       278
       278
       +
         let copy () ~src =

     

       279
       279
       +
           try

     

       280
       280
       +
             while true do

     

       281
       281
       +
               match Eio.Flow.single_read src buf with

     

       282
       282
       +
               | i ->

     

       283
       283
       +
                   let bufs = [ Cstruct.sub buf 0 i ] in

     

       284
       284
       +
                   Eio.Fiber.both

     

       285
       285
       +
                     (fun () -> Eio.Flow.write other bufs)

     

       286
       286
       +
                     (fun () -> Sink.copy ~src:(Eio.Flow.cstruct_source bufs) t)

     

       287
       287
       +
             done

     

       288
       288
       +
           with End_of_file -> ()

     

       289
       289
       +
         in

     

       290
       290
       +
         let single_write () x =

     

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

     

       292
       292
       +
           Sink.single_write t x

     

       293
       293
       +
         in

     

       294
       294
       +
         let module T = struct

     

       295
       295
       +
           type t = unit

     

       296
       296
       +
       

     

       297
       297
       +
           let single_write = single_write

     

       298
       298
       +
           let copy = copy

     

       299
       299
       +
         end in

     

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

     

       301
       301
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       309
       309
       +
           "127.0.0.1 localhost builder";

     

       310
       310
       +
         let id = string_of_int !next_id in

     

       311
       311
       +
         incr next_id;

     

       312
       312
       +
         let cmd = [ "runc"; "run"; id ] in

     

       313
       313
       +
         let stdout =

     

       314
       314
       +
           to_other_sink_as_well ~other:env#stdout

     

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

     

       316
       316
       +
         in

     

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

     

       318
       318
       +
       

     

       319
       319
       +
       (* 

     

       320
       320
       +
                                        Apache License

     

       321
       321
       +
                                  Version 2.0, January 2004

     

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

     

       323
       323
       +
       

     

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

     

       325
       325
       +
       

     

       326
       326
       +
          1. Definitions.

     

       327
       327
       +
       

     

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

     

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

     

       330
       330
       +
       

     

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

     

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

     

       333
       333
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       341
       341
       +
       

     

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

     

       343
       343
       +
             exercising permissions granted by this License.

     

       344
       344
       +
       

     

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

     

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

     

       347
       347
       +
             source, and configuration files.

     

       348
       348
       +
       

     

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

     

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

     

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

     

       352
       352
       +
             and conversions to other media types.

     

       353
       353
       +
       

     

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

     

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

     

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

     

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

     

       358
       358
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       365
       365
       +
             the Work and Derivative Works thereof.

     

       366
       366
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       378
       378
       +
             excluding communication that is conspicuously marked or otherwise

     

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

     

       380
       380
       +
       

     

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

     

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

     

       383
       383
       +
             subsequently incorporated within the Work.

     

       384
       384
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       391
       391
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       407
       407
       +
       

     

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

     

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

     

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

     

       411
       411
       +
             meet the following conditions:

     

       412
       412
       +
       

     

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

     

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

     

       415
       415
       +
       

     

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

     

       417
       417
       +
                 stating that You changed the files; and

     

       418
       418
       +
       

     

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

     

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

     

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

     

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

     

       423
       423
       +
                 the Derivative Works; and

     

       424
       424
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       439
       439
       +
                 that such additional attribution notices cannot be construed

     

       440
       440
       +
                 as modifying the License.

     

       441
       441
       +
       

     

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

     

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

     

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

     

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

     

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

     

       447
       447
       +
             the conditions stated in this License.

     

       448
       448
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       455
       455
       +
             with Licensor regarding such Contributions.

     

       456
       456
       +
       

     

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

     

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

     

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

     

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

     

       461
       461
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       471
       471
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       483
       483
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       494
       494
       +
       

     

       495
       495
       +
          END OF TERMS AND CONDITIONS

     

       496
       496
       +
       

     

       497
       497
       +
          Copyright 2020 Thomas Leonard

     

       498
       498
       +
       

     

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

     

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

     

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

     

       502
       502
       +
       

     

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

     

       504
       504
       +
       

     

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

     

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

     

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

     

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

     

       509
       509
       +
          limitations under the License. *)

+592

src/shelter/lib/shelter/shelter_main.ml

···

       1
       1
       +
       open Eio

     

       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
       +
       

     

       9
       9
       +
       module History = struct

     

       10
       10
       +
         type mode = Void.mode

     

       11
       11
       +
       

     

       12
       12
       +
         let mode_t =

     

       13
       13
       +
           Repr.map Repr.string

     

       14
       14
       +
             (function

     

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

     

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

     

       17
       17
       +
       

     

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

     

       19
       19
       +
       

     

       20
       20
       +
         type pre = {

     

       21
       21
       +
           mode : mode;

     

       22
       22
       +
           build : Store.Build.t;

     

       23
       23
       +
           args : string list;

     

       24
       24
       +
           env : string list;

     

       25
       25
       +
           cwd : string;

     

       26
       26
       +
           user : int * int;

     

       27
       27
       +
         }

     

       28
       28
       +
         [@@deriving repr]

     

       29
       29
       +
         (** Needed for execution *)

     

       30
       30
       +
       

     

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

     

       32
       32
       +
       

     

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

     

       34
       34
       +
       end

     

       35
       35
       +
       

     

       36
       36
       +
       type config = Config.t

     

       37
       37
       +
       

     

       38
       38
       +
       let config_term = Config.cmdliner

     

       39
       39
       +
       

     

       40
       40
       +
       type entry = History.t

     

       41
       41
       +
       

     

       42
       42
       +
       type action =

     

       43
       43
       +
         (* Change modes *)

     

       44
       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 *)

     

       47
       47
       +
         | Set_session of string

     

       48
       48
       +
         (* Run a command *)

     

       49
       49
       +
         | Exec of string list

     

       50
       50
       +
         (* Undo the last command *)

     

       51
       51
       +
         | Undo

     

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

     

       53
       53
       +
         | Replay of string

     

       54
       54
       +
         (* Display info *)

     

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

     

       56
       56
       +
         (* Error state *)

     

       57
       57
       +
         | Unknown of string list

     

       58
       58
       +
       [@@deriving repr]

     

       59
       59
       +
       

     

       60
       60
       +
       let split_and_remove_empty s =

     

       61
       61
       +
         String.split_on_char ' ' s |> List.filter (fun v -> not (String.equal "" v))

     

       62
       62
       +
       

     

       63
       63
       +
       let action = action_t

     

       64
       64
       +
       

     

       65
       65
       +
       let shelter_action = function

     

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

     

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

     

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

     

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

     

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

     

       71
       71
       +
         | [ "undo" ] -> Undo

     

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

     

       73
       73
       +
         | other -> Unknown other

     

       74
       74
       +
       

     

       75
       75
       +
       let action_of_command cmd =

     

       76
       76
       +
         match split_and_remove_empty cmd with

     

       77
       77
       +
         | "@" :: rest -> shelter_action rest

     

       78
       78
       +
         | args -> Exec args

     

       79
       79
       +
       

     

       80
       80
       +
       let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty

     

       81
       81
       +
       let history_key = [ "history" ]

     

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

     

       83
       83
       +
       

     

       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 ]

     

       93
       93
       +
             in

     

       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

     

       118
       118
       +
       

     

       119
       119
       +
       let with_latest ~default s f =

     

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

     

       121
       121
       +
       

     

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

     

       123
       123
       +
       

     

       124
       124
       +
       let sessions (H.Store ((module S), store) : entry H.t) =

     

       125
       125
       +
         S.Branch.list (S.repo store)

     

       126
       126
       +
       

     

       127
       127
       +
       let commit ~message clock (H.Store ((module S), store) : entry H.t) v =

     

       128
       128
       +
         let info () = S.Info.v ~message (Eio.Time.now clock |> Int64.of_float) in

     

       129
       129
       +
         S.set_exn ~info store (key clock) v

     

       130
       130
       +
       

     

       131
       131
       +
       let which_branch ((H.Store ((module S), session) : entry H.t) as s) =

     

       132
       132
       +
         let branches = sessions s in

     

       133
       133
       +
         let repo = S.repo session in

     

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

     

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

     

       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)

     

       142
       142
       +
       

     

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

     

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

     

       145
       145
       +
         match

     

       146
       146
       +
           List.filter_map (S.Commit.of_hash (S.repo session))

     

       147
       147
       +
           @@ S.Commit.parents (S.Head.get session)

     

       148
       148
       +
         with

     

       149
       149
       +
         | [] -> s

     

       150
       150
       +
         | p :: _ ->

     

       151
       151
       +
             S.Head.set session p;

     

       152
       152
       +
             s

     

       153
       153
       +
       

     

       154
       154
       +
       (* Fork a new session from an existing one *)

     

       155
       155
       +
       let fork (H.Store ((module S), session) : entry H.t) new_branch =

     

       156
       156
       +
         let repo = S.repo session in

     

       157
       157
       +
         match (S.Head.find session, S.Branch.find repo new_branch) with

     

       158
       158
       +
         | _, Some _ ->

     

       159
       159
       +
             Error (new_branch ^ " already exists, try @ session " ^ new_branch)

     

       160
       160
       +
         | None, _ -> Error "Current branch needs at least one commit"

     

       161
       161
       +
         | Some commit, None ->

     

       162
       162
       +
             let new_store = S.of_branch (S.repo session) new_branch in

     

       163
       163
       +
             S.Branch.set repo new_branch commit;

     

       164
       164
       +
             let store = H.Store ((module S), new_store) in

     

       165
       165
       +
             Ok store

     

       166
       166
       +
       

     

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

     

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

     

       169
       169
       +
         let pp_diff fmt d = if d = [] then () else Fmt.pf fmt "\n%a%!" Diff.pp d in

     

       170
       170
       +
         let pp_entry fmt (e : entry) =

     

       171
       171
       +
           Fmt.pf fmt "%-10s %s%a"

     

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

     

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

     

       174
       174
       +
             pp_diff e.post.diff

     

       175
       175
       +
         in

     

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

     

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

     

       178
       178
       +
       

     

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

     

       180
       180
       +
         let head, sesh = which_branch store in

     

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

     

       182
       182
       +
         let prompt () =

     

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

     

       184
       184
       +
           Format.flush_str_formatter ()

     

       185
       185
       +
         in

     

       186
       186
       +
         let pp_head fmt = function

     

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

     

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

     

       189
       189
       +
         in

     

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

     

       191
       191
       +
         let pp_status fmt = function

     

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

     

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

     

       194
       194
       +
           | _ -> Fmt.nop fmt ()

     

       195
       195
       +
         in

     

       196
       196
       +
         let prompt_entry (e : entry) =

     

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

     

       198
       198
       +
             (text `Yellow) "shelter" pp_sesh sesh (text `Red)

     

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

     

       200
       200
       +
           Format.flush_str_formatter ()

     

       201
       201
       +
         in

     

       202
       202
       +
         with_latest store ~default:prompt prompt_entry

     

       203
       203
       +
       

     

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

     

       205
       205
       +
       

     

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

     

       207
       207
       +
       

     

       208
       208
       +
       let init fs proc s =

     

       209
       209
       +
         let store = Store.init fs proc "shelter" in

     

       210
       210
       +
         List.iter

     

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

     

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

     

       213
       213
       +
           (history s);

     

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

     

       215
       215
       +
         let tools =

     

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

     

       217
       217
       +
           Eio.Fiber.List.iter

     

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

     

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

     

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

     

       221
       221
       +
             tools;

     

       222
       222
       +
           tool_dir

     

       223
       223
       +
         in

     

       224
       224
       +
         { store; tool_dir = tools }

     

       225
       225
       +
       

     

       226
       226
       +
       (* Run a command:

     

       227
       227
       +
         

     

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

     

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

     

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

     

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

     

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

     

       233
       233
       +
           match entry.pre.build with

     

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

     

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

     

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

     

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

     

       238
       238
       +
         in

     

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

     

       240
       240
       +
         let hash_entry =

     

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

     

       242
       242
       +
         in

     

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

     

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

     

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

     

       246
       246
       +
       

     

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

     

       248
       248
       +
         let new_cid =

     

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

     

       250
       250
       +
         in

     

       251
       251
       +
         let with_rootfs fn =

     

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

     

       253
       253
       +
           else

     

       254
       254
       +
             let diff_path =

     

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

     

       256
       256
       +
             in

     

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

     

       258
       258
       +
         in

     

       259
       259
       +
         with_rootfs @@ function

     

       260
       260
       +
         | `Exists path ->

     

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

     

       262
       262
       +
             let () =

     

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

     

       264
       264
       +
               Eio.Flow.copy ic stdout

     

       265
       265
       +
             in

     

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

     

       267
       267
       +
             Ok (`Reset c)

     

       268
       268
       +
         | `Build rootfs ->

     

       269
       269
       +
             let spawn sw log =

     

       270
       270
       +
               if config.no_runc then

     

       271
       271
       +
                 (* Experiment Void Process *)

     

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

     

       273
       273
       +
                 let void =

     

       274
       274
       +
                   Void.empty

     

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

     

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

     

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

     

       278
       278
       +
                   |> Void.exec ~env

     

       279
       279
       +
                        [

     

       280
       280
       +
                          config.shell;

     

       281
       281
       +
                          "-c";

     

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

     

       283
       283
       +
                        ]

     

       284
       284
       +
                 in

     

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

     

       286
       286
       +
               else

     

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

     

       288
       288
       +
                   {

     

       289
       289
       +
                     ty = `Bind;

     

       290
       290
       +
                     src = ctx.tool_dir;

     

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

     

       292
       292
       +
                     readonly = true;

     

       293
       293
       +
                   }

     

       294
       294
       +
                 in

     

       295
       295
       +
                 let config =

     

       296
       296
       +
                   Runc.Json_config.

     

       297
       297
       +
                     {

     

       298
       298
       +
                       cwd = entry.pre.cwd;

     

       299
       299
       +
                       argv =

     

       300
       300
       +
                         [

     

       301
       301
       +
                           config.shell;

     

       302
       302
       +
                           "-c";

     

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

     

       304
       304
       +
                         ];

     

       305
       305
       +
                       hostname = "builder";

     

       306
       306
       +
                       network = [ "host" ];

     

       307
       307
       +
                       user = (uid, gid);

     

       308
       308
       +
                       env = entry.pre.env;

     

       309
       309
       +
                       mounts = [ tool_mount ];

     

       310
       310
       +
                       entrypoint = None;

     

       311
       311
       +
                     }

     

       312
       312
       +
                 in

     

       313
       313
       +
                 let env =

     

       314
       314
       +
                   object

     

       315
       315
       +
                     method fs = fs

     

       316
       316
       +
                     method proc = proc

     

       317
       317
       +
                     method stdout = stdout

     

       318
       318
       +
                   end

     

       319
       319
       +
                 in

     

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

     

       321
       321
       +
             in

     

       322
       322
       +
             let savedTio = Unix.tcgetattr Unix.stdin in

     

       323
       323
       +
             let tio =

     

       324
       324
       +
               {

     

       325
       325
       +
                 savedTio with

     

       326
       326
       +
                 (* input modes *)

     

       327
       327
       +
                 c_ignpar = true;

     

       328
       328
       +
                 c_istrip = false;

     

       329
       329
       +
                 c_inlcr = false;

     

       330
       330
       +
                 c_igncr = false;

     

       331
       331
       +
                 c_ixon = false;

     

       332
       332
       +
                 (* c_ixany = false; *)

     

       333
       333
       +
                 (* c_iuclc = false; *)

     

       334
       334
       +
                 c_ixoff = false;

     

       335
       335
       +
                 (* output modes *)

     

       336
       336
       +
                 c_opost = false;

     

       337
       337
       +
                 (* control modes *)

     

       338
       338
       +
                 c_isig = false;

     

       339
       339
       +
                 c_icanon = false;

     

       340
       340
       +
                 c_echo = false;

     

       341
       341
       +
                 c_echoe = false;

     

       342
       342
       +
                 c_echok = false;

     

       343
       343
       +
                 c_echonl = false;

     

       344
       344
       +
                 (* c_iexten = false; *)

     

       345
       345
       +
       

     

       346
       346
       +
                 (* special characters *)

     

       347
       347
       +
                 c_vmin = 1;

     

       348
       348
       +
                 c_vtime = 0;

     

       349
       349
       +
               }

     

       350
       350
       +
             in

     

       351
       351
       +
             Unix.tcsetattr Unix.stdin TCSADRAIN tio;

     

       352
       352
       +
             let start, res =

     

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

     

       354
       354
       +
               let log =

     

       355
       355
       +
                 Eio.Path.open_out ~sw ~create:(`Or_truncate 0o644)

     

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

     

       357
       357
       +
               in

     

       358
       358
       +
               let res = spawn sw log in

     

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

     

       360
       360
       +
               match res with

     

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

     

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

     

       363
       363
       +
             in

     

       364
       364
       +
       

     

       365
       365
       +
             (* restore tio *)

     

       366
       366
       +
             Unix.tcsetattr Unix.stdin TCSADRAIN savedTio;

     

       367
       367
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       374
       374
       +
             in

     

       375
       375
       +
             if res = `Exited 0 then (

     

       376
       376
       +
               (* Extract env *)

     

       377
       377
       +
               let env_path =

     

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

     

       379
       379
       +
               in

     

       380
       380
       +
               let env =

     

       381
       381
       +
                 Eio.Path.(load env_path)

     

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

     

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

     

       384
       384
       +
               in

     

       385
       385
       +
               Eio.Path.unlink env_path;

     

       386
       386
       +
               let cwd =

     

       387
       387
       +
                 List.find_map

     

       388
       388
       +
                   (fun v ->

     

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

     

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

     

       391
       391
       +
                     | _ -> None)

     

       392
       392
       +
                   env

     

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

     

       394
       394
       +
               in

     

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

     

       396
       396
       +
                 Ok

     

       397
       397
       +
                   (`Entry

     

       398
       398
       +
                      ( {

     

       399
       399
       +
                          hash_entry with

     

       400
       400
       +
                          History.pre =

     

       401
       401
       +
                            {

     

       402
       402
       +
                              hash_entry.pre with

     

       403
       403
       +
                              build = Build new_cid;

     

       404
       404
       +
                              env;

     

       405
       405
       +
                              cwd;

     

       406
       406
       +
                              user = (uid, gid);

     

       407
       407
       +
                            };

     

       408
       408
       +
                        },

     

       409
       409
       +
                        rootfs ))

     

       410
       410
       +
               else

     

       411
       411
       +
                 Ok

     

       412
       412
       +
                   (`Entry

     

       413
       413
       +
                      ( {

     

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

     

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

     

       416
       416
       +
                        },

     

       417
       417
       +
                        rootfs )))

     

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

     

       419
       419
       +
       

     

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

     

       421
       421
       +
           new_entry diff =

     

       422
       422
       +
         match new_entry with

     

       423
       423
       +
         | Error e -> Error e

     

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

     

       425
       425
       +
             match

     

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

     

       427
       427
       +
             with

     

       428
       428
       +
             | None ->

     

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

     

       430
       430
       +
                 Ok (s, ctx)

     

       431
       431
       +
             | Some c ->

     

       432
       432
       +
                 S.Head.set store c;

     

       433
       433
       +
                 Ok (s, ctx))

     

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

     

       435
       435
       +
             (* Set diff *)

     

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

     

       437
       437
       +
             (* Commit if RW *)

     

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

     

       439
       439
       +
               commit

     

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

     

       441
       441
       +
                 clock s entry;

     

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

     

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

     

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

     

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

     

       446
       446
       +
                 hash);

     

       447
       447
       +
             Ok (s, ctx)

     

       448
       448
       +
       

     

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

     

       450
       450
       +
           proc stdout existing_branch =

     

       451
       451
       +
         let seshes = sessions store in

     

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

     

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

     

       454
       454
       +
           Ok (store, ctx))

     

       455
       455
       +
         else

     

       456
       456
       +
           let repo = S.repo s in

     

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

     

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

     

       459
       459
       +
           | Error lcas_error ->

     

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

     

       461
       461
       +
               Ok (store, ctx)

     

       462
       462
       +
           | Ok [ lcas ] -> (

     

       463
       463
       +
               let all_commits = history store in

     

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

     

       465
       465
       +
               let rec collect = function

     

       466
       466
       +
                 | [] -> []

     

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

     

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

     

       469
       469
       +
               in

     

       470
       470
       +
               let commits_to_apply = collect all_commits in

     

       471
       471
       +
               match commits_to_apply with

     

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

     

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

     

       474
       474
       +
                   let _, last_other =

     

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

     

       476
       476
       +
                   in

     

       477
       477
       +
                   let new_first =

     

       478
       478
       +
                     {

     

       479
       479
       +
                       first with

     

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

     

       481
       481
       +
                     }

     

       482
       482
       +
                   in

     

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

     

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

     

       485
       485
       +
                  and replay our commits onto it *)

     

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

     

       487
       487
       +
                   S.Head.set s other_head;

     

       488
       488
       +
                   let res =

     

       489
       489
       +
                     List.fold_left

     

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

     

       491
       491
       +
                         match last with

     

       492
       492
       +
                         | Error _ as e -> e

     

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

     

       494
       494
       +
                             let new_entry, diff =

     

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

     

       496
       496
       +
                             in

     

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

     

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

     

       499
       499
       +
                       commits_to_apply

     

       500
       500
       +
                   in

     

       501
       501
       +
                   res)

     

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

     

       503
       503
       +
       

     

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

     

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

     

       506
       506
       +
         | Set_mode mode ->

     

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

     

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

     

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

     

       510
       510
       +
             Ok (s, ctx)

     

       511
       511
       +
         | Set_session m -> (

     

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

     

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

     

       514
       514
       +
             let sessions = sessions s in

     

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

     

       516
       516
       +
             | true ->

     

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

     

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

     

       519
       519
       +
             | false -> (

     

       520
       520
       +
                 match fork s m with

     

       521
       521
       +
                 | Error err ->

     

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

     

       523
       523
       +
                     Ok (s, ctx)

     

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

     

       525
       525
       +
         | Unknown args ->

     

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

     

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

     

       528
       528
       +
         | Info `Current ->

     

       529
       529
       +
             let sessions = sessions s in

     

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

     

       531
       531
       +
             let history = history s in

     

       532
       532
       +
             let pp_commit fmt (hash, msg) =

     

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

     

       534
       534
       +
             in

     

       535
       535
       +
             let repo = S.repo store in

     

       536
       536
       +
             let commits =

     

       537
       537
       +
               List.fold_left

     

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

     

       539
       539
       +
                   let commit =

     

       540
       540
       +
                     S.Hash.unsafe_of_raw_string commit

     

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

     

       542
       542
       +
                   in

     

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

     

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

     

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

     

       546
       546
       +
                 [] history

     

       547
       547
       +
             in

     

       548
       548
       +
             let latest =

     

       549
       549
       +
               with_latest

     

       550
       550
       +
                 ~default:(fun () -> None)

     

       551
       551
       +
                 s

     

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

     

       553
       553
       +
             in

     

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

     

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

     

       556
       556
       +
               sessions (text `Green) sesh

     

       557
       557
       +
               Fmt.(option string)

     

       558
       558
       +
               latest

     

       559
       559
       +
               Fmt.(vbox ~indent:2 @@ list pp_commit)

     

       560
       560
       +
               commits;

     

       561
       561
       +
             Ok (s, ctx)

     

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

     

       563
       563
       +
         | Undo -> Ok (reset_hard s, ctx)

     

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

     

       565
       565
       +
         | Info `History ->

     

       566
       566
       +
             display_history s;

     

       567
       567
       +
             Ok (s, ctx)

     

       568
       568
       +
         | Exec command -> (

     

       569
       569
       +
             let entry =

     

       570
       570
       +
               with_latest

     

       571
       571
       +
                 ~default:(fun () ->

     

       572
       572
       +
                   History.

     

       573
       573
       +
                     {

     

       574
       574
       +
                       pre =

     

       575
       575
       +
                         {

     

       576
       576
       +
                           mode = Void.RW;

     

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

     

       578
       578
       +
                           args = command;

     

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

     

       580
       580
       +
                           env = [];

     

       581
       581
       +
                           cwd = "/";

     

       582
       582
       +
                           user = (0, 0);

     

       583
       583
       +
                         };

     

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

     

       585
       585
       +
                     })

     

       586
       586
       +
                 s Fun.id

     

       587
       587
       +
             in

     

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

     

       589
       589
       +
             try

     

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

     

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

     

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

+41

src/shelter/lib/shelter/shelter_main.mli

···

       1
       1
       +
       module Store = Store

     

       2
       2
       +
       

     

       3
       3
       +
       module History : sig

     

       4
       4
       +
         type mode = Void.mode

     

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

     

       6
       6
       +
       

     

       7
       7
       +
         type pre = {

     

       8
       8
       +
           mode : Void.mode;

     

       9
       9
       +
           build : Store.Build.t;

     

       10
       10
       +
           args : string list;

     

       11
       11
       +
           env : string list;

     

       12
       12
       +
           cwd : string;

     

       13
       13
       +
           user : int * int;

     

       14
       14
       +
         }

     

       15
       15
       +
         [@@deriving repr]

     

       16
       16
       +
         (** Needed for execution *)

     

       17
       17
       +
       

     

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

     

       19
       19
       +
       

     

       20
       20
       +
         include Irmin.Contents.S with type t := t

     

       21
       21
       +
       end

     

       22
       22
       +
       

     

       23
       23
       +
       type action =

     

       24
       24
       +
         (* Change modes *)

     

       25
       25
       +
         | Set_mode of History.mode

     

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

     

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

     

       28
       28
       +
         | Set_session of string

     

       29
       29
       +
         (* Run a command *)

     

       30
       30
       +
         | Exec of string list

     

       31
       31
       +
         (* Undo the last command *)

     

       32
       32
       +
         | Undo

     

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

     

       34
       34
       +
         | Replay of string

     

       35
       35
       +
         (* Display info *)

     

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

     

       37
       37
       +
         (* Error state *)

     

       38
       38
       +
         | Unknown of string list

     

       39
       39
       +
       [@@deriving repr]

     

       40
       40
       +
       

     

       41
       41
       +
       include Shelter.Engine.S with type entry = History.t and type action := action

+212

src/shelter/lib/shelter/store.ml

···

       1
       1
       +
       (* A store a bit like OBuilder's but a little simplified

     

       2
       2
       +
          for our purposes *)

     

       3
       3
       +
       module Build = struct

     

       4
       4
       +
         type cid = Cid.t

     

       5
       5
       +
       

     

       6
       6
       +
         let cid_of_string s =

     

       7
       7
       +
           match Cid.of_string s with

     

       8
       8
       +
           | Ok v -> v

     

       9
       9
       +
           | Error (`Msg m) -> failwith m

     

       10
       10
       +
           | Error (`Unsupported _) -> failwith "unsupported cid"

     

       11
       11
       +
       

     

       12
       12
       +
         let cid_t = Repr.map Repr.string cid_of_string Cid.to_string

     

       13
       13
       +
       

     

       14
       14
       +
         type t = Image of string | Build of cid [@@deriving repr]

     

       15
       15
       +
       end

     

       16
       16
       +
       

     

       17
       17
       +
       type path = string list

     

       18
       18
       +
       

     

       19
       19
       +
       type t = {

     

       20
       20
       +
         fs : Eio.Fs.dir_ty Eio.Path.t;

     

       21
       21
       +
         proc : Eio_unix.Process.mgr_ty Eio_unix.Process.mgr;

     

       22
       22
       +
         zfs : Zfs.Handle.t;

     

       23
       23
       +
         pool : string;

     

       24
       24
       +
       }

     

       25
       25
       +
       

     

       26
       26
       +
       module Datasets : sig

     

       27
       27
       +
         type dataset = private string

     

       28
       28
       +
         type snapshot = private string

     

       29
       29
       +
       

     

       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

     

       35
       35
       +
       end = struct

     

       36
       36
       +
         type dataset = string

     

       37
       37
       +
         type snapshot = string

     

       38
       38
       +
       

     

       39
       39
       +
         let ( / ) a b = a ^ "/" ^ b

     

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

     

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

     

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

     

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

     

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

     

       45
       45
       +
       end

     

       46
       46
       +
       

     

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

     

       48
       48
       +
         let exists = Zfs.exists t.zfs (dataset :> string) typ in

     

       49
       49
       +
         if not exists then Zfs.create t.zfs dataset typ;

     

       50
       50
       +
         let dataset = Zfs.open_ t.zfs dataset typ in

     

       51
       51
       +
         Fun.protect ~finally:(fun () -> Zfs.close dataset) (fun () -> f dataset)

     

       52
       52
       +
       

     

       53
       53
       +
       let mount_dataset ?(typ = Zfs.Types.dataset) t (dataset : Datasets.dataset) =

     

       54
       54
       +
         match Zfs.is_mounted t.zfs (dataset :> string) with

     

       55
       55
       +
         | Some _ -> ()

     

       56
       56
       +
         | None -> with_dataset ~typ t (dataset :> string) @@ fun d -> Zfs.mount d

     

       57
       57
       +
       

     

       58
       58
       +
       let mount_snapshot ?(typ = Zfs.Types.snapshot) t (dataset : Datasets.snapshot) =

     

       59
       59
       +
         match Zfs.is_mounted t.zfs (dataset :> string) with

     

       60
       60
       +
         | Some _ -> ()

     

       61
       61
       +
         | None -> with_dataset ~typ t (dataset :> string) @@ fun d -> Zfs.mount d

     

       62
       62
       +
       

     

       63
       63
       +
       let unmount_dataset t (dataset : Datasets.dataset) =

     

       64
       64
       +
         match Zfs.is_mounted t.zfs (dataset :> string) with

     

       65
       65
       +
         | None -> ()

     

       66
       66
       +
         | Some _ ->

     

       67
       67
       +
             with_dataset t (dataset :> string) @@ fun d ->

     

       68
       68
       +
             let () = Zfs.unmount d in

     

       69
       69
       +
             ()

     

       70
       70
       +
       

     

       71
       71
       +
       let create_dataset t (dataset : Datasets.dataset) =

     

       72
       72
       +
         with_dataset t (dataset :> string) (fun _ -> ())

     

       73
       73
       +
       

     

       74
       74
       +
       let create_and_mount t (dataset : Datasets.dataset) =

     

       75
       75
       +
         create_dataset t dataset;

     

       76
       76
       +
         mount_dataset t dataset

     

       77
       77
       +
       

     

       78
       78
       +
       let init fs proc pool =

     

       79
       79
       +
         let zfs = Zfs.init () in

     

       80
       80
       +
         Zfs.debug zfs true;

     

       81
       81
       +
         let t =

     

       82
       82
       +
           {

     

       83
       83
       +
             fs :> Eio.Fs.dir_ty Eio.Path.t;

     

       84
       84
       +
             proc :> Eio_unix.Process.mgr_ty Eio_unix.Process.mgr;

     

       85
       85
       +
             zfs;

     

       86
       86
       +
             pool;

     

       87
       87
       +
           }

     

       88
       88
       +
         in

     

       89
       89
       +
         create_and_mount t (Datasets.builds t.pool);

     

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

     

       91
       91
       +
         t

     

       92
       92
       +
       

     

       93
       93
       +
       let snapshot t (snap : Datasets.snapshot) =

     

       94
       94
       +
         let exists = Zfs.exists t.zfs (snap :> string) Zfs.Types.snapshot in

     

       95
       95
       +
         if not exists then Zfs.snapshot t.zfs (snap :> string) true

     

       96
       96
       +
       

     

       97
       97
       +
       let destroy t (d : Datasets.dataset) =

     

       98
       98
       +
         with_dataset t (d :> string) @@ fun ds -> Zfs.destroy ds false

     

       99
       99
       +
       

     

       100
       100
       +
       let clone t (snap : Datasets.snapshot) (tgt : Datasets.dataset) =

     

       101
       101
       +
         with_dataset ~typ:Zfs.Types.snapshot t (snap :> string) @@ fun src ->

     

       102
       102
       +
         Zfs.clone src (tgt :> string)

     

       103
       103
       +
       

     

       104
       104
       +
       let read_all fd =

     

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

     

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

     

       107
       107
       +
         let rec loop () =

     

       108
       108
       +
           match Unix.read fd bytes 0 4096 with

     

       109
       109
       +
           | 0 | (exception End_of_file) -> Buffer.contents buf

     

       110
       110
       +
           | n ->

     

       111
       111
       +
               Buffer.add_bytes buf (Bytes.sub bytes 0 n);

     

       112
       112
       +
               loop ()

     

       113
       113
       +
         in

     

       114
       114
       +
         loop ()

     

       115
       115
       +
       

     

       116
       116
       +
       let cid s =

     

       117
       117
       +
         let hash =

     

       118
       118
       +
           Multihash_digestif.of_cstruct `Sha2_256 (Cstruct.of_string s)

     

       119
       119
       +
           |> Result.get_ok

     

       120
       120
       +
         in

     

       121
       121
       +
         Cid.v ~version:`Cidv1 ~base:`Base32 ~codec:`Raw ~hash

     

       122
       122
       +
       

     

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

     

       124
       124
       +
       

     

       125
       125
       +
       let get_uid_gid ~username rootfs =

     

       126
       126
       +
         let passwd =

     

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

     

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

     

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

     

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

     

       131
       131
       +
         in

     

       132
       132
       +
         List.find_map

     

       133
       133
       +
           (function

     

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

     

       135
       135
       +
                 Some (int_of_string uid, int_of_string gid)

     

       136
       136
       +
             | _ -> None)

     

       137
       137
       +
           passwd

     

       138
       138
       +
       

     

       139
       139
       +
       let fetch t image =

     

       140
       140
       +
         let cid = cid image in

     

       141
       141
       +
         let cids = cid |> Cid.to_string in

     

       142
       142
       +
         let dataset = Datasets.build t.pool cids in

     

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

     

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

     

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

     

       146
       146
       +
           ( cid,

     

       147
       147
       +
             Fetch.get_env t.proc image,

     

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

     

       149
       149
       +
         else (

     

       150
       150
       +
           create_and_mount t dataset;

     

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

     

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

     

       153
       153
       +
           ( cid,

     

       154
       154
       +
             Fetch.get_env t.proc image,

     

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

     

       156
       156
       +
       

     

       157
       157
       +
       module Run = struct

     

       158
       158
       +
         let with_build t cid fn =

     

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

     

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

     

       161
       161
       +
           mount_dataset t ds;

     

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

     

       163
       163
       +
       

     

       164
       164
       +
         let with_tool t cid fn =

     

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

     

       166
       166
       +
           mount_dataset t ds;

     

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

     

       168
       168
       +
       

     

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

     

       170
       170
       +
           let data_fs =

     

       171
       171
       +
             String.sub (data :> string) 0 (String.index (data :> string) '@')

     

       172
       172
       +
           in

     

       173
       173
       +
           let snap_fs =

     

       174
       174
       +
             String.sub (snap :> string) 0 (String.index (snap :> string) '@')

     

       175
       175
       +
           in

     

       176
       176
       +
           if Option.is_none (Zfs.is_mounted t.zfs data_fs) then

     

       177
       177
       +
             with_dataset t data_fs Zfs.mount;

     

       178
       178
       +
           if Option.is_none (Zfs.is_mounted t.zfs snap_fs) then

     

       179
       179
       +
             with_dataset t snap_fs Zfs.mount;

     

       180
       180
       +
           with_dataset ~typ:Zfs.Types.filesystem t data_fs @@ fun zh ->

     

       181
       181
       +
           let () =

     

       182
       182
       +
             try

     

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

     

       184
       184
       +
               @@ fun flow_fd ->

     

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

     

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

     

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

     

       188
       188
       +
               | Some fd ->

     

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

     

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

     

       191
       191
       +
           in

     

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

     

       193
       193
       +
           Diff.of_zfs diff

     

       194
       194
       +
       

     

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

     

       196
       196
       +
           let ds = Datasets.build t.pool (Cid.to_string src) in

     

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

     

       198
       198
       +
           let src_snap = Datasets.snapshot ds in

     

       199
       199
       +
           let tgt_snap = Datasets.snapshot tgt in

     

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

     

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

     

       202
       202
       +
           else (

     

       203
       203
       +
             clone t src_snap tgt;

     

       204
       204
       +
             match with_build t new_cid fn with

     

       205
       205
       +
             | Error _ as v ->

     

       206
       206
       +
                 destroy t tgt;

     

       207
       207
       +
                 (v, [])

     

       208
       208
       +
             | Ok _ as v ->

     

       209
       209
       +
                 snapshot t tgt_snap;

     

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

     

       211
       211
       +
                 (v, d))

     

       212
       212
       +
       end

src/shelter/lib/shelter/tools.ml

···

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

+73

src/shelter/lib/shelter.ml

···

       1
       1
       +
       module History = History

     

       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
       +
       

     

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

     

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

     

       10
       10
       +
       

     

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

     

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

     

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

     

       14
       14
       +
           let rec loop store ctx exit_code =

     

       15
       15
       +
             let prompt = Engine.prompt exit_code store in

     

       16
       16
       +
             match LNoise.linenoise prompt with

     

       17
       17
       +
             | None -> ()

     

       18
       18
       +
             | Some input -> (

     

       19
       19
       +
                 let action = Engine.action_of_command input in

     

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

     

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

     

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

     

       23
       23
       +
                     loop store ctx exit_code

     

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

     

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

     

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

     

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

     

       31
       31
       +
           in

     

       32
       32
       +
           loop store initial_ctx (`Exited 0)

     

       33
       33
       +
       

     

       34
       34
       +
         let command_file_to_actions cf =

     

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

     

       36
       36
       +
           |> List.map Engine.action_of_command

     

       37
       37
       +
       

     

       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

     

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

     

       41
       41
       +
           let store = Store.main repo in

     

       42
       42
       +
           match command_file with

     

       43
       43
       +
           | Some file -> (

     

       44
       44
       +
               let actions = command_file_to_actions file in

     

       45
       45
       +
               let store = History.Store ((module Store), store) in

     

       46
       46
       +
               let initial_ctx = Engine.init fs proc store in

     

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

     

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

     

       49
       49
       +
                 else

     

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

     

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

     

       55
       55
       +
                       (store, ctx, exit_code)

     

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

     

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

     

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

     

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

     

       63
       63
       +
               in

     

       64
       64
       +
               let _store, _ctx, exit_code =

     

       65
       65
       +
                 List.fold_left folder (store, initial_ctx, `Exited 0) actions

     

       66
       66
       +
               in

     

       67
       67
       +
               match exit_code with

     

       68
       68
       +
               | `Exited 0 -> ()

     

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

     

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

     

       71
       71
       +
                   exit n)

     

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

     

       73
       73
       +
       end

src/shelterd/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (name main)

     

       3
       3
       +
        (public_name shelterd)

     

       4
       4
       +
        (libraries eio_main shelter_common capnp-rpc-unix index.unix))

+134

src/shelterd/main.ml

···

       1
       1
       +
       open Shelter_common

     

       2
       2
       +
       open Capnp_rpc

     

       3
       3
       +
       

     

       4
       4
       +
       module Admin = struct

     

       5
       5
       +
         module Secret = Capnp_rpc_net.Restorer.Id

     

       6
       6
       +
       

     

       7
       7
       +
         let add_user t restorer name =

     

       8
       8
       +
           match Store.lookup t name with

     

       9
       9
       +
           | Some _ -> Fmt.failwith "User %s already exists!" name

     

       10
       10
       +
           | None -> (

     

       11
       11
       +
               let secret = Store.add_client t name in

     

       12
       12
       +
               match Capnp_rpc_net.Restorer.restore restorer secret with

     

       13
       13
       +
               | Ok v -> v

     

       14
       14
       +
               | Error exn ->

     

       15
       15
       +
                   Fmt.failwith "%a" Capnp_rpc_proto.Error.pp (`Exception exn))

     

       16
       16
       +
       

     

       17
       17
       +
         let remove_user t name = Store.remove t name

     

       18
       18
       +
       

     

       19
       19
       +
         let v sr restorer t =

     

       20
       20
       +
           let add_user = add_user t restorer in

     

       21
       21
       +
           let remove_user = remove_user t in

     

       22
       22
       +
           Admin.v ~add_user ~remove_user sr

     

       23
       23
       +
       end

     

       24
       24
       +
       

     

       25
       25
       +
       open Capnp_rpc_net

     

       26
       26
       +
       

     

       27
       27
       +
       let export ~secrets_dir ~vat ~name id =

     

       28
       28
       +
         let ( / ) = Filename.concat in

     

       29
       29
       +
         let path = secrets_dir / (name ^ ".cap") in

     

       30
       30
       +
         Capnp_rpc_unix.Cap_file.save_service vat id path |> or_fail;

     

       31
       31
       +
         Logs.app (fun f -> f "Wrote capability reference to %S" path)

     

       32
       32
       +
       

     

       33
       33
       +
       let daemon capnp services store secrets_dir =

     

       34
       34
       +
         let restore = Restorer.of_table services in

     

       35
       35
       +
         let admin_id = Capnp_rpc_unix.Vat_config.derived_id capnp "admin" in

     

       36
       36
       +
         let admin =

     

       37
       37
       +
           let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services admin_id in

     

       38
       38
       +
           Admin.v sr restore store

     

       39
       39
       +
         in

     

       40
       40
       +
         Restorer.Table.add services admin_id admin;

     

       41
       41
       +
         Eio.Switch.run @@ fun sw ->

     

       42
       42
       +
         let vat = Capnp_rpc_unix.serve capnp ~sw ~restore in

     

       43
       43
       +
         export ~secrets_dir ~vat ~name:"admin" admin_id;

     

       44
       44
       +
         Logs.app (fun f -> f "shelterd running...");

     

       45
       45
       +
         Eio.Promise.await (Eio.Promise.create () |> fst)

     

       46
       46
       +
       

     

       47
       47
       +
       open Cmdliner

     

       48
       48
       +
       

     

       49
       49
       +
       let setup_log style_renderer level =

     

       50
       50
       +
         Fmt_tty.setup_std_outputs ?style_renderer ();

     

       51
       51
       +
         Logs.set_level level;

     

       52
       52
       +
         Logs.set_reporter (Logs_fmt.reporter ());

     

       53
       53
       +
         ()

     

       54
       54
       +
       

     

       55
       55
       +
       let setup_log =

     

       56
       56
       +
         let docs = Manpage.s_common_options in

     

       57
       57
       +
         Term.(

     

       58
       58
       +
           const setup_log $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ())

     

       59
       59
       +
       

     

       60
       60
       +
       let admin =

     

       61
       61
       +
         Arg.required

     

       62
       62
       +
         @@ Arg.opt Arg.(some file) None

     

       63
       63
       +
         @@ Arg.info ~doc:"Path of the admin capability." ~docv:"ADDR"

     

       64
       64
       +
              [ "c"; "connect" ]

     

       65
       65
       +
       

     

       66
       66
       +
       let username =

     

       67
       67
       +
         Arg.required

     

       68
       68
       +
         @@ Arg.pos 0 Arg.(some string) None

     

       69
       69
       +
         @@ Arg.info ~doc:"The name of the new user to add." ~docv:"NAME" []

     

       70
       70
       +
       

     

       71
       71
       +
       let daemon env =

     

       72
       72
       +
         let doc = "run the shelter daemon" in

     

       73
       73
       +
         let man =

     

       74
       74
       +
           [

     

       75
       75
       +
             `S Manpage.s_description;

     

       76
       76
       +
             `P "The shelter daemon provides a way to run sessions for shelter users.";

     

       77
       77
       +
           ]

     

       78
       78
       +
         in

     

       79
       79
       +
         let info = Cmd.info ~man "daemon" ~doc in

     

       80
       80
       +
         let daemon () capnp =

     

       81
       81
       +
           let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri capnp in

     

       82
       82
       +
           let connect = Obj.magic () in

     

       83
       83
       +
           let load ~validate:_ ~sturdy_ref =

     

       84
       84
       +
             let sr = Capnp_rpc.Sturdy_ref.cast sturdy_ref in

     

       85
       85
       +
             Restorer.grant (User.v sr connect)

     

       86
       86
       +
           in

     

       87
       87
       +
           let loader = Store.create ~make_sturdy ~load "shelter.index" in

     

       88
       88
       +
           Eio.Switch.run @@ fun sw ->

     

       89
       89
       +
           let services = Restorer.Table.of_loader ~sw (module Store) loader in

     

       90
       90
       +
           daemon capnp services loader.store "./secrets"

     

       91
       91
       +
         in

     

       92
       92
       +
         let term =

     

       93
       93
       +
           Term.(const daemon $ setup_log $ Capnp_rpc_unix.Vat_config.cmd env)

     

       94
       94
       +
         in

     

       95
       95
       +
         (Cmd.v info term, term)

     

       96
       96
       +
       

     

       97
       97
       +
       let add_cmd env =

     

       98
       98
       +
         let doc = "add a new client" in

     

       99
       99
       +
         let man =

     

       100
       100
       +
           [

     

       101
       101
       +
             `S Manpage.s_description;

     

       102
       102
       +
             `P

     

       103
       103
       +
               "Add a new client and get a capablity back to use for that client to \

     

       104
       104
       +
                run shelter sessions.";

     

       105
       105
       +
           ]

     

       106
       106
       +
         in

     

       107
       107
       +
         let info = Cmd.info ~man "add" ~doc in

     

       108
       108
       +
         let add () cap_path name =

     

       109
       109
       +
           Eio.Switch.run @@ fun sw ->

     

       110
       110
       +
           let vat = Capnp_rpc_unix.client_only_vat ~sw env#net in

     

       111
       111
       +
           let sr = Capnp_rpc_unix.Cap_file.load vat cap_path |> or_fail in

     

       112
       112
       +
           Capnp_rpc_unix.with_cap_exn sr @@ fun service ->

     

       113
       113
       +
           let cap = Shelter_common.Admin.add_user service name in

     

       114
       114
       +
           Capability.with_ref cap @@ fun client ->

     

       115
       115
       +
           let uri = Persistence.save_exn client in

     

       116
       116
       +
           Fmt.pr "%a" Uri.pp uri

     

       117
       117
       +
         in

     

       118
       118
       +
         Cmd.v info Term.(const add $ setup_log $ admin $ username)

     

       119
       119
       +
       

     

       120
       120
       +
       let () =

     

       121
       121
       +
         Eio_main.run @@ fun env ->

     

       122
       122
       +
         let doc = "Shelterd" in

     

       123
       123
       +
         let man =

     

       124
       124
       +
           [

     

       125
       125
       +
             `S Manpage.s_authors;

     

       126
       126
       +
             `P "Patrick Ferris";

     

       127
       127
       +
             `S Manpage.s_bugs;

     

       128
       128
       +
             `P "Email bug reports to <patrick@sirref.org>.";

     

       129
       129
       +
           ]

     

       130
       130
       +
         in

     

       131
       131
       +
         let info = Cmd.info ~doc ~man "shelterd" in

     

       132
       132
       +
         let daemon_cmd, daemon_term = daemon env in

     

       133
       133
       +
         exit

     

       134
       134
       +
           (Cmd.eval @@ Cmd.group ~default:daemon_term info [ daemon_cmd; add_cmd env ])

+71

src/shelterd/store.ml

···

       1
       1
       +
       (* let () = Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna) *)

     

       2
       2
       +
       let hash_size = 256

     

       3
       3
       +
       

     

       4
       4
       +
       module Fixed_string = Index.Key.String_fixed (struct

     

       5
       5
       +
         let length = 256

     

       6
       6
       +
       end)

     

       7
       7
       +
       

     

       8
       8
       +
       module I = Index_unix.Make (Fixed_string) (Fixed_string) (Index.Cache.Noop)

     

       9
       9
       +
       module Secret = Capnp_rpc_net.Restorer.Id

     

       10
       10
       +
       

     

       11
       11
       +
       type t = {

     

       12
       12
       +
         store : I.t;

     

       13
       13
       +
         make_sturdy : Secret.t -> Uri.t;

     

       14
       14
       +
         load :

     

       15
       15
       +
           validate:(unit -> bool) ->

     

       16
       16
       +
           sturdy_ref:[ `Generic ] Capnp_rpc.Sturdy_ref.t ->

     

       17
       17
       +
           Capnp_rpc_net.Restorer.resolution;

     

       18
       18
       +
       }

     

       19
       19
       +
       

     

       20
       20
       +
       let create ~make_sturdy ~load path =

     

       21
       21
       +
         let store = I.v ~log_size:4096 path in

     

       22
       22
       +
         { store; make_sturdy; load }

     

       23
       23
       +
       

     

       24
       24
       +
       let pad_name name =

     

       25
       25
       +
         let diff = hash_size - String.length name in

     

       26
       26
       +
         if diff >= 0 then String.make diff ' ' ^ name else failwith "Name too long!"

     

       27
       27
       +
       

     

       28
       28
       +
       let add_client t name =

     

       29
       29
       +
         let name = String.trim name in

     

       30
       30
       +
         let secret = Secret.generate () in

     

       31
       31
       +
         let hash = Secret.digest `SHA256 secret in

     

       32
       32
       +
         let name = pad_name name in

     

       33
       33
       +
         let store_secret = pad_name hash in

     

       34
       34
       +
         I.replace t name store_secret;

     

       35
       35
       +
         I.replace t store_secret name;

     

       36
       36
       +
         I.merge t;

     

       37
       37
       +
         secret

     

       38
       38
       +
       

     

       39
       39
       +
       let lookup t name =

     

       40
       40
       +
         let name = pad_name name in

     

       41
       41
       +
         try Some (I.find t name) with Not_found -> None

     

       42
       42
       +
       

     

       43
       43
       +
       let lookup_by_hash t digest =

     

       44
       44
       +
         try Some (I.find t (pad_name digest)) with Not_found -> None

     

       45
       45
       +
       

     

       46
       46
       +
       let remove t name =

     

       47
       47
       +
         let name = String.trim name in

     

       48
       48
       +
         let padded_name = pad_name name in

     

       49
       49
       +
         I.filter t (fun (k, _) -> k = padded_name);

     

       50
       50
       +
         I.merge t

     

       51
       51
       +
       

     

       52
       52
       +
       let list t =

     

       53
       53
       +
         let lst = ref [] in

     

       54
       54
       +
         I.iter (fun k _ -> lst := String.trim k :: !lst) t;

     

       55
       55
       +
         List.stable_sort String.compare !lst

     

       56
       56
       +
       

     

       57
       57
       +
       module type T = Capnp_rpc_net.Restorer.LOADER

     

       58
       58
       +
       

     

       59
       59
       +
       let hash _ = `SHA256

     

       60
       60
       +
       let make_sturdy t = t.make_sturdy

     

       61
       61
       +
       

     

       62
       62
       +
       let validate t digest () =

     

       63
       63
       +
         match lookup t.store digest with None -> false | Some _ -> true

     

       64
       64
       +
       

     

       65
       65
       +
       let load t self digest =

     

       66
       66
       +
         Logs.info (fun f -> f "Looking up %s" digest);

     

       67
       67
       +
         match lookup_by_hash t.store digest with

     

       68
       68
       +
         | None -> Capnp_rpc_net.Restorer.unknown_service_id

     

       69
       69
       +
         | Some _ ->

     

       70
       70
       +
             t.load ~validate:(validate t digest)

     

       71
       71
       +
               ~sturdy_ref:(Capnp_rpc.Sturdy_ref.cast self)

+1 -1

vendor/zfs/src/function_description.ml

···

       91
       91
        
       

     

       92
       92
        
         let is_mounted =

     

       93
       93
        
           foreign "is_mounted"

     

       94
       94
       -
             (Types.libzfs_handle_t @-> string @-> ptr string @-> returning bool)

     

       94
       94
       +
             (Types.libzfs_handle_t @-> string @-> ptr (ptr char) @-> returning bool)

     

       95
       95
        
       

     

       96
       96
        
         let diff =

     

       97
       97
        
           foreign "zfs_show_diffs"

+9 -5

vendor/zfs/src/zfs.ml

···

       112
       112
        
       

     

       113
       113
        
       let exists handle path (type_ : Types.t) = C.Functions.exists handle path type_

     

       114
       114
        
       

     

       115
       115
       +
       let null_string = Ctypes.(coerce (ptr void) (ptr char) null)

     

       116
       116
       +
       

     

       115
       117
        
       let is_mounted handle path =

     

       116
       116
       -
         let where = Ctypes.allocate Ctypes.string "" in

     

       117
       117
       -
         let v = C.Functions.is_mounted handle path where in

     

       118
       118
       -
         if not v then None else Some (Ctypes.( !@ ) where)

     

       119
       119
       -
       

     

       120
       120
       -
       let null_string = Ctypes.(coerce (ptr void) (ptr char) null)

     

       118
       118
       +
         let where = Ctypes.(coerce (ptr void) (ptr char) null) in

     

       119
       119
       +
         let where_ptr = Ctypes.(allocate (ptr char) where) in

     

       120
       120
       +
         let v = C.Functions.is_mounted handle path where_ptr in

     

       121
       121
       +
         if not v then None else

     

       122
       122
       +
           let v = Ctypes.( !@ ) where_ptr in

     

       123
       123
       +
           let s = Ctypes.string_from_ptr v ~length:256 in

     

       124
       124
       +
           Some s

     

       121
       125
        
       

     

       122
       126
        
       let mount ?mount_opts ?(mount_flags = 0) dataset =

     

       123
       127
        
         let res = C.Functions.mount dataset mount_opts mount_flags in

Compare changes