comparing 0812102c1cde06dacb31f60714d6e3d279b136be and fix-build on anil.recoil.org/shelter

.gitignore

+20

README.md

···

       1
       1
        
       shelter

     

       2
       2
        
       -------

     

       3
       3
        
       

     

       4
       4
       +
       A shell session shim that makes exploring from the terminal a little bit easier.

     

       4
       5
        
       

     

       6
       6
       +
       ## Up and running

     

       7
       7
       +
       

     

       8
       8
       +
       To test shelter locally you feel need a ZFS pool, for now you must name it `shelter`.

     

       9
       9
       +
       

     

       10
       10
       +
       ```

     

       11
       11
       +
       $ truncate --size=10G /var/shelter.img

     

       12
       12
       +
       $ sudo zpool create shelter /var/shelter.img 

     

       13
       13
       +
       $ sudo -E dune exec -- shelter

     

       14
       14
       +
       ```

     

       15
       15
       +
       

     

       16
       16
       +
       Sometimes you want to just restart the world.

     

       17
       17
       +
       

     

       18
       18
       +
       ```

     

       19
       19
       +
       $ sudo zpool destroy shelter && sudo zpool create shelter /var/shelter.img && sudo rm -rf ~/.cache/shelter

     

       20
       20
       +
       ```

     

       21
       21
       +
       

     

       22
       22
       +
       ## Shl files

     

       23
       23
       +
       

     

       24
       24
       +
       You can run both the main shelter program and the passthrough mode via a series of actions in a `.shl` file.

-31

cshell.opam

···

       1
       1
       -
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       -
       opam-version: "2.0"

     

       3
       3
       -
       synopsis: "A short synopsis"

     

       4
       4
       -
       description: "A longer description"

     

       5
       5
       -
       maintainer: ["Maintainer Name <maintainer@example.com>"]

     

       6
       6
       -
       authors: ["Author Name <author@example.com>"]

     

       7
       7
       -
       license: "LICENSE"

     

       8
       8
       -
       tags: ["add topics" "to describe" "your" "project"]

     

       9
       9
       -
       homepage: "https://github.com/username/reponame"

     

       10
       10
       -
       doc: "https://url/to/documentation"

     

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

     

       12
       12
       -
       depends: [

     

       13
       13
       -
         "dune" {>= "3.17"}

     

       14
       14
       -
         "ocaml"

     

       15
       15
       -
         "odoc" {with-doc}

     

       16
       16
       -
       ]

     

       17
       17
       -
       build: [

     

       18
       18
       -
         ["dune" "subst"] {dev}

     

       19
       19
       -
         [

     

       20
       20
       -
           "dune"

     

       21
       21
       -
           "build"

     

       22
       22
       -
           "-p"

     

       23
       23
       -
           name

     

       24
       24
       -
           "-j"

     

       25
       25
       -
           jobs

     

       26
       26
       -
           "@install"

     

       27
       27
       -
           "@runtest" {with-test}

     

       28
       28
       -
           "@doc" {with-doc}

     

       29
       29
       -
         ]

     

       30
       30
       -
       ]

     

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

+20 -11

dune-project

···

       1
       1
        
       (lang dune 3.17)

     

       2
       2
        
       

     

       3
       3
       -
       (name cshell)

     

       3
       3
       +
       (name shelter)

     

       4
       4
        
       

     

       5
       5
        
       (generate_opam_files true)

     

       6
       6
        
       

     

       7
       7
        
       (source

     

       8
       8
        
        (github username/reponame))

     

       9
       9
        
       

     

       10
       10
       -
       (authors "Author Name <author@example.com>")

     

       10
       10
       +
       (authors "Patrick Ferris <patrick@sirref.org>")

     

       11
       11
        
       

     

       12
       12
       -
       (maintainers "Maintainer Name <maintainer@example.com>")

     

       12
       12
       +
       (maintainers "Patrick Ferris <patrick@sirref.org>")

     

       13
       13
        
       

     

       14
       14
       -
       (license LICENSE)

     

       14
       14
       +
       (license ISC)

     

       15
       15
        
       

     

       16
       16
       -
       (documentation https://url/to/documentation)

     

       17
       16
        
       

     

       18
       17
        
       (package

     

       19
       19
       -
        (name cshell)

     

       20
       20
       -
        (synopsis "A short synopsis")

     

       21
       21
       -
        (description "A longer description")

     

       22
       22
       -
        (depends ocaml)

     

       18
       18
       +
        (name shelter)

     

       19
       19
       +
        (synopsis "Shelter from the Storm")

     

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

     

       21
       21
       +
        (depends

     

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

     

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

     

       24
       24
       +
          eio_posix

     

       25
       25
       +
          zfs

     

       26
       26
       +
          cid

     

       27
       27
       +
          ppx_repr

     

       28
       28
       +
          irmin-git

     

       29
       29
       +
          morbig

     

       30
       30
       +
          ppx_blob

     

       31
       31
       +
          cmdliner

     

       32
       32
       +
         )

     

       23
       33
        
        (tags

     

       24
       24
       -
         ("add topics" "to describe" your project)))

     

       34
       34
       +
         ("shell")))

     

       25
       35
        
       

     

       26
       26
       -
       ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/reference/dune-project/index.html

+47

shelter.opam

···

       1
       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       +
       opam-version: "2.0"

     

       3
       3
       +
       synopsis: "Shelter from the Storm"

     

       4
       4
       +
       description: "A shell session shim to help you explore!"

     

       5
       5
       +
       maintainer: ["Patrick Ferris <patrick@sirref.org>"]

     

       6
       6
       +
       authors: ["Patrick Ferris <patrick@sirref.org>"]

     

       7
       7
       +
       license: "ISC"

     

       8
       8
       +
       tags: ["shell"]

     

       9
       9
       +
       homepage: "https://github.com/username/reponame"

     

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

     

       11
       11
       +
       depends: [

     

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

     

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

     

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

     

       15
       15
       +
         "eio_posix"

     

       16
       16
       +
         "zfs"

     

       17
       17
       +
         "cid"

     

       18
       18
       +
         "ppx_repr"

     

       19
       19
       +
         "irmin-git"

     

       20
       20
       +
         "morbig"

     

       21
       21
       +
         "ppx_blob"

     

       22
       22
       +
         "cmdliner"

     

       23
       23
       +
         "odoc" {with-doc}

     

       24
       24
       +
       ]

     

       25
       25
       +
       build: [

     

       26
       26
       +
         ["dune" "subst"] {dev}

     

       27
       27
       +
         [

     

       28
       28
       +
           "dune"

     

       29
       29
       +
           "build"

     

       30
       30
       +
           "-p"

     

       31
       31
       +
           name

     

       32
       32
       +
           "-j"

     

       33
       33
       +
           jobs

     

       34
       34
       +
           "@install"

     

       35
       35
       +
           "@runtest" {with-test}

     

       36
       36
       +
           "@doc" {with-doc}

     

       37
       37
       +
         ]

     

       38
       38
       +
       ]

     

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

     

       40
       40
       +
       pin-depends:[

     

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

     

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

     

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

     

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

     

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

     

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

     

       47
       47
       +
       ]

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
       4
       +
         [ "irmin.dev"    "git+https://github.com/mirage/irmin#eio" ]

     

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

     

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

     

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

     

       8
       8
       +
       ]

+3 -3

src/bin/dune

···

       1
       1
        
       (executable

     

       2
       2
       -
        (public_name cshell)

     

       3
       3
       -
        (package cshell)

     

       2
       2
       +
        (public_name shelter)

     

       3
       3
       +
        (package shelter)

     

       4
       4
        
        (name main)

     

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

     

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

+67 -11

src/bin/main.ml

···

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

     

       6
       6
        
       end

     

       7
       7
        
       

     

       8
       8
       -
       module Pass = Cshell.Make (History) (Cshell_passthrough)

     

       9
       9
       -
       module Shelter = Cshell.Make (Shelter.History) (Shelter)

     

       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/cshell" / type') in

     

       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
       +
       

     

       18
       81
        
       let () =

     

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

     

       20
       82
        
         Fmt_tty.setup_std_outputs ();

     

       21
       21
       -
         match Sys.argv.(1) with

     

       22
       22
       -
         | "shelter" ->

     

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

     

       24
       24
       -
             Shelter.main env#fs env#clock env#process_mgr dir

     

       25
       25
       -
         | _ | (exception Invalid_argument _) ->

     

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

     

       27
       27
       -
             Pass.main env#fs env#clock env#process_mgr dir

     

       83
       83
       +
         exit (Cmd.eval cmds)

-33

src/lib/cshell.ml

···

       1
       1
       -
       module History = History

     

       2
       2
       -
       module Engine = Engine

     

       3
       3
       -
       

     

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

     

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

     

       6
       6
       -
       

     

       7
       7
       -
         let run fs clock proc store =

     

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

     

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

     

       10
       10
       -
           let rec loop store ctx exit_code =

     

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

     

       12
       12
       -
             match LNoise.linenoise prompt with

     

       13
       13
       -
             | None -> ()

     

       14
       14
       -
             | Some input -> (

     

       15
       15
       -
                 let action = Engine.action_of_command input in

     

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

     

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

     

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

     

       19
       19
       -
                     loop store ctx exit_code

     

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

     

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

     

       22
       22
       -
                     loop store ctx (`Exited 127)

     

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

     

       24
       24
       -
           in

     

       25
       25
       -
           loop store initial_ctx (`Exited 0)

     

       26
       26
       -
       

     

       27
       27
       -
         let main fs clock proc directory =

     

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

     

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

     

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

     

       31
       31
       -
           let store = Store.main repo in

     

       32
       32
       -
           run fs clock proc store

     

       33
       33
       -
       end

+3 -3

src/lib/dune

···

       1
       1
        
       (library

     

       2
       2
       -
        (name cshell)

     

       3
       3
       -
        (public_name cshell)

     

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

     

       2
       2
       +
        (name shelter)

     

       3
       3
       +
        (public_name shelter)

     

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

+17 -2

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
       +
       

     

       2
       8
        
         type action

     

       3
       9
        
         (** An action to run *)

     

       4
       10
        
       

     
···

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

     

       12
       18
        
             shell *)

     

       13
       19
        
       

     

       20
       20
       +
         type error

     

       21
       21
       +
         (** Shell specific errors *)

     

       22
       22
       +
       

     

       23
       23
       +
         val pp_error : error Fmt.t

     

       24
       24
       +
       

     

       14
       25
        
         val init :

     

       15
       26
        
           _ Eio.Path.t ->

     

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

     
···

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

     

       21
       32
        
       

     

       22
       33
        
         val run :

     

       23
       23
       -
           _ Eio.Path.t ->

     

       34
       34
       +
           config ->

     

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

     

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

     

       24
       37
        
           _ Eio.Time.clock ->

     

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

     

       26
       39
        
           entry History.t * ctx ->

     

       27
       40
        
           action ->

     

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

     

       41
       41
       +
           ( entry History.t * ctx,

     

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

     

       43
       43
       +
           result

     

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

     

       30
       45
        
             that can be persisted *)

     

       31
       46

-56

src/lib/passthrough/cshell_passthrough.ml

···

       1
       1
       -
       open Eio

     

       2
       2
       -
       

     

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

     

       4
       4
       -
       

     

       5
       5
       -
       let action = action_t

     

       6
       6
       -
       let action_of_command cmd = Exec cmd

     

       7
       7
       -
       

     

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

     

       9
       9
       -
       

     

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

     

       11
       11
       -
       

     

       12
       12
       -
       let prompt _ _ =

     

       13
       13
       -
         Fmt.(styled (`Fg `Red) string) Format.str_formatter "cshell> ";

     

       14
       14
       -
         Format.flush_str_formatter ()

     

       15
       15
       -
       

     

       16
       16
       -
       let history_key = [ "history" ]

     

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

     

       18
       18
       -
       

     

       19
       19
       -
       type ctx = unit

     

       20
       20
       -
       

     

       21
       21
       -
       let init _ _ (Cshell.History.Store ((module S), store) : entry Cshell.History.t)

     

       22
       22
       -
           =

     

       23
       23
       -
         match S.list store history_key with

     

       24
       24
       -
         | [] -> ()

     

       25
       25
       -
         | xs ->

     

       26
       26
       -
             let rec loop acc = function

     

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

     

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

     

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

     

       30
       30
       -
             in

     

       31
       31
       -
             let entries =

     

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

     

       33
       33
       -
             in

     

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

     

       35
       35
       -
       

     

       36
       36
       -
       let run _fs clock proc

     

       37
       37
       -
           ( ((Cshell.History.Store ((module S), store) : entry Cshell.History.t) as

     

       38
       38
       -
              full_store),

     

       39
       39
       -
             () ) (Exec command) =

     

       40
       40
       -
         let info () =

     

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

     

       42
       42
       -
         in

     

       43
       43
       -
         let cmd =

     

       44
       44
       -
           String.split_on_char ' ' command

     

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

     

       46
       46
       -
         in

     

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

     

       48
       48
       -
         try

     

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

     

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

     

       51
       51
       -
           if res = `Exited 0 then (

     

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

     

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

     

       54
       54
       -
             Ok (full_store, ()))

     

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

     

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

-1

src/lib/passthrough/cshell_passthrough.mli

···

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

+3 -3

src/lib/passthrough/dune

···

       1
       1
        
       (library

     

       2
       2
       -
        (name cshell_passthrough)

     

       3
       3
       -
        (public_name cshell.passthrough)

     

       2
       2
       +
        (name shelter_passthrough)

     

       3
       3
       +
        (public_name shelter.passthrough)

     

       4
       4
        
        (preprocess

     

       5
       5
        
         (pps ppx_repr))

     

       6
       6
       -
        (libraries cshell))

     

       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

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)

+11 -4

src/lib/shelter/dune

···

       1
       1
       +
       ; (rule

     

       2
       2
       +
       ;   (target opentrace)

     

       3
       3
       +
       ;   (action

     

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

     

       5
       5
       +
       

     

       1
       6
        
       (library

     

       2
       2
       -
        (name shelter)

     

       3
       3
       -
        (public_name cshell.shelter)

     

       7
       7
       +
        (name shelter_main)

     

       8
       8
       +
        (public_name shelter.main)

     

       9
       9
       +
        (preprocessor_deps

     

       10
       10
       +
         (file opentrace))

     

       4
       11
        
        (preprocess

     

       5
       5
       -
         (pps ppx_repr))

     

       6
       6
       -
        (libraries cshell cid void zfs))

     

       12
       12
       +
         (pps ppx_repr ppx_blob))

     

       13
       13
       +
        (libraries shelter cid void zfs))

+29 -2

src/lib/shelter/fetch.ml

···

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

     

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

     

       3
       3
       +
       

     

       4
       4
       +
       let get_user proc image =

     

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

     

       6
       6
       +
           [

     

       7
       7
       +
             "docker";

     

       8
       8
       +
             "image";

     

       9
       9
       +
             "inspect";

     

       10
       10
       +
             "--format";

     

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

     

       12
       12
       +
             "--";

     

       13
       13
       +
             image;

     

       14
       14
       +
           ]

     

       15
       15
       +
         |> String.trim

     

       16
       16
       +
       

     

       17
       17
       +
       let get_env proc image =

     

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

     

       19
       19
       +
           [

     

       20
       20
       +
             "docker";

     

       21
       21
       +
             "image";

     

       22
       22
       +
             "inspect";

     

       23
       23
       +
             "--format";

     

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

     

       25
       25
       +
             "--";

     

       26
       26
       +
             image;

     

       27
       27
       +
           ]

     

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

     

       2
       29
        
       

     

       3
       30
        
       let get_image ~dir ~proc image =

     

       4
       31
        
         let container_id =

     
···

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

     

       7
       34
        
           |> String.trim

     

       8
       35
        
         in

     

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

     

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

     

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

     

       11
       38
        
         let () =

     

       12
       39
        
           Eio.Process.run proc

     
···

       18
       45
        
             [

     

       19
       46
        
               "tar";

     

       20
       47
        
               "-xf";

     

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

     

       48
       48
       +
               Filename.concat dir_s tar;

     

       22
       49
        
               "-C";

     

       23
       50
        
               Filename.concat dir_s "rootfs";

     

       24
       51
        
             ]

src/lib/shelter/opentrace

This is a binary file and will not be displayed.

+498

src/lib/shelter/runc.ml

···

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

     

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

     

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

     

       4
       4
       +
       

     

       5
       5
       +
       type config = { fast_sync : bool }

     

       6
       6
       +
       

     

       7
       7
       +
       let get_machine () =

     

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

     

       9
       9
       +
         let arch = input_line ch in

     

       10
       10
       +
         match Unix.close_process_in ch with

     

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

     

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

     

       13
       13
       +
       

     

       14
       14
       +
       let get_arches () =

     

       15
       15
       +
         if Sys.unix then

     

       16
       16
       +
           match get_machine () with

     

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

     

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

     

       19
       19
       +
           | _ -> []

     

       20
       20
       +
         else []

     

       21
       21
       +
       

     

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

     

       23
       23
       +
       

     

       24
       24
       +
       module Json_config = struct

     

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

     

       26
       26
       +
           `Assoc

     

       27
       27
       +
             [

     

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

     

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

     

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

     

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

     

       32
       32
       +
             ]

     

       33
       33
       +
       

     

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

     

       35
       35
       +
       

     

       36
       36
       +
         let user_mounts =

     

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

     

       38
       38
       +
           assert (ty = `Bind);

     

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

     

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

     

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

     

       42
       42
       +
       

     

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

     

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

     

       45
       45
       +
       

     

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

     

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

     

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

     

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

     

       50
       50
       +
         let default_linux_caps =

     

       51
       51
       +
           [

     

       52
       52
       +
             "CAP_CHOWN";

     

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

     

       54
       54
       +
             "CAP_DAC_OVERRIDE";

     

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

     

       56
       56
       +
             "CAP_FSETID";

     

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

     

       58
       58
       +
             "CAP_FOWNER";

     

       59
       59
       +
             (* Bypass permission checks. *)

     

       60
       60
       +
             "CAP_MKNOD";

     

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

     

       62
       62
       +
             "CAP_SETGID";

     

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

     

       64
       64
       +
             "CAP_SETUID";

     

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

     

       66
       66
       +
             "CAP_SETFCAP";

     

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

     

       68
       68
       +
             "CAP_SETPCAP";

     

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

     

       70
       70
       +
             "CAP_SYS_CHROOT";

     

       71
       71
       +
             (* Use chroot. *)

     

       72
       72
       +
             "CAP_KILL";

     

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

     

       74
       74
       +
             "CAP_AUDIT_WRITE"

     

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

     

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

     

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

     

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

     

       79
       79
       +
           *);

     

       80
       80
       +
           ]

     

       81
       81
       +
       

     

       82
       82
       +
         let seccomp_syscalls ~fast_sync =

     

       83
       83
       +
           if fast_sync then

     

       84
       84
       +
             [

     

       85
       85
       +
               `Assoc

     

       86
       86
       +
                 [

     

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

     

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

     

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

     

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

     

       91
       91
       +
                   ( "names",

     

       92
       92
       +
                     strings

     

       93
       93
       +
                       [

     

       94
       94
       +
                         "fsync";

     

       95
       95
       +
                         "fdatasync";

     

       96
       96
       +
                         "msync";

     

       97
       97
       +
                         "sync";

     

       98
       98
       +
                         "syncfs";

     

       99
       99
       +
                         "sync_file_range";

     

       100
       100
       +
                       ] );

     

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

     

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

     

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

     

       104
       104
       +
                 ];

     

       105
       105
       +
             ]

     

       106
       106
       +
           else []

     

       107
       107
       +
       

     

       108
       108
       +
         let seccomp_policy =

     

       109
       109
       +
           let fields =

     

       110
       110
       +
             [

     

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

     

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

     

       113
       113
       +
             ]

     

       114
       114
       +
           in

     

       115
       115
       +
           `Assoc fields

     

       116
       116
       +
       

     

       117
       117
       +
         type config = {

     

       118
       118
       +
           cwd : string;

     

       119
       119
       +
           argv : string list;

     

       120
       120
       +
           hostname : string;

     

       121
       121
       +
           network : string list;

     

       122
       122
       +
           user : int * int;

     

       123
       123
       +
           env : string list;

     

       124
       124
       +
           mounts : mount list;

     

       125
       125
       +
           entrypoint : string option;

     

       126
       126
       +
         }

     

       127
       127
       +
       

     

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

     

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

     

       130
       130
       +
           assert (entrypoint = None);

     

       131
       131
       +
           let user =

     

       132
       132
       +
             let uid, gid = user in

     

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

     

       134
       134
       +
           in

     

       135
       135
       +
           let network_ns =

     

       136
       136
       +
             match network with

     

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

     

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

     

       139
       139
       +
             | xs ->

     

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

     

       141
       141
       +
                   Fmt.Dump.(list string)

     

       142
       142
       +
                   xs

     

       143
       143
       +
           in

     

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

     

       145
       145
       +
           `Assoc

     

       146
       146
       +
             [

     

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

     

       148
       148
       +
               ( "process",

     

       149
       149
       +
                 `Assoc

     

       150
       150
       +
                   [

     

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

     

       152
       152
       +
                     ("user", user);

     

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

     

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

     

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

     

       156
       156
       +
                     ( "capabilities",

     

       157
       157
       +
                       `Assoc

     

       158
       158
       +
                         [

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       167
       167
       +
                         ] );

     

       168
       168
       +
                     ( "rlimits",

     

       169
       169
       +
                       `List

     

       170
       170
       +
                         [

     

       171
       171
       +
                           `Assoc

     

       172
       172
       +
                             [

     

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

     

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

     

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

     

       176
       176
       +
                             ];

     

       177
       177
       +
                           `Assoc

     

       178
       178
       +
                             [

     

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

     

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

     

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

     

       182
       182
       +
                             ];

     

       183
       183
       +
                         ] );

     

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

     

       185
       185
       +
                   ] );

     

       186
       186
       +
               ( "root",

     

       187
       187
       +
                 `Assoc

     

       188
       188
       +
                   [

     

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

     

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

     

       191
       191
       +
                   ] );

     

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

     

       193
       193
       +
               ( "mounts",

     

       194
       194
       +
                 `List

     

       195
       195
       +
                   (mount "/proc"

     

       196
       196
       +
                      ~options:

     

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

     

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

     

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

     

       200
       200
       +
                         ~options:

     

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

     

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

     

       203
       203
       +
                         ~options:

     

       204
       204
       +
                           [

     

       205
       205
       +
                             "nosuid";

     

       206
       206
       +
                             "noexec";

     

       207
       207
       +
                             "newinstance";

     

       208
       208
       +
                             "ptmxmode=0666";

     

       209
       209
       +
                             "mode=0620";

     

       210
       210
       +
                             "gid=5";

     

       211
       211
       +
                             (* tty *)

     

       212
       212
       +
                           ]

     

       213
       213
       +
                    :: mount

     

       214
       214
       +
                         "/sys"

     

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

     

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

     

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

     

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

     

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

     

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

     

       221
       221
       +
                         ~options:

     

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

     

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

     

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

     

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

     

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

     

       227
       227
       +
                    ::

     

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

     

       229
       229
       +
                       [

     

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

     

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

     

       232
       232
       +
                       ]

     

       233
       233
       +
                     else [])

     

       234
       234
       +
                   @ user_mounts mounts) );

     

       235
       235
       +
               ( "linux",

     

       236
       236
       +
                 `Assoc

     

       237
       237
       +
                   [

     

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

     

       239
       239
       +
                     ( "maskedPaths",

     

       240
       240
       +
                       strings

     

       241
       241
       +
                         [

     

       242
       242
       +
                           "/proc/acpi";

     

       243
       243
       +
                           "/proc/asound";

     

       244
       244
       +
                           "/proc/kcore";

     

       245
       245
       +
                           "/proc/keys";

     

       246
       246
       +
                           "/proc/latency_stats";

     

       247
       247
       +
                           "/proc/timer_list";

     

       248
       248
       +
                           "/proc/timer_stats";

     

       249
       249
       +
                           "/proc/sched_debug";

     

       250
       250
       +
                           "/sys/firmware";

     

       251
       251
       +
                           "/proc/scsi";

     

       252
       252
       +
                         ] );

     

       253
       253
       +
                     ( "readonlyPaths",

     

       254
       254
       +
                       strings

     

       255
       255
       +
                         [

     

       256
       256
       +
                           "/proc/bus";

     

       257
       257
       +
                           "/proc/fs";

     

       258
       258
       +
                           "/proc/irq";

     

       259
       259
       +
                           "/proc/sys";

     

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

     

       261
       261
       +
                         ] );

     

       262
       262
       +
                     ("seccomp", seccomp_policy);

     

       263
       263
       +
                   ] );

     

       264
       264
       +
             ]

     

       265
       265
       +
       end

     

       266
       266
       +
       

     

       267
       267
       +
       let next_id = ref 0

     

       268
       268
       +
       

     

       269
       269
       +
       let to_other_sink_as_well ~other

     

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

     

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

     

       272
       272
       +
         let copy_buf = Buffer.create 128 in

     

       273
       273
       +
         let copy () ~src =

     

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

     

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

     

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

     

       277
       277
       +
           Buffer.clear copy_buf

     

       278
       278
       +
         in

     

       279
       279
       +
         let single_write () x =

     

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

     

       281
       281
       +
           Sink.single_write t x

     

       282
       282
       +
         in

     

       283
       283
       +
         let module T = struct

     

       284
       284
       +
           type t = unit

     

       285
       285
       +
       

     

       286
       286
       +
           let single_write = single_write

     

       287
       287
       +
           let copy = copy

     

       288
       288
       +
         end in

     

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

     

       290
       290
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       298
       298
       +
           "127.0.0.1 localhost builder";

     

       299
       299
       +
         let id = string_of_int !next_id in

     

       300
       300
       +
         incr next_id;

     

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

     

       302
       302
       +
         let stdout =

     

       303
       303
       +
           to_other_sink_as_well ~other:env#stdout

     

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

     

       305
       305
       +
         in

     

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

     

       307
       307
       +
       

     

       308
       308
       +
       (* 

     

       309
       309
       +
                                        Apache License

     

       310
       310
       +
                                  Version 2.0, January 2004

     

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

     

       312
       312
       +
       

     

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

     

       314
       314
       +
       

     

       315
       315
       +
          1. Definitions.

     

       316
       316
       +
       

     

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

     

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

     

       319
       319
       +
       

     

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

     

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

     

       322
       322
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       330
       330
       +
       

     

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

     

       332
       332
       +
             exercising permissions granted by this License.

     

       333
       333
       +
       

     

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

     

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

     

       336
       336
       +
             source, and configuration files.

     

       337
       337
       +
       

     

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

     

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

     

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

     

       341
       341
       +
             and conversions to other media types.

     

       342
       342
       +
       

     

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

     

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

     

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

     

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

     

       347
       347
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       354
       354
       +
             the Work and Derivative Works thereof.

     

       355
       355
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       367
       367
       +
             excluding communication that is conspicuously marked or otherwise

     

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

     

       369
       369
       +
       

     

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

     

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

     

       372
       372
       +
             subsequently incorporated within the Work.

     

       373
       373
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       380
       380
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       396
       396
       +
       

     

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

     

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

     

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

     

       400
       400
       +
             meet the following conditions:

     

       401
       401
       +
       

     

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

     

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

     

       404
       404
       +
       

     

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

     

       406
       406
       +
                 stating that You changed the files; and

     

       407
       407
       +
       

     

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

     

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

     

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

     

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

     

       412
       412
       +
                 the Derivative Works; and

     

       413
       413
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       428
       428
       +
                 that such additional attribution notices cannot be construed

     

       429
       429
       +
                 as modifying the License.

     

       430
       430
       +
       

     

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

     

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

     

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

     

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

     

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

     

       436
       436
       +
             the conditions stated in this License.

     

       437
       437
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

       444
       444
       +
             with Licensor regarding such Contributions.

     

       445
       445
       +
       

     

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

     

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

     

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

     

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

     

       450
       450
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       460
       460
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       472
       472
       +
       

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       483
       483
       +
       

     

       484
       484
       +
          END OF TERMS AND CONDITIONS

     

       485
       485
       +
       

     

       486
       486
       +
          Copyright 2020 Thomas Leonard

     

       487
       487
       +
       

     

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

     

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

     

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

     

       491
       491
       +
       

     

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

     

       493
       493
       +
       

     

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

     

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

     

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

     

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

     

       498
       498
       +
          limitations under the License. *)

-292

src/lib/shelter/shelter.ml

···

       1
       1
       -
       open Eio

     

       2
       2
       -
       module Store = Store

     

       3
       3
       -
       module H = Cshell.History

     

       4
       4
       -
       

     

       5
       5
       -
       module History = struct

     

       6
       6
       -
         type mode = Void.mode

     

       7
       7
       -
       

     

       8
       8
       -
         let mode_t =

     

       9
       9
       -
           Repr.map Repr.string

     

       10
       10
       -
             (function

     

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

     

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

     

       13
       13
       -
       

     

       14
       14
       -
         type t = {

     

       15
       15
       -
           mode : mode;

     

       16
       16
       -
           build : Store.Build.t;

     

       17
       17
       -
           args : string list;

     

       18
       18
       -
           time : int64;

     

       19
       19
       -
           diff : Diff.t;

     

       20
       20
       -
         }

     

       21
       21
       -
         [@@deriving repr]

     

       22
       22
       -
       

     

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

     

       24
       24
       -
       end

     

       25
       25
       -
       

     

       26
       26
       -
       type entry = History.t

     

       27
       27
       -
       

     

       28
       28
       -
       type action =

     

       29
       29
       -
         | Set_mode of History.mode

     

       30
       30
       -
         | Set_session of string

     

       31
       31
       -
         | Exec of string list

     

       32
       32
       -
         | Info

     

       33
       33
       -
         | Undo

     

       34
       34
       -
         | Fork of string

     

       35
       35
       -
         | Replay of string

     

       36
       36
       -
         | Unknown of string list

     

       37
       37
       -
         | History

     

       38
       38
       -
       [@@deriving repr]

     

       39
       39
       -
       

     

       40
       40
       -
       let split_and_remove_empty s =

     

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

     

       42
       42
       -
       

     

       43
       43
       -
       let action = action_t

     

       44
       44
       -
       

     

       45
       45
       -
       let shelter_action = function

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

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

     

       54
       54
       -
         | other -> Unknown other

     

       55
       55
       -
       

     

       56
       56
       -
       let action_of_command cmd =

     

       57
       57
       -
         match split_and_remove_empty cmd with

     

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

     

       59
       59
       -
         | args -> Exec args

     

       60
       60
       -
       

     

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

     

       62
       62
       -
       let history_key = [ "history" ]

     

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

     

       64
       64
       -
       

     

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

     

       66
       66
       -
         match S.list store history_key with

     

       67
       67
       -
         | [] -> []

     

       68
       68
       -
         | xs ->

     

       69
       69
       -
             let rec loop acc = function

     

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

     

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

     

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

     

       73
       73
       -
             in

     

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

     

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

     

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

     

       77
       77
       -
             |> List.rev

     

       78
       78
       -
       

     

       79
       79
       -
       let with_latest ~default s f =

     

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

     

       81
       81
       -
       

     

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

     

       83
       83
       -
       

     

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

     

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

     

       86
       86
       -
       

     

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

     

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

     

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

     

       90
       90
       -
       

     

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

     

       92
       92
       -
         let branches = sessions s in

     

       93
       93
       -
         let repo = S.repo session in

     

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

     

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

     

       96
       96
       -
         List.assoc_opt head heads

     

       97
       97
       -
       

     

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

     

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

     

       100
       100
       -
         match

     

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

     

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

     

       103
       103
       -
         with

     

       104
       104
       -
         | [] -> s

     

       105
       105
       -
         | p :: _ ->

     

       106
       106
       -
             S.Head.set session p;

     

       107
       107
       -
             s

     

       108
       108
       -
       

     

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

     

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

     

       111
       111
       -
         let repo = S.repo session in

     

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

     

       113
       113
       -
         | _, Some _ ->

     

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

     

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

     

       116
       116
       -
         | Some commit, None ->

     

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

     

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

     

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

     

       120
       120
       -
             Ok store

     

       121
       121
       -
       

     

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

     

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

     

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

     

       125
       125
       -
         let content c =

     

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

     

       127
       127
       -
         in

     

       128
       128
       -
         let pp_diff fmt d =

     

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

     

       130
       130
       -
         in

     

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

     

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

     

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

     

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

     

       135
       135
       -
         in

     

       136
       136
       -
         let linearize =

     

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

     

       138
       138
       -
         in

     

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

     

       140
       140
       -
       

     

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

     

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

     

       143
       143
       -
         let prompt () =

     

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

     

       145
       145
       -
           Format.flush_str_formatter ()

     

       146
       146
       -
         in

     

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

     

       148
       148
       -
         let pp_status fmt = function

     

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

     

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

     

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

     

       152
       152
       -
         in

     

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

     

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

     

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

     

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

     

       157
       157
       -
           Format.flush_str_formatter ()

     

       158
       158
       -
         in

     

       159
       159
       -
         with_latest store ~default:prompt prompt_entry

     

       160
       160
       -
       

     

       161
       161
       -
       type ctx = Store.t

     

       162
       162
       -
       

     

       163
       163
       -
       let init fs proc s =

     

       164
       164
       -
         let store = Store.init fs proc "test-pool" in

     

       165
       165
       -
         List.iter

     

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

     

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

     

       168
       168
       -
           (list s);

     

       169
       169
       -
         store

     

       170
       170
       -
       

     

       171
       171
       -
       let run _fs clock _proc (((H.Store ((module S), store) : entry H.t) as s), ctx)

     

       172
       172
       -
           = function

     

       173
       173
       -
         | Set_mode mode ->

     

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

     

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

     

       176
       176
       -
             Ok (s, ctx)

     

       177
       177
       -
         | Set_session m ->

     

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

     

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

     

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

     

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

     

       182
       182
       -
             Ok (new_full_store, ctx)

     

       183
       183
       -
         | Unknown args ->

     

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

     

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

     

       186
       186
       -
             Ok (s, ctx)

     

       187
       187
       -
         | Info ->

     

       188
       188
       -
             let sessions = sessions s in

     

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

     

       190
       190
       -
             let history = S.history store in

     

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

     

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

     

       193
       193
       -
             in

     

       194
       194
       -
             let commits =

     

       195
       195
       -
               S.History.fold_vertex

     

       196
       196
       -
                 (fun commit acc ->

     

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

     

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

     

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

     

       200
       200
       -
                 history []

     

       201
       201
       -
             in

     

       202
       202
       -
             let latest =

     

       203
       203
       -
               with_latest

     

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

     

       205
       205
       -
                 s

     

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

     

       207
       207
       -
             in

     

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

     

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

     

       210
       210
       -
               sessions (text `Green) sesh

     

       211
       211
       -
               Fmt.(option string)

     

       212
       212
       -
               latest

     

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

     

       214
       214
       -
               commits;

     

       215
       215
       -
             Ok (s, ctx)

     

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

     

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

     

       218
       218
       -
         | Fork new_branch -> (

     

       219
       219
       -
             match fork s new_branch with

     

       220
       220
       -
             | Error err ->

     

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

     

       222
       222
       -
                 Ok (s, ctx)

     

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

     

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

     

       225
       225
       -
         | History ->

     

       226
       226
       -
             display_history s;

     

       227
       227
       -
             Ok (s, ctx)

     

       228
       228
       -
         | Exec command -> (

     

       229
       229
       -
             let entry =

     

       230
       230
       -
               with_latest

     

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

     

       232
       232
       -
                   History.

     

       233
       233
       -
                     {

     

       234
       234
       -
                       mode = Void.RW;

     

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

     

       236
       236
       -
                       args = command;

     

       237
       237
       -
                       time = 0L;

     

       238
       238
       -
                       diff = [];

     

       239
       239
       -
                     })

     

       240
       240
       -
                 s

     

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

     

       242
       242
       -
             in

     

       243
       243
       -
             let build =

     

       244
       244
       -
               match entry.build with

     

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

     

       246
       246
       -
               | Store.Build.Build cid -> cid

     

       247
       247
       -
             in

     

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

     

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

     

       250
       250
       -
             let with_rootfs fn =

     

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

     

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

     

       253
       253
       -
             in

     

       254
       254
       -
             try

     

       255
       255
       -
               let new_entry, diff =

     

       256
       256
       -
                 with_rootfs @@ fun rootfs ->

     

       257
       257
       -
                 let void =

     

       258
       258
       -
                   Void.empty

     

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

     

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

     

       261
       261
       -
                 in

     

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

     

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

     

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

     

       265
       265
       -
                 let res =

     

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

     

       267
       267
       -
                 in

     

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

     

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

     

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

     

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

     

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

     

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

     

       274
       274
       -
                 in

     

       275
       275
       -
                 if res = `Exited 0 then

     

       276
       276
       -
                   if entry.mode = RW then

     

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

     

       278
       278
       -
                   else Ok hash_entry

     

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

     

       280
       280
       -
               in

     

       281
       281
       -
               match new_entry with

     

       282
       282
       -
               | Error e -> Error e

     

       283
       283
       -
               | Ok entry ->

     

       284
       284
       -
                   (* Set diff *)

     

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

     

       286
       286
       -
                   (* Commit if RW *)

     

       287
       287
       -
                   if entry.mode = RW then

     

       288
       288
       -
                     commit

     

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

     

       290
       290
       -
                       clock s entry;

     

       291
       291
       -
                   Ok (s, ctx)

     

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

-16

src/lib/shelter/shelter.mli

···

       1
       1
       -
       module Store = Store

     

       2
       2
       -
       

     

       3
       3
       -
       module History : sig

     

       4
       4
       -
         type t = {

     

       5
       5
       -
           mode : Void.mode;

     

       6
       6
       -
           build : Store.Build.t;

     

       7
       7
       -
           args : string list;

     

       8
       8
       -
           time : int64;

     

       9
       9
       -
           diff : Diff.t;

     

       10
       10
       -
         }

     

       11
       11
       -
         [@@deriving repr]

     

       12
       12
       -
       

     

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

     

       14
       14
       -
       end

     

       15
       15
       -
       

     

       16
       16
       -
       include Cshell.Engine.S with type entry = History.t

+560

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 =

     

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

     

       171
       171
       +
         in

     

       172
       172
       +
         let pp_entry fmt (e : entry) =

     

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

     

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

     

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

     

       176
       176
       +
             pp_diff e.post.diff

     

       177
       177
       +
         in

     

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

     

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

     

       180
       180
       +
       

     

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

     

       182
       182
       +
         let head, sesh = which_branch store in

     

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

     

       184
       184
       +
         let prompt () =

     

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

     

       186
       186
       +
           Format.flush_str_formatter ()

     

       187
       187
       +
         in

     

       188
       188
       +
         let pp_head fmt = function

     

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

     

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

     

       191
       191
       +
         in

     

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

     

       193
       193
       +
         let pp_status fmt = function

     

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

     

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

     

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

     

       197
       197
       +
         in

     

       198
       198
       +
         let prompt_entry (e : entry) =

     

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

     

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

     

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

     

       202
       202
       +
           Format.flush_str_formatter ()

     

       203
       203
       +
         in

     

       204
       204
       +
         with_latest store ~default:prompt prompt_entry

     

       205
       205
       +
       

     

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

     

       207
       207
       +
       

     

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

     

       209
       209
       +
       

     

       210
       210
       +
       let init fs proc s =

     

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

     

       212
       212
       +
         List.iter

     

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

     

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

     

       215
       215
       +
           (history s);

     

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

     

       217
       217
       +
         let tools =

     

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

     

       219
       219
       +
           Eio.Fiber.List.iter

     

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

     

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

     

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

     

       223
       223
       +
             tools;

     

       224
       224
       +
           tool_dir

     

       225
       225
       +
         in

     

       226
       226
       +
         { store; tool_dir = tools }

     

       227
       227
       +
       

     

       228
       228
       +
       (* Run a command:

     

       229
       229
       +
         

     

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

     

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

     

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

     

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

     

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

     

       235
       235
       +
           match entry.pre.build with

     

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

     

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

     

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

     

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

     

       240
       240
       +
         in

     

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

     

       242
       242
       +
         let hash_entry =

     

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

     

       244
       244
       +
         in

     

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

     

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

     

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

     

       248
       248
       +
       

     

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

     

       250
       250
       +
         let new_cid =

     

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

     

       252
       252
       +
         in

     

       253
       253
       +
         let with_rootfs fn =

     

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

     

       255
       255
       +
           else

     

       256
       256
       +
             let diff_path =

     

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

     

       258
       258
       +
             in

     

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

     

       260
       260
       +
         in

     

       261
       261
       +
         with_rootfs @@ function

     

       262
       262
       +
         | `Exists path ->

     

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

     

       264
       264
       +
             let () =

     

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

     

       266
       266
       +
               Eio.Flow.copy ic stdout

     

       267
       267
       +
             in

     

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

     

       269
       269
       +
             Ok (`Reset c)

     

       270
       270
       +
         | `Build rootfs ->

     

       271
       271
       +
             let spawn sw log =

     

       272
       272
       +
               if config.no_runc then

     

       273
       273
       +
                 (* Experiment Void Process *)

     

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

     

       275
       275
       +
                 let void =

     

       276
       276
       +
                   Void.empty

     

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

     

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

     

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

     

       280
       280
       +
                   |> Void.exec ~env

     

       281
       281
       +
                        [

     

       282
       282
       +
                          config.shell;

     

       283
       283
       +
                          "-c";

     

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

     

       285
       285
       +
                        ]

     

       286
       286
       +
                 in

     

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

     

       288
       288
       +
               else

     

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

     

       290
       290
       +
                   {

     

       291
       291
       +
                     ty = `Bind;

     

       292
       292
       +
                     src = ctx.tool_dir;

     

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

     

       294
       294
       +
                     readonly = true;

     

       295
       295
       +
                   }

     

       296
       296
       +
                 in

     

       297
       297
       +
                 let config =

     

       298
       298
       +
                   Runc.Json_config.

     

       299
       299
       +
                     {

     

       300
       300
       +
                       cwd = entry.pre.cwd;

     

       301
       301
       +
                       argv =

     

       302
       302
       +
                         [

     

       303
       303
       +
                           config.shell;

     

       304
       304
       +
                           "-c";

     

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

     

       306
       306
       +
                         ];

     

       307
       307
       +
                       hostname = "builder";

     

       308
       308
       +
                       network = [ "host" ];

     

       309
       309
       +
                       user = (uid, gid);

     

       310
       310
       +
                       env = entry.pre.env;

     

       311
       311
       +
                       mounts = [ tool_mount ];

     

       312
       312
       +
                       entrypoint = None;

     

       313
       313
       +
                     }

     

       314
       314
       +
                 in

     

       315
       315
       +
                 let env =

     

       316
       316
       +
                   object

     

       317
       317
       +
                     method fs = fs

     

       318
       318
       +
                     method proc = proc

     

       319
       319
       +
                     method stdout = stdout

     

       320
       320
       +
                   end

     

       321
       321
       +
                 in

     

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

     

       323
       323
       +
             in

     

       324
       324
       +
             let start, res =

     

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

     

       326
       326
       +
               let log =

     

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

     

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

     

       329
       329
       +
               in

     

       330
       330
       +
               let res = spawn sw log in

     

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

     

       332
       332
       +
               match res with

     

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

     

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

     

       335
       335
       +
             in

     

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

     

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

     

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

     

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

     

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

     

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

     

       342
       342
       +
             in

     

       343
       343
       +
             if res = `Exited 0 then (

     

       344
       344
       +
               (* Extract env *)

     

       345
       345
       +
               let env_path =

     

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

     

       347
       347
       +
               in

     

       348
       348
       +
               let env =

     

       349
       349
       +
                 Eio.Path.(load env_path)

     

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

     

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

     

       352
       352
       +
               in

     

       353
       353
       +
               Eio.Path.unlink env_path;

     

       354
       354
       +
               let cwd =

     

       355
       355
       +
                 List.find_map

     

       356
       356
       +
                   (fun v ->

     

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

     

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

     

       359
       359
       +
                     | _ -> None)

     

       360
       360
       +
                   env

     

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

     

       362
       362
       +
               in

     

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

     

       364
       364
       +
                 Ok

     

       365
       365
       +
                   (`Entry

     

       366
       366
       +
                      ( {

     

       367
       367
       +
                          hash_entry with

     

       368
       368
       +
                          History.pre =

     

       369
       369
       +
                            {

     

       370
       370
       +
                              hash_entry.pre with

     

       371
       371
       +
                              build = Build new_cid;

     

       372
       372
       +
                              env;

     

       373
       373
       +
                              cwd;

     

       374
       374
       +
                              user = (uid, gid);

     

       375
       375
       +
                            };

     

       376
       376
       +
                        },

     

       377
       377
       +
                        rootfs ))

     

       378
       378
       +
               else

     

       379
       379
       +
                 Ok

     

       380
       380
       +
                   (`Entry

     

       381
       381
       +
                      ( {

     

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

     

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

     

       384
       384
       +
                        },

     

       385
       385
       +
                        rootfs )))

     

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

     

       387
       387
       +
       

     

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

     

       389
       389
       +
           new_entry diff =

     

       390
       390
       +
         match new_entry with

     

       391
       391
       +
         | Error e -> Error e

     

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

     

       393
       393
       +
             match

     

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

     

       395
       395
       +
             with

     

       396
       396
       +
             | None ->

     

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

     

       398
       398
       +
                 Ok (s, ctx)

     

       399
       399
       +
             | Some c ->

     

       400
       400
       +
                 S.Head.set store c;

     

       401
       401
       +
                 Ok (s, ctx))

     

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

     

       403
       403
       +
             (* Set diff *)

     

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

     

       405
       405
       +
             (* Commit if RW *)

     

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

     

       407
       407
       +
               commit

     

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

     

       409
       409
       +
                 clock s entry;

     

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

     

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

     

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

     

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

     

       414
       414
       +
                 hash);

     

       415
       415
       +
             Ok (s, ctx)

     

       416
       416
       +
       

     

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

     

       418
       418
       +
           proc stdout existing_branch =

     

       419
       419
       +
         let seshes = sessions store in

     

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

     

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

     

       422
       422
       +
           Ok (store, ctx))

     

       423
       423
       +
         else

     

       424
       424
       +
           let repo = S.repo s in

     

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

     

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

     

       427
       427
       +
           | Error lcas_error ->

     

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

     

       429
       429
       +
               Ok (store, ctx)

     

       430
       430
       +
           | Ok [ lcas ] -> (

     

       431
       431
       +
               let all_commits = history store in

     

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

     

       433
       433
       +
               let rec collect = function

     

       434
       434
       +
                 | [] -> []

     

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

     

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

     

       437
       437
       +
               in

     

       438
       438
       +
               let commits_to_apply = collect all_commits in

     

       439
       439
       +
               match commits_to_apply with

     

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

     

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

     

       442
       442
       +
                   let _, last_other =

     

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

     

       444
       444
       +
                   in

     

       445
       445
       +
                   let new_first =

     

       446
       446
       +
                     {

     

       447
       447
       +
                       first with

     

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

     

       449
       449
       +
                     }

     

       450
       450
       +
                   in

     

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

     

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

     

       453
       453
       +
                  and replay our commits onto it *)

     

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

     

       455
       455
       +
                   S.Head.set s other_head;

     

       456
       456
       +
                   let res =

     

       457
       457
       +
                     List.fold_left

     

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

     

       459
       459
       +
                         match last with

     

       460
       460
       +
                         | Error _ as e -> e

     

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

     

       462
       462
       +
                             let new_entry, diff =

     

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

     

       464
       464
       +
                             in

     

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

     

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

     

       467
       467
       +
                       commits_to_apply

     

       468
       468
       +
                   in

     

       469
       469
       +
                   res)

     

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

     

       471
       471
       +
       

     

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

     

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

     

       474
       474
       +
         | Set_mode mode ->

     

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

     

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

     

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

     

       478
       478
       +
             Ok (s, ctx)

     

       479
       479
       +
         | Set_session m -> (

     

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

     

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

     

       482
       482
       +
             let sessions = sessions s in

     

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

     

       484
       484
       +
             | true ->

     

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

     

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

     

       487
       487
       +
             | false -> (

     

       488
       488
       +
                 match fork s m with

     

       489
       489
       +
                 | Error err ->

     

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

     

       491
       491
       +
                     Ok (s, ctx)

     

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

     

       493
       493
       +
         | Unknown args ->

     

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

     

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

     

       496
       496
       +
         | Info `Current ->

     

       497
       497
       +
             let sessions = sessions s in

     

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

     

       499
       499
       +
             let history = history s in

     

       500
       500
       +
             let pp_commit fmt (hash, msg) =

     

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

     

       502
       502
       +
             in

     

       503
       503
       +
             let repo = S.repo store in

     

       504
       504
       +
             let commits =

     

       505
       505
       +
               List.fold_left

     

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

     

       507
       507
       +
                   let commit =

     

       508
       508
       +
                     S.Hash.unsafe_of_raw_string commit

     

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

     

       510
       510
       +
                   in

     

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

     

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

     

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

     

       514
       514
       +
                 [] history

     

       515
       515
       +
             in

     

       516
       516
       +
             let latest =

     

       517
       517
       +
               with_latest

     

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

     

       519
       519
       +
                 s

     

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

     

       521
       521
       +
             in

     

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

     

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

     

       524
       524
       +
               sessions (text `Green) sesh

     

       525
       525
       +
               Fmt.(option string)

     

       526
       526
       +
               latest

     

       527
       527
       +
               Fmt.(vbox ~indent:2 @@ list pp_commit)

     

       528
       528
       +
               commits;

     

       529
       529
       +
             Ok (s, ctx)

     

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

     

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

     

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

     

       533
       533
       +
         | Info `History ->

     

       534
       534
       +
             display_history s;

     

       535
       535
       +
             Ok (s, ctx)

     

       536
       536
       +
         | Exec command -> (

     

       537
       537
       +
             let entry =

     

       538
       538
       +
               with_latest

     

       539
       539
       +
                 ~default:(fun () ->

     

       540
       540
       +
                   History.

     

       541
       541
       +
                     {

     

       542
       542
       +
                       pre =

     

       543
       543
       +
                         {

     

       544
       544
       +
                           mode = Void.RW;

     

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

     

       546
       546
       +
                           args = command;

     

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

     

       548
       548
       +
                           env = [];

     

       549
       549
       +
                           cwd = "/";

     

       550
       550
       +
                           user = (0, 0);

     

       551
       551
       +
                         };

     

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

     

       553
       553
       +
                     })

     

       554
       554
       +
                 s Fun.id

     

       555
       555
       +
             in

     

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

     

       557
       557
       +
             try

     

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

     

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

     

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

+22

src/lib/shelter/shelter_main.mli

···

       1
       1
       +
       module Store = Store

     

       2
       2
       +
       

     

       3
       3
       +
       module History : sig

     

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

     

       5
       5
       +
       

     

       6
       6
       +
         type pre = {

     

       7
       7
       +
           mode : Void.mode;

     

       8
       8
       +
           build : Store.Build.t;

     

       9
       9
       +
           args : string list;

     

       10
       10
       +
           env : string list;

     

       11
       11
       +
           cwd : string;

     

       12
       12
       +
           user : int * int;

     

       13
       13
       +
         }

     

       14
       14
       +
         [@@deriving repr]

     

       15
       15
       +
         (** Needed for execution *)

     

       16
       16
       +
       

     

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

     

       18
       18
       +
       

     

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

     

       20
       20
       +
       end

     

       21
       21
       +
       

     

       22
       22
       +
       include Shelter.Engine.S with type entry = History.t

+57 -25

src/lib/shelter/store.ml

···

       30
       30
        
         val builds : string -> dataset

     

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

     

       32
       32
        
         val snapshot : dataset -> snapshot

     

       33
       33
       +
         val tools : string -> dataset

     

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

     

       33
       35
        
       end = struct

     

       34
       36
        
         type dataset = string

     

       35
       37
        
         type snapshot = string

     
···

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

     

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

     

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

     

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

     

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

     

       41
       45
        
       end

     

       42
       46
        
       

     

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

     
···

       78
       82
        
           }

     

       79
       83
        
         in

     

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

     

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

     

       81
       86
        
         t

     

       82
       87
        
       

     

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

     
···

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

     

       90
       95
        
       

     

       91
       96
        
       let read_all fd =

     

       92
       92
       -
         let buf = Buffer.create 128 in

     

       93
       93
       -
         let bytes = Bytes.create 4096 in

     

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

     

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

     

       94
       99
        
         let rec loop () =

     

       95
       100
        
           match Unix.read fd bytes 0 4096 with

     

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

     
···

       100
       105
        
         in

     

       101
       106
        
         loop ()

     

       102
       107
        
       

     

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

     

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

     

       104
       109
        
         let data_fs =

     

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

     

       106
       111
        
         in

     

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

     

       108
       108
       -
         let diff =

     

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

     

       113
       113
       +
         let () =

     

       110
       114
        
           try

     

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

     

       112
       112
       -
             let f = read_all r in

     

       113
       113
       -
             Unix.close r;

     

       114
       114
       -
             f

     

       115
       115
       -
           with e ->

     

       116
       116
       -
             Unix.close r;

     

       117
       117
       -
             raise e

     

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

     

       116
       116
       +
             @@ fun flow_fd ->

     

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

     

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

     

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

     

       120
       120
       +
             | Some fd ->

     

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

     

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

     

       118
       123
        
         in

     

       119
       124
        
         Zfs.close zh;

     

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

     

       120
       126
        
         Diff.of_zfs diff

     

       121
       127
        
       

     

       122
       128
        
       let cid s =

     
···

       126
       132
        
         in

     

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

     

       128
       134
        
       

     

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

     

       136
       136
       +
       

     

       137
       137
       +
       let get_uid_gid ~username rootfs =

     

       138
       138
       +
         let passwd =

     

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

     

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

     

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

     

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

     

       143
       143
       +
         in

     

       144
       144
       +
         List.find_map

     

       145
       145
       +
           (function

     

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

     

       147
       147
       +
                 Some (int_of_string uid, int_of_string gid)

     

       148
       148
       +
             | _ -> None)

     

       149
       149
       +
           passwd

     

       150
       150
       +
       

     

       129
       151
        
       let fetch t image =

     

       130
       152
        
         let cid = cid image in

     

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

     

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

     

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

     

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

     

       135
       135
       -
         else (

     

       136
       136
       -
           create_and_mount t dataset;

     

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

     

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

     

       139
       139
       -
           cid)

     

       156
       156
       +
         create_and_mount t dataset;

     

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

     

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

     

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

     

       160
       160
       +
         ( cid,

     

       161
       161
       +
           Fetch.get_env t.proc image,

     

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

     

       140
       163
        
       

     

       141
       164
        
       module Run = struct

     

       142
       165
        
         let with_build t cid fn =

     

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

     

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

     

       145
       168
        
           mount_dataset t ds;

     

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

     

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

     

       170
       170
       +
       

     

       171
       171
       +
         let with_tool t cid fn =

     

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

     

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

     

       174
       174
       +
           mount_dataset t ds;

     

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

     

       147
       176
        
       

     

       148
       148
       -
         let with_clone t ~src new_cid fn =

     

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

     

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

     

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

     

       151
       180
        
           let src_snap = Datasets.snapshot ds in

     

       152
       181
        
           let tgt_snap = Datasets.snapshot tgt in

     

       153
       153
       -
           clone t src_snap tgt;

     

       154
       154
       -
           let v = with_build t new_cid fn in

     

       155
       155
       -
           snapshot t tgt_snap;

     

       156
       156
       -
           let d = diff t src_snap tgt_snap in

     

       157
       157
       -
           (v, d)

     

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

     

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

     

       184
       184
       +
           else (

     

       185
       185
       +
             clone t src_snap tgt;

     

       186
       186
       +
             let v = with_build t new_cid fn in

     

       187
       187
       +
             snapshot t tgt_snap;

     

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

     

       189
       189
       +
             (v, d))

     

       158
       190
        
       end

src/lib/shelter/tools.ml

···

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

+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

+22

vendor/void/.github/workflows/test.yml

···

       1
       1
       +
       name: Void Test

     

       2
       2
       +
       on:

     

       3
       3
       +
         - push

     

       4
       4
       +
         - pull_request

     

       5
       5
       +
       permissions: read-all

     

       6
       6
       +
       jobs:

     

       7
       7
       +
         build:

     

       8
       8
       +
           strategy:

     

       9
       9
       +
             fail-fast: false

     

       10
       10
       +
           runs-on: ubuntu-latest

     

       11
       11
       +
           steps:

     

       12
       12
       +
             - name: Checkout tree

     

       13
       13
       +
               uses: actions/checkout@v4

     

       14
       14
       +
       

     

       15
       15
       +
             - name: Set-up OCaml

     

       16
       16
       +
               uses: ocaml/setup-ocaml@v3

     

       17
       17
       +
               with:

     

       18
       18
       +
                 ocaml-compiler: 5

     

       19
       19
       +
       

     

       20
       20
       +
             - run: opam install . --deps-only --with-test

     

       21
       21
       +
             - run: opam exec -- dune build

     

       22
       22
       +
             - run: sudo ./_build/default/examples/hey.exe

vendor/void/.gitignore

vendor/void/.ocamlformat

···

       1
       1
       +
       version=0.27.0

+14

vendor/void/LICENSE.md

···

       1
       1
       +
       Copyright (C) 2024 Patrick Ferris

     

       2
       2
       +
       

     

       3
       3
       +
       Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.

     

       4
       4
       +
       

     

       5
       5
       +
       THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

     

       6
       6
       +
       

     

       7
       7
       +
       Much of the codebase is borrowed directly from Eio, with the following license:

     

       8
       8
       +
       

     

       9
       9
       +
       Copyright (C) 2021 Anil Madhavapeddy

     

       10
       10
       +
       Copyright (C) 2022 Thomas Leonard

     

       11
       11
       +
       

     

       12
       12
       +
       Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.

     

       13
       13
       +
       

     

       14
       14
       +
       THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

vendor/void/README.md

···

       1
       1
       +
       Void

     

       2
       2
       +
       ----

     

       3
       3
       +
       

     

       4
       4
       +
       Void processes for Eio.

     

       5
       5
       +

+29

vendor/void/dune-project

···

       1
       1
       +
       (lang dune 3.15)

     

       2
       2
       +
       

     

       3
       3
       +
       (name void)

     

       4
       4
       +
       

     

       5
       5
       +
       (generate_opam_files true)

     

       6
       6
       +
       

     

       7
       7
       +
       (source

     

       8
       8
       +
        (github patricoferris/void))

     

       9
       9
       +
       

     

       10
       10
       +
       (authors "Patrick Ferris")

     

       11
       11
       +
       

     

       12
       12
       +
       (maintainers "Patrick Ferris")

     

       13
       13
       +
       

     

       14
       14
       +
       (license MIT)

     

       15
       15
       +
       

     

       16
       16
       +
       (documentation https://ocaml.org/p/void)

     

       17
       17
       +
       

     

       18
       18
       +
       (package

     

       19
       19
       +
        (name void)

     

       20
       20
       +
        (synopsis "Void Processes in Eio_linux")

     

       21
       21
       +
        (description "A longer description")

     

       22
       22
       +
        (depends 

     

       23
       23
       +
          ocaml 

     

       24
       24
       +
          dune

     

       25
       25
       +
          eio_posix)

     

       26
       26
       +
        (tags

     

       27
       27
       +
         (linux process spawn)))

     

       28
       28
       +
       

     

       29
       29
       +
       ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

+69

vendor/void/examples/alpine.ml

···

       1
       1
       +
       open Eio.Std

     

       2
       2
       +
       

     

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

     

       4
       4
       +
       

     

       5
       5
       +
       let test_data fs data =

     

       6
       6
       +
         let tempdir = Filename.temp_dir "void-" "-alpine" in

     

       7
       7
       +
         Eio.Path.(save ~create:(`If_missing 0o644) (fs / tempdir / "data.txt") data);

     

       8
       8
       +
         Eio.traceln "Test data in %s" tempdir;

     

       9
       9
       +
         tempdir

     

       10
       10
       +
       

     

       11
       11
       +
       let get_alpine_image ~fs ~proc =

     

       12
       12
       +
         let tmpdir = Filename.temp_dir "void" "alpine" in

     

       13
       13
       +
         Eio.traceln "Extracting alpine to %s..." tmpdir;

     

       14
       14
       +
         let container_id =

     

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

     

       16
       16
       +
             [ "docker"; "run"; "-d"; "alpine" ]

     

       17
       17
       +
           |> String.trim

     

       18
       18
       +
         in

     

       19
       19
       +
         Eio.traceln "Container %s" container_id;

     

       20
       20
       +
         let () =

     

       21
       21
       +
           Eio.Process.run proc

     

       22
       22
       +
             [

     

       23
       23
       +
               "docker";

     

       24
       24
       +
               "export";

     

       25
       25
       +
               container_id;

     

       26
       26
       +
               "-o";

     

       27
       27
       +
               Filename.concat tmpdir "alpine.tar.gz";

     

       28
       28
       +
             ]

     

       29
       29
       +
         in

     

       30
       30
       +
         Eio.traceln "Untarring...";

     

       31
       31
       +
         Eio.Path.mkdir ~perm:0o777 (fs / tmpdir / "rootfs");

     

       32
       32
       +
         let () =

     

       33
       33
       +
           Eio.Process.run proc

     

       34
       34
       +
             [

     

       35
       35
       +
               "tar";

     

       36
       36
       +
               "-xf";

     

       37
       37
       +
               Filename.concat tmpdir "alpine.tar.gz";

     

       38
       38
       +
               "-C";

     

       39
       39
       +
               Filename.concat tmpdir "rootfs";

     

       40
       40
       +
             ]

     

       41
       41
       +
         in

     

       42
       42
       +
         Filename.concat tmpdir "rootfs"

     

       43
       43
       +
       

     

       44
       44
       +
       (* This example read-only mounts a copy of busybox

     

       45
       45
       +
          into the root-filesystem of the process. *)

     

       46
       46
       +
       let () =

     

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

     

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

     

       49
       49
       +
         let fs = env#fs in

     

       50
       50
       +
         let proc = env#process_mgr in

     

       51
       51
       +
         let alpine_img = get_alpine_image ~fs ~proc in

     

       52
       52
       +
         let mount_src = test_data fs "Hello, World!" in

     

       53
       53
       +
         let open Void in

     

       54
       54
       +
         let args =

     

       55
       55
       +
           let l = Array.length Sys.argv in

     

       56
       56
       +
           if l <= 1 then

     

       57
       57
       +
             [

     

       58
       58
       +
               "/bin/ash"; "-c"; "/bin/echo hello > /hello.txt && /bin/cat /hello.txt";

     

       59
       59
       +
             ]

     

       60
       60
       +
           else Array.sub Sys.argv 1 (l - 1) |> Array.to_list

     

       61
       61
       +
         in

     

       62
       62
       +
         let void =

     

       63
       63
       +
           empty |> rootfs ~mode:RW alpine_img

     

       64
       64
       +
           |> mount ~mode:R ~src:mount_src ~tgt:"data"

     

       65
       65
       +
           |> exec args

     

       66
       66
       +
         in

     

       67
       67
       +
         let t = Void.spawn ~sw void in

     

       68
       68
       +
         let status = Promise.await (Void.exit_status t) in

     

       69
       69
       +
         Eio.traceln "Status: %s" (Void.exit_status_to_string status)

+55

vendor/void/examples/curl.ml

···

       1
       1
       +
       open Eio.Std

     

       2
       2
       +
       

     

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

     

       4
       4
       +
       

     

       5
       5
       +
       let get_alpine_image ~fs ~proc =

     

       6
       6
       +
         let tmpdir = Filename.temp_dir "void-" "-alpine-curl" in

     

       7
       7
       +
         Eio.traceln "Extracting alpine/curl to %s..." tmpdir;

     

       8
       8
       +
         let container_id =

     

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

     

       10
       10
       +
             [ "docker"; "run"; "-d"; "alpine/curl" ]

     

       11
       11
       +
           |> String.trim

     

       12
       12
       +
         in

     

       13
       13
       +
         Eio.traceln "Container %s" container_id;

     

       14
       14
       +
         let () =

     

       15
       15
       +
           Eio.Process.run proc

     

       16
       16
       +
             [

     

       17
       17
       +
               "docker";

     

       18
       18
       +
               "export";

     

       19
       19
       +
               container_id;

     

       20
       20
       +
               "-o";

     

       21
       21
       +
               Filename.concat tmpdir "alpine-curl.tar.gz";

     

       22
       22
       +
             ]

     

       23
       23
       +
         in

     

       24
       24
       +
         Eio.traceln "Untarring...";

     

       25
       25
       +
         Eio.Path.mkdir ~perm:0o777 (fs / tmpdir / "rootfs");

     

       26
       26
       +
         let () =

     

       27
       27
       +
           Eio.Process.run proc

     

       28
       28
       +
             [

     

       29
       29
       +
               "tar";

     

       30
       30
       +
               "-xf";

     

       31
       31
       +
               Filename.concat tmpdir "alpine-curl.tar.gz";

     

       32
       32
       +
               "-C";

     

       33
       33
       +
               Filename.concat tmpdir "rootfs";

     

       34
       34
       +
             ]

     

       35
       35
       +
         in

     

       36
       36
       +
         Filename.concat tmpdir "rootfs"

     

       37
       37
       +
       

     

       38
       38
       +
       (* This example read-only mounts a copy of busybox

     

       39
       39
       +
          into the root-filesystem of the process. *)

     

       40
       40
       +
       let () =

     

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

     

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

     

       43
       43
       +
         let fs = env#fs in

     

       44
       44
       +
         let proc = env#process_mgr in

     

       45
       45
       +
         let alpine_img = get_alpine_image ~fs ~proc in

     

       46
       46
       +
         let open Void in

     

       47
       47
       +
         let args =

     

       48
       48
       +
           let l = Array.length Sys.argv in

     

       49
       49
       +
           if l <= 1 then [ "/bin/ls"; "-l" ]

     

       50
       50
       +
           else Array.sub Sys.argv 1 (l - 1) |> Array.to_list

     

       51
       51
       +
         in

     

       52
       52
       +
         let void = empty |> rootfs ~mode:R alpine_img |> exec args in

     

       53
       53
       +
         let t = Void.spawn ~sw void in

     

       54
       54
       +
         let status = Promise.await (Void.exit_status t) in

     

       55
       55
       +
         Eio.traceln "Status: %s" (Void.exit_status_to_string status)

vendor/void/examples/dune

···

       1
       1
       +
       (executables

     

       2
       2
       +
        (names hey curl alpine)

     

       3
       3
       +
        (libraries void eio_posix))

+11

vendor/void/examples/empty.ml

···

       1
       1
       +
       open Eio.Std

     

       2
       2
       +
       

     

       3
       3
       +
       let () =

     

       4
       4
       +
         Eio_linux.run @@ fun _env ->

     

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

     

       6
       6
       +
         let open Void in

     

       7
       7
       +
         let void = empty |> exec [] in

     

       8
       8
       +
         Eio.traceln "Spawning the empty void...";

     

       9
       9
       +
         let t = Void.spawn ~sw void in

     

       10
       10
       +
         let status = Promise.await (Void.exit_status t) in

     

       11
       11
       +
         Eio.traceln "Status: %s" (Void.exit_status_to_string status)

vendor/void/examples/hey

This is a binary file and will not be displayed.

+11

vendor/void/examples/hey.c

···

       1
       1
       +
       // Based off of Docker's hello-world

     

       2
       2
       +
       // This is standalone program

     

       3
       3
       +
       #include <sys/syscall.h>

     

       4
       4
       +
       #include <unistd.h>

     

       5
       5
       +
       

     

       6
       6
       +
       const char message[] = "Hello from the Void!\n";

     

       7
       7
       +
       

     

       8
       8
       +
       int main() {

     

       9
       9
       +
         syscall(SYS_write, STDOUT_FILENO, message, sizeof(message) - 1);

     

       10
       10
       +
         return 0;

     

       11
       11
       +
       }

+22

vendor/void/examples/hey.ml

···

       1
       1
       +
       open Eio.Std

     

       2
       2
       +
       

     

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

     

       4
       4
       +
       

     

       5
       5
       +
       let copy_hey fs =

     

       6
       6
       +
         let temp_dir = Filename.temp_dir "void-" "-world" in

     

       7
       7
       +
         let hey = Eio.Path.load (fs / "./examples/hey") in

     

       8
       8
       +
         Eio.Path.save ~create:(`If_missing 0o755) (fs / temp_dir / "hey") hey;

     

       9
       9
       +
         temp_dir

     

       10
       10
       +
       

     

       11
       11
       +
       (* This mounts the hello-world into the void process. *)

     

       12
       12
       +
       let () =

     

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

     

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

     

       15
       15
       +
         let hey_dir = copy_hey env#fs in

     

       16
       16
       +
         let void =

     

       17
       17
       +
           let open Void in

     

       18
       18
       +
           empty |> mount ~mode:R ~src:hey_dir ~tgt:"say" |> exec [ "/say/hey" ]

     

       19
       19
       +
         in

     

       20
       20
       +
         let t = Void.spawn ~sw void in

     

       21
       21
       +
         let status = Promise.await (Void.exit_status t) in

     

       22
       22
       +
         Eio.traceln "Void process: %s" (Void.exit_status_to_string status)

+13

vendor/void/src/dune

···

       1
       1
       +
       (rule

     

       2
       2
       +
        (targets config.ml)

     

       3
       3
       +
        (action

     

       4
       4
       +
         (run ./include/discover.exe)))

     

       5
       5
       +
       

     

       6
       6
       +
       (library

     

       7
       7
       +
        (name void)

     

       8
       8
       +
        (public_name void)

     

       9
       9
       +
        (foreign_stubs

     

       10
       10
       +
         (language c)

     

       11
       11
       +
         (flags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64)

     

       12
       12
       +
         (names void_action))

     

       13
       13
       +
        (libraries eio_posix eio.unix))

+57

vendor/void/src/include/discover.ml

···

       1
       1
       +
       module C = Configurator.V1

     

       2
       2
       +
       

     

       3
       3
       +
       let () =

     

       4
       4
       +
         C.main ~name:"discover" (fun c ->

     

       5
       5
       +
             let defs, mount_flags =

     

       6
       6
       +
               C.C_define.import c ~c_flags:[ "-D_GNU_SOURCE" ]

     

       7
       7
       +
                 ~includes:[ "linux/sched.h"; "sys/mount.h" ]

     

       8
       8
       +
                 C.C_define.Type.

     

       9
       9
       +
                   [

     

       10
       10
       +
                     (* Clone3 Flags *)

     

       11
       11
       +
                     ("CLONE_PIDFD", Int);

     

       12
       12
       +
                     ("CLONE_NEWPID", Int);

     

       13
       13
       +
                     ("CLONE_NEWCGROUP", Int);

     

       14
       14
       +
                     ("CLONE_NEWNS", Int);

     

       15
       15
       +
                     ("CLONE_NEWIPC", Int);

     

       16
       16
       +
                     ("CLONE_NEWNET", Int);

     

       17
       17
       +
                     ("CLONE_NEWTIME", Int);

     

       18
       18
       +
                     ("CLONE_NEWUSER", Int);

     

       19
       19
       +
                     ("CLONE_NEWUTS", Int);

     

       20
       20
       +
                     (* Mount Flags *)

     

       21
       21
       +
                     ("MS_RDONLY", Int);

     

       22
       22
       +
                     ("MS_REMOUNT", Int);

     

       23
       23
       +
                     ("MS_BIND", Int);

     

       24
       24
       +
                     ("MS_SHARED", Int);

     

       25
       25
       +
                   ]

     

       26
       26
       +
               |> List.fold_left

     

       27
       27
       +
                    (fun (cls, mnts) -> function

     

       28
       28
       +
                      | name, C.C_define.Value.Int v ->

     

       29
       29
       +
                          let t = (String.lowercase_ascii name, v) in

     

       30
       30
       +
                          if String.starts_with ~prefix:"CLONE" name then

     

       31
       31
       +
                            (t :: cls, mnts)

     

       32
       32
       +
                          else (cls, t :: mnts)

     

       33
       33
       +
                      | _ -> assert false)

     

       34
       34
       +
                    ([], [])

     

       35
       35
       +
             in

     

       36
       36
       +
             let sigs vs =

     

       37
       37
       +
               List.map (fun (name, _) -> Printf.sprintf "  val %s : t" name) vs

     

       38
       38
       +
             in

     

       39
       39
       +
             let structs vs =

     

       40
       40
       +
               List.map (fun (name, v) -> Printf.sprintf "  let %s = 0x%x" name v) vs

     

       41
       41
       +
             in

     

       42
       42
       +
             let flags_nspace =

     

       43
       43
       +
               List.filter (String.starts_with ~prefix:"clone_new") (List.map fst defs)

     

       44
       44
       +
             in

     

       45
       45
       +
             let mount =

     

       46
       46
       +
               [ "module Mount_flags : sig"; "  type t = int" ]

     

       47
       47
       +
               @ sigs mount_flags

     

       48
       48
       +
               @ [ "end = struct"; "  type t = int" ]

     

       49
       49
       +
               @ structs mount_flags @ [ "end" ]

     

       50
       50
       +
             in

     

       51
       51
       +
             C.Flags.write_lines "config.ml"

     

       52
       52
       +
               ([ "module Clone_flags : sig"; "  type t = int" ]

     

       53
       53
       +
               @ sigs defs @ [ "val all : t list" ]

     

       54
       54
       +
               @ [ "end = struct"; "  type t = int" ]

     

       55
       55
       +
               @ structs defs

     

       56
       56
       +
               @ [ "let all = [" ^ String.concat ";" flags_nspace ^ "]" ]

     

       57
       57
       +
               @ [ "end" ] @ mount))

vendor/void/src/include/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (name discover)

     

       3
       3
       +
        (modules discover)

     

       4
       4
       +
        (libraries dune-configurator))

+222

vendor/void/src/void.ml

···

       1
       1
       +
       open Eio.Std

     

       2
       2
       +
       module Process = Eio_posix.Low_level.Process

     

       3
       3
       +
       module Trace = Eio.Private.Trace

     

       4
       4
       +
       module Fd = Eio_unix.Fd

     

       5
       5
       +
       module Rcfd = Eio_unix.Private.Rcfd

     

       6
       6
       +
       module Fork_action = Eio_unix.Private.Fork_action

     

       7
       7
       +
       

     

       8
       8
       +
       type mode = R | RW

     

       9
       9
       +
       

     

       10
       10
       +
       type void = {

     

       11
       11
       +
         args : string list;

     

       12
       12
       +
         env : string list;

     

       13
       13
       +
         cwd : string;

     

       14
       14
       +
         uid : int;

     

       15
       15
       +
         (* TODO: gid *)

     

       16
       16
       +
         rootfs : (string * mode) option;

     

       17
       17
       +
         mounts : mount list;

     

       18
       18
       +
       }

     

       19
       19
       +
       

     

       20
       20
       +
       and mount = { src : string; tgt : string; mode : int [@warning "-69"] }

     

       21
       21
       +
       

     

       22
       22
       +
       (* Actions for namespacing *)

     

       23
       23
       +
       module Mount = struct

     

       24
       24
       +
         module Flags = struct

     

       25
       25
       +
           include Config.Mount_flags

     

       26
       26
       +
       

     

       27
       27
       +
           let empty : t = 0

     

       28
       28
       +
           let ( + ) = ( lor )

     

       29
       29
       +
         end

     

       30
       30
       +
       

     

       31
       31
       +
         module Types = struct

     

       32
       32
       +
           type t = string

     

       33
       33
       +
       

     

       34
       34
       +
           let btrfs = "btrfs"

     

       35
       35
       +
           let ext4 = "ext4"

     

       36
       36
       +
           let auto = "auto"

     

       37
       37
       +
         end

     

       38
       38
       +
       end

     

       39
       39
       +
       

     

       40
       40
       +
       external action_mount : unit -> Fork_action.fork_fn = "void_fork_mount"

     

       41
       41
       +
       

     

       42
       42
       +
       let action_mount = action_mount ()

     

       43
       43
       +
       

     

       44
       44
       +
       let _mount ~(src : string) ~(target : string) (type_ : Mount.Types.t)

     

       45
       45
       +
           (flags : Mount.Flags.t) =

     

       46
       46
       +
         Fork_action.

     

       47
       47
       +
           { run = (fun k -> k (Obj.repr (action_mount, src, target, type_, flags))) }

     

       48
       48
       +
       

     

       49
       49
       +
       external action_pivot_root : unit -> Fork_action.fork_fn

     

       50
       50
       +
         = "void_fork_pivot_root"

     

       51
       51
       +
       

     

       52
       52
       +
       let action_pivot_root = action_pivot_root ()

     

       53
       53
       +
       

     

       54
       54
       +
       let pivot_root (new_root : string) (new_root_flags : Mount.Flags.t)

     

       55
       55
       +
           (tmpfs : bool) (mounts : mount list) =

     

       56
       56
       +
         Fork_action.

     

       57
       57
       +
           {

     

       58
       58
       +
             run =

     

       59
       59
       +
               (fun k ->

     

       60
       60
       +
                 k

     

       61
       61
       +
                   (Obj.repr

     

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

     

       63
       63
       +
           }

     

       64
       64
       +
       

     

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

     

       66
       66
       +
         = "void_fork_setuid"

     

       67
       67
       +
       

     

       68
       68
       +
       let action_setuid = action_setuid ()

     

       69
       69
       +
       

     

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

     

       71
       71
       +
           {

     

       72
       72
       +
             run =

     

       73
       73
       +
               (fun k ->

     

       74
       74
       +
                 k

     

       75
       75
       +
                   (Obj.repr

     

       76
       76
       +
                      (action_setuid, uid)));

     

       77
       77
       +
           }

     

       78
       78
       +
       

     

       79
       79
       +
       external action_map_uid_gid : unit -> Fork_action.fork_fn

     

       80
       80
       +
         = "void_fork_map_uid_gid"

     

       81
       81
       +
       

     

       82
       82
       +
       let action_map_uid_gid = action_map_uid_gid ()

     

       83
       83
       +
       

     

       84
       84
       +
       let map_uid_gid ~uid ~gid =

     

       85
       85
       +
         Fork_action.{ run = (fun k -> k (Obj.repr (action_map_uid_gid, uid, gid))) }

     

       86
       86
       +
       

     

       87
       87
       +
       module Flags = struct

     

       88
       88
       +
         include Config.Clone_flags

     

       89
       89
       +
       

     

       90
       90
       +
         let ( + ) = ( lor )

     

       91
       91
       +
       end

     

       92
       92
       +
       

     

       93
       93
       +
       external eio_spawn :

     

       94
       94
       +
         Unix.file_descr ->

     

       95
       95
       +
         Flags.t ->

     

       96
       96
       +
         Eio_unix.Private.Fork_action.c_action list ->

     

       97
       97
       +
         int * Unix.file_descr = "caml_void_clone3"

     

       98
       98
       +
       

     

       99
       99
       +
       type t = {

     

       100
       100
       +
         pid : int;

     

       101
       101
       +
         pid_fd : Fd.t;

     

       102
       102
       +
         exit_status : Unix.process_status Promise.t;

     

       103
       103
       +
       }

     

       104
       104
       +
       

     

       105
       105
       +
       let exit_status t = t.exit_status

     

       106
       106
       +
       let pid t = t.pid

     

       107
       107
       +
       

     

       108
       108
       +
       (* Read a (typically short) error message from a child process. *)

     

       109
       109
       +
       let rec read_response fd =

     

       110
       110
       +
         let buf = Cstruct.create 256 in

     

       111
       111
       +
         match Eio_posix.Low_level.readv fd [| buf |] with

     

       112
       112
       +
         | 0 | (exception End_of_file) -> ""

     

       113
       113
       +
         | len -> Cstruct.to_string buf ~len ^ read_response fd

     

       114
       114
       +
       

     

       115
       115
       +
       let void_flags = List.fold_left Flags.( + ) 0 Flags.all

     

       116
       116
       +
       

     

       117
       117
       +
       type path = string

     

       118
       118
       +
       

     

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

     

       120
       120
       +
       

     

       121
       121
       +
       let actions v : Fork_action.t list =

     

       122
       122
       +
         let root, tmpfs, root_mode =

     

       123
       123
       +
           match v.rootfs with

     

       124
       124
       +
           | None -> (Filename.temp_dir "void-" "-tmpdir", true, R)

     

       125
       125
       +
           | Some (s, m) -> (s, false, m)

     

       126
       126
       +
         in

     

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

     

       128
       128
       +
         let e =

     

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

     

       130
       130
       +
             ~argv:(Array.of_list args)

     

       131
       131
       +
         in

     

       132
       132
       +
         (* Process mount point points *)

     

       133
       133
       +
         let mounts =

     

       134
       134
       +
           List.map

     

       135
       135
       +
             (fun mnt ->

     

       136
       136
       +
               let src = Filename.concat "/.old_root" mnt.src in

     

       137
       137
       +
               let tgt = Filename.concat "/" mnt.tgt in

     

       138
       138
       +
               { mnt with tgt; src })

     

       139
       139
       +
             v.mounts

     

       140
       140
       +
         in

     

       141
       141
       +
         let root_flags =

     

       142
       142
       +
           if root_mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty

     

       143
       143
       +
         in

     

       144
       144
       +
         let mounts = pivot_root root root_flags tmpfs mounts in

     

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

     

       146
       146
       +
         let user_namespace = map_uid_gid ~uid ~gid in

     

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

     

       148
       148
       +
       

     

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

     

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

     

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

     

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

     

       153
       153
       +
       

     

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

     

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

     

       156
       156
       +
         { v with mounts = { src; tgt; mode } :: v.mounts }

     

       157
       157
       +
       

     

       158
       158
       +
       (* From eio_linux/eio_posix *)

     

       159
       159
       +
       let with_pipe fn =

     

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

     

       161
       161
       +
         let r, w = Eio_posix.Low_level.pipe ~sw in

     

       162
       162
       +
         fn r w

     

       163
       163
       +
       

     

       164
       164
       +
       external pidfd_send_signal : Unix.file_descr -> int -> unit

     

       165
       165
       +
         = "caml_void_pidfd_send_signal"

     

       166
       166
       +
       

     

       167
       167
       +
       let signal t signum =

     

       168
       168
       +
         Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd ->

     

       169
       169
       +
         pidfd_send_signal pid_fd signum

     

       170
       170
       +
       

     

       171
       171
       +
       let rec waitpid pid =

     

       172
       172
       +
         match Unix.waitpid [] pid with

     

       173
       173
       +
         | p, status ->

     

       174
       174
       +
             assert (p = pid);

     

       175
       175
       +
             status

     

       176
       176
       +
         | exception Unix.Unix_error (EINTR, _, _) -> waitpid pid

     

       177
       177
       +
       

     

       178
       178
       +
       let spawn ~sw v =

     

       179
       179
       +
         with_pipe @@ fun errors_r errors_w ->

     

       180
       180
       +
         Eio_unix.Private.Fork_action.with_actions (actions v) @@ fun c_actions ->

     

       181
       181
       +
         Switch.check sw;

     

       182
       182
       +
         let exit_status, set_exit_status = Promise.create () in

     

       183
       183
       +
         let t =

     

       184
       184
       +
           let pid, pid_fd =

     

       185
       185
       +
             Fd.use_exn "errors-w" errors_w @@ fun errors_w ->

     

       186
       186
       +
             Eio.Private.Trace.with_span "spawn" @@ fun () ->

     

       187
       187
       +
             let flags = Flags.(clone_pidfd + void_flags) in

     

       188
       188
       +
             eio_spawn errors_w flags c_actions

     

       189
       189
       +
           in

     

       190
       190
       +
           let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in

     

       191
       191
       +
           { pid; pid_fd; exit_status }

     

       192
       192
       +
         in

     

       193
       193
       +
         Fd.close errors_w;

     

       194
       194
       +
         Fiber.fork_daemon ~sw (fun () ->

     

       195
       195
       +
             let cleanup () =

     

       196
       196
       +
               Fd.close t.pid_fd;

     

       197
       197
       +
               Promise.resolve set_exit_status (waitpid t.pid);

     

       198
       198
       +
               `Stop_daemon

     

       199
       199
       +
             in

     

       200
       200
       +
             match Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd with

     

       201
       201
       +
             | () -> Eio.Cancel.protect cleanup

     

       202
       202
       +
             | exception Eio.Cancel.Cancelled _ ->

     

       203
       203
       +
                 Eio.Cancel.protect (fun () ->

     

       204
       204
       +
                     Printf.eprintf "Cancelled?";

     

       205
       205
       +
                     signal t Sys.sigkill;

     

       206
       206
       +
                     Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd;

     

       207
       207
       +
                     cleanup ()));

     

       208
       208
       +
         (* Check for errors starting the process. *)

     

       209
       209
       +
         match read_response errors_r with

     

       210
       210
       +
         | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *)

     

       211
       211
       +
         | err -> failwith err

     

       212
       212
       +
       

     

       213
       213
       +
       let to_eio_status t =

     

       214
       214
       +
         match t with

     

       215
       215
       +
         | Unix.WEXITED i -> `Exited i

     

       216
       216
       +
         | Unix.WSIGNALED i -> `Signaled i

     

       217
       217
       +
         | Unix.WSTOPPED _ -> assert false

     

       218
       218
       +
       

     

       219
       219
       +
       let exit_status_to_string = function

     

       220
       220
       +
         | Unix.WEXITED n -> Printf.sprintf "Exited with %i" n

     

       221
       221
       +
         | Unix.WSTOPPED n -> Printf.sprintf "Stopped with %i" n

     

       222
       222
       +
         | Unix.WSIGNALED n -> Printf.sprintf "Signalled with %i" n

+68

vendor/void/src/void.mli

···

       1
       1
       +
       (** {1 Void}

     

       2
       2
       +
       

     

       3
       3
       +
           Void is a library to provide {e void processes}. A void process is an

     

       4
       4
       +
           {e empty} process, one in which most global resources have been removed. As

     

       5
       5
       +
           a user, you can add back in precisely those pieces you need for your

     

       6
       6
       +
           process.

     

       7
       7
       +
       

     

       8
       8
       +
           Void uses Eio's [fork_action]s to provide this mechanism, thus it is only

     

       9
       9
       +
           available with Eio. *)

     

       10
       10
       +
       

     

       11
       11
       +
       module Mount : sig

     

       12
       12
       +
         module Flags : sig

     

       13
       13
       +
           type t = private int

     

       14
       14
       +
       

     

       15
       15
       +
           val ms_remount : t

     

       16
       16
       +
           val ms_bind : t

     

       17
       17
       +
           val ms_shared : t

     

       18
       18
       +
           val ( + ) : t -> t -> t

     

       19
       19
       +
         end

     

       20
       20
       +
       

     

       21
       21
       +
         module Types : sig

     

       22
       22
       +
           type t = private string

     

       23
       23
       +
       

     

       24
       24
       +
           val btrfs : t

     

       25
       25
       +
           val ext4 : t

     

       26
       26
       +
           val auto : t

     

       27
       27
       +
         end

     

       28
       28
       +
       end

     

       29
       29
       +
       

     

       30
       30
       +
       type t

     

       31
       31
       +
       (** A void process *)

     

       32
       32
       +
       

     

       33
       33
       +
       type path = string

     

       34
       34
       +
       (** File paths *)

     

       35
       35
       +
       

     

       36
       36
       +
       type mode = R | RW

     

       37
       37
       +
       (* Mounting modes *)

     

       38
       38
       +
       

     

       39
       39
       +
       type void

     

       40
       40
       +
       (** A configuration for a void process *)

     

       41
       41
       +
       

     

       42
       42
       +
       val empty : void

     

       43
       43
       +
       (** The empty void *)

     

       44
       44
       +
       

     

       45
       45
       +
       val rootfs : mode:mode -> path -> void -> void

     

       46
       46
       +
       (** Add a new root filesystem *)

     

       47
       47
       +
       

     

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

     

       49
       49
       +
       

     

       50
       50
       +
       

     

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

     

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

     

       53
       53
       +
       

     

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

     

       55
       55
       +
       (** Set the UID *)

     

       56
       56
       +
       

     

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

     

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

     

       59
       59
       +
       

     

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

     

       61
       61
       +
       (** Spawn a void process *)

     

       62
       62
       +
       

     

       63
       63
       +
       val pid : t -> int

     

       64
       64
       +
       (** The pid of a running void process *)

     

       65
       65
       +
       

     

       66
       66
       +
       val exit_status : t -> Unix.process_status Eio.Promise.t

     

       67
       67
       +
       val exit_status_to_string : Unix.process_status -> string

     

       68
       68
       +
       val to_eio_status : Unix.process_status -> Eio.Process.exit_status

+420

vendor/void/src/void_action.c

···

       1
       1
       +
       #define _GNU_SOURCE

     

       2
       2
       +
       #define _FILE_OFFSET_BITS 64

     

       3
       3
       +
       #include <linux/sched.h>

     

       4
       4
       +
       

     

       5
       5
       +
       #include <sys/stat.h>

     

       6
       6
       +
       #include <sys/types.h>

     

       7
       7
       +
       #include <sys/eventfd.h>

     

       8
       8
       +
       #if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24

     

       9
       9
       +
       #include <sys/random.h>

     

       10
       10
       +
       #endif

     

       11
       11
       +
       #include <sys/syscall.h>

     

       12
       12
       +
       #include <sys/wait.h>

     

       13
       13
       +
       #include <sys/mount.h>

     

       14
       14
       +
       #include <limits.h>

     

       15
       15
       +
       #include <errno.h>

     

       16
       16
       +
       #include <dirent.h>

     

       17
       17
       +
       #include <fcntl.h>

     

       18
       18
       +
       #include <signal.h>

     

       19
       19
       +
       #include <unistd.h>

     

       20
       20
       +
       #include <string.h>

     

       21
       21
       +
       

     

       22
       22
       +
       

     

       23
       23
       +
       #define CAML_INTERNALS

     

       24
       24
       +
       #include <caml/mlvalues.h>

     

       25
       25
       +
       #include <caml/unixsupport.h>

     

       26
       26
       +
       #include <caml/memory.h>

     

       27
       27
       +
       #include <caml/custom.h>

     

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

     

       29
       29
       +
       #include <caml/fail.h>

     

       30
       30
       +
       #undef CAML_INTERNALS

     

       31
       31
       +
       

     

       32
       32
       +
       // From Eio

     

       33
       33
       +
       #include <include/fork_action.h>

     

       34
       34
       +
       

     

       35
       35
       +
       #ifndef SYS_pidfd_send_signal

     

       36
       36
       +
       #define SYS_pidfd_send_signal 424

     

       37
       37
       +
       #endif

     

       38
       38
       +
       

     

       39
       39
       +
       // struct clone_args isn't defined in linux-lts headers, so define it here

     

       40
       40
       +
       // Note that this struct is versioned by size. See linux/sched.h for details

     

       41
       41
       +
       struct caml_void_clone_args

     

       42
       42
       +
       {

     

       43
       43
       +
         uint64_t flags;

     

       44
       44
       +
         uint64_t pidfd;

     

       45
       45
       +
         uint64_t child_tid;

     

       46
       46
       +
         uint64_t parent_tid;

     

       47
       47
       +
         uint64_t exit_signal;

     

       48
       48
       +
         uint64_t stack;

     

       49
       49
       +
         uint64_t stack_size;

     

       50
       50
       +
         uint64_t tls;

     

       51
       51
       +
       };

     

       52
       52
       +
       

     

       53
       53
       +
       static int

     

       54
       54
       +
       pidfd_send_signal (int pidfd, int sig, siginfo_t *info, unsigned int flags)

     

       55
       55
       +
       {

     

       56
       56
       +
         return syscall (SYS_pidfd_send_signal, pidfd, sig, info, flags);

     

       57
       57
       +
       }

     

       58
       58
       +
       

     

       59
       59
       +
       CAMLprim value

     

       60
       60
       +
       caml_void_pidfd_send_signal (value v_pidfd, value v_signal)

     

       61
       61
       +
       {

     

       62
       62
       +
         CAMLparam0 ();

     

       63
       63
       +
         int res;

     

       64
       64
       +
       

     

       65
       65
       +
         res =

     

       66
       66
       +
           pidfd_send_signal (Int_val (v_pidfd),

     

       67
       67
       +
       		       caml_convert_signal_number (Int_val (v_signal)), NULL,

     

       68
       68
       +
       		       0);

     

       69
       69
       +
         if (res == -1)

     

       70
       70
       +
           uerror ("pidfd_send_signal", Nothing);

     

       71
       71
       +
         CAMLreturn (Val_unit);

     

       72
       72
       +
       }

     

       73
       73
       +
       

     

       74
       74
       +
       static pid_t

     

       75
       75
       +
       clone3_no_fallback (struct caml_void_clone_args *cl_args)

     

       76
       76
       +
       {

     

       77
       77
       +
         int *pidfd = (int *) (uintptr_t) cl_args->pidfd;

     

       78
       78
       +
         pid_t child_pid =

     

       79
       79
       +
           syscall (SYS_clone3, cl_args, sizeof (struct caml_void_clone_args));

     

       80
       80
       +
       

     

       81
       81
       +
         if (child_pid >= 0)

     

       82
       82
       +
           return child_pid;		/* Success! */

     

       83
       83
       +
       

     

       84
       84
       +
         if (errno != ENOSYS && errno != EPERM)

     

       85
       85
       +
           {

     

       86
       86
       +
             uerror ("clone3", Nothing);	/* Unknown error */

     

       87
       87
       +
           }

     

       88
       88
       +
       

     

       89
       89
       +
         uerror ("clone3", Nothing);

     

       90
       90
       +
       }

     

       91
       91
       +
       

     

       92
       92
       +
       CAMLprim value

     

       93
       93
       +
       caml_void_clone3 (value v_errors, value v_flags, value v_actions)

     

       94
       94
       +
       {

     

       95
       95
       +
         CAMLparam1 (v_actions);

     

       96
       96
       +
         CAMLlocal1 (v_result);

     

       97
       97
       +
         pid_t child_pid;

     

       98
       98
       +
         int pidfd = -1;		/* Is automatically close-on-exec */

     

       99
       99
       +
       

     

       100
       100
       +
         struct caml_void_clone_args cl_args = {

     

       101
       101
       +
           .flags = Int_val (v_flags),

     

       102
       102
       +
           .pidfd = (uintptr_t) & pidfd,

     

       103
       103
       +
           .exit_signal = SIGCHLD,	/* Needed for wait4 to work if we exit before exec */

     

       104
       104
       +
           .stack = (uintptr_t) NULL,	/* Use copy-on-write parent stack */

     

       105
       105
       +
           .stack_size = 0,

     

       106
       106
       +
         };

     

       107
       107
       +
       

     

       108
       108
       +
         child_pid = clone3_no_fallback (&cl_args);

     

       109
       109
       +
         if (child_pid == 0)

     

       110
       110
       +
           {

     

       111
       111
       +
             /* Run child actions (doesn't return) */

     

       112
       112
       +
             eio_unix_run_fork_actions (Int_val (v_errors), v_actions);

     

       113
       113
       +
           }

     

       114
       114
       +
       

     

       115
       115
       +
         v_result = caml_alloc_tuple (2);

     

       116
       116
       +
         Store_field (v_result, 0, Val_long (child_pid));

     

       117
       117
       +
         Store_field (v_result, 1, Val_int (pidfd));

     

       118
       118
       +
       

     

       119
       119
       +
         CAMLreturn (v_result);

     

       120
       120
       +
       }

     

       121
       121
       +
       

     

       122
       122
       +
       

     

       123
       123
       +
       // Actions 

     

       124
       124
       +
       

     

       125
       125
       +
       // MOUNT/UNMOUNT

     

       126
       126
       +
       static void

     

       127
       127
       +
       action_mount (int errors, value v_config)

     

       128
       128
       +
       {

     

       129
       129
       +
         value v_src = Field (v_config, 1);

     

       130
       130
       +
         value v_tgt = Field (v_config, 2);

     

       131
       131
       +
         value v_type = Field (v_config, 3);

     

       132
       132
       +
         value v_flags = Field (v_config, 4);

     

       133
       133
       +
       

     

       134
       134
       +
         int r;

     

       135
       135
       +
       

     

       136
       136
       +
         r =

     

       137
       137
       +
           mount (String_val (v_src), String_val (v_tgt), String_val (v_type),

     

       138
       138
       +
       	   Int_val (v_flags), NULL);

     

       139
       139
       +
       

     

       140
       140
       +
         if (r != 0)

     

       141
       141
       +
           {

     

       142
       142
       +
             eio_unix_fork_error (errors, "mount", strerror (errno));

     

       143
       143
       +
             _exit (1);

     

       144
       144
       +
           }

     

       145
       145
       +
       }

     

       146
       146
       +
       

     

       147
       147
       +
       CAMLprim value

     

       148
       148
       +
       void_fork_mount (value v_unit)

     

       149
       149
       +
       {

     

       150
       150
       +
         return Val_fork_fn (action_mount);

     

       151
       151
       +
       }

     

       152
       152
       +
       

     

       153
       153
       +
       // Writes a single line to a file

     

       154
       154
       +
       static int

     

       155
       155
       +
       put_line (const char *filename, const char *line)

     

       156
       156
       +
       {

     

       157
       157
       +
         int fd;

     

       158
       158
       +
         int written;

     

       159
       159
       +
       

     

       160
       160
       +
         fd = open (filename, O_WRONLY | O_CLOEXEC | O_CREAT | O_TRUNC, 0644);

     

       161
       161
       +
       

     

       162
       162
       +
         if (fd < 0)

     

       163
       163
       +
           {

     

       164
       164
       +
             return fd;

     

       165
       165
       +
           }

     

       166
       166
       +
       

     

       167
       167
       +
         written = write (fd, line, strlen (line));

     

       168
       168
       +
       

     

       169
       169
       +
         close (fd);

     

       170
       170
       +
       

     

       171
       171
       +
         if (written != strlen (line))

     

       172
       172
       +
           {

     

       173
       173
       +
             return -1;

     

       174
       174
       +
           }

     

       175
       175
       +
       

     

       176
       176
       +
         return 0;

     

       177
       177
       +
       }

     

       178
       178
       +
       

     

       179
       179
       +
       // MAP UID/GID to root

     

       180
       180
       +
       static void

     

       181
       181
       +
       action_map_uid_gid (int errors, value v_config)

     

       182
       182
       +
       {

     

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

     

       184
       184
       +
         value v_gid = Field (v_config, 2);

     

       185
       185
       +
         int result;

     

       186
       186
       +
         char uid_line[30];

     

       187
       187
       +
         char gid_line[30];

     

       188
       188
       +
       

     

       189
       189
       +
         // We map root onto the calling UID

     

       190
       190
       +
         snprintf (uid_line, sizeof (uid_line), "0 %i 1\n", Int_val (v_uid));

     

       191
       191
       +
         result = put_line ("/proc/self/uid_map", uid_line);

     

       192
       192
       +
       

     

       193
       193
       +
         if (result < 0)

     

       194
       194
       +
           {

     

       195
       195
       +
             eio_unix_fork_error (errors, "map_uid_gid-uid", strerror (errno));

     

       196
       196
       +
             _exit (1);

     

       197
       197
       +
           }

     

       198
       198
       +
       

     

       199
       199
       +
         /* From user_namespaces(7)

     

       200
       200
       +
          *

     

       201
       201
       +
          * Writing "deny" to the /proc/pid/setgroups file before writing to

     

       202
       202
       +
          * /proc/pid/gid_map will permanently disable setgroups(2) in a user

     

       203
       203
       +
          * namespace and allow writing to /proc/pid/gid_map without having

     

       204
       204
       +
          * the CAP_SETGID capability in the parent user namespace.

     

       205
       205
       +
          *

     

       206
       206
       +
          * See also: https://lwn.net/Articles/626665/ */

     

       207
       207
       +
       

     

       208
       208
       +
         put_line ("/proc/self/setgroups", "deny\n");

     

       209
       209
       +
       

     

       210
       210
       +
         if (result < 0)

     

       211
       211
       +
           {

     

       212
       212
       +
             eio_unix_fork_error (errors, "map_uid_gid-setgroups", strerror (errno));

     

       213
       213
       +
             _exit (1);

     

       214
       214
       +
           }

     

       215
       215
       +
       

     

       216
       216
       +
         result =

     

       217
       217
       +
           snprintf (gid_line, sizeof (gid_line), "0 %i 1\n", Int_val (v_gid));

     

       218
       218
       +
         put_line ("/proc/self/gid_map", gid_line);

     

       219
       219
       +
       

     

       220
       220
       +
         if (result < 0)

     

       221
       221
       +
           {

     

       222
       222
       +
             eio_unix_fork_error (errors, "map_uid_gid-gid", strerror (errno));

     

       223
       223
       +
             _exit (1);

     

       224
       224
       +
           }

     

       225
       225
       +
       }

     

       226
       226
       +
       

     

       227
       227
       +
       

     

       228
       228
       +
       CAMLprim value

     

       229
       229
       +
       void_fork_map_uid_gid (value v_unit)

     

       230
       230
       +
       {

     

       231
       231
       +
         return Val_fork_fn (action_map_uid_gid);

     

       232
       232
       +
       }

     

       233
       233
       +
       

     

       234
       234
       +
       static void

     

       235
       235
       +
       action_setuid (int errors, value v_config)

     

       236
       236
       +
       {

     

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

     

       238
       238
       +
       

     

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

     

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

     

       241
       241
       +
         //     _exit (1);

     

       242
       242
       +
         // }

     

       243
       243
       +
       }

     

       244
       244
       +
       

     

       245
       245
       +
       // SETUID

     

       246
       246
       +
       CAMLprim value

     

       247
       247
       +
       void_fork_setuid (value v_unit)

     

       248
       248
       +
       {

     

       249
       249
       +
         return Val_fork_fn (action_setuid);

     

       250
       250
       +
       }

     

       251
       251
       +
       

     

       252
       252
       +
       // PIVOT ROOT

     

       253
       253
       +
       //

     

       254
       254
       +
       static int

     

       255
       255
       +
       pivot_root (const char *new_root, const char *put_old)

     

       256
       256
       +
       {

     

       257
       257
       +
         return syscall (SYS_pivot_root, new_root, put_old);

     

       258
       258
       +
       }

     

       259
       259
       +
       

     

       260
       260
       +
       // Is there too much OCaml stuff going on here for a fork_action ?

     

       261
       261
       +
       static void

     

       262
       262
       +
       action_pivot_root (int errors, value v_config)

     

       263
       263
       +
       {

     

       264
       264
       +
         value v_new_root = Field (v_config, 1);

     

       265
       265
       +
         value v_root_flags = Field (v_config, 2);

     

       266
       266
       +
         value v_no_root = Field (v_config, 3);

     

       267
       267
       +
         value v_mounts = Field (v_config, 4);

     

       268
       268
       +
         char path[PATH_MAX];

     

       269
       269
       +
         char old_root_path[PATH_MAX];

     

       270
       270
       +
         char *new_root = String_val (v_new_root);

     

       271
       271
       +
         const char *put_old = ".old_root";

     

       272
       272
       +
       

     

       273
       273
       +
         // From pivot_root example: We want to change the propagation type

     

       274
       274
       +
         // of root to be private so we can pivot it.

     

       275
       275
       +
         if (mount (NULL, "/", NULL, MS_REC | MS_PRIVATE, NULL) == -1)

     

       276
       276
       +
           {

     

       277
       277
       +
             eio_unix_fork_error (errors, "pivot_root-private", strerror (errno));

     

       278
       278
       +
             _exit (1);

     

       279
       279
       +
           }

     

       280
       280
       +
       

     

       281
       281
       +
         // If no pivot_root was given, then we tmpfs the tmpdir we assume was passed.

     

       282
       282
       +
         if (Bool_val (v_no_root))

     

       283
       283
       +
           {

     

       284
       284
       +
             // Make a temporary directory... can't because it allocates ?

     

       285
       285
       +
             //if (mkdtemp(new_root) != NULL) {

     

       286
       286
       +
             //  eio_unix_fork_error(errors, new_root, strerror(errno));

     

       287
       287
       +
             //  _exit(1);

     

       288
       288
       +
             //}

     

       289
       289
       +
       

     

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

     

       291
       291
       +
       		{

     

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

     

       293
       293
       +
       		  _exit (1);

     

       294
       294
       +
       		}

     

       295
       295
       +
           }

     

       296
       296
       +
         else

     

       297
       297
       +
           {

     

       298
       298
       +
             // From pivot_root example: we check that new_root is indeed a mountpoint 

     

       299
       299
       +
             if (mount (new_root, new_root, NULL, MS_BIND, NULL) <= -1)

     

       300
       300
       +
       	{

     

       301
       301
       +
       	  eio_unix_fork_error (errors, "pivot_root-new_root",

     

       302
       302
       +
       			       strerror (errno));

     

       303
       303
       +
       	  _exit (1);

     

       304
       304
       +
       	}

     

       305
       305
       +
           }

     

       306
       306
       +
       

     

       307
       307
       +
         // Make the place to pivot the old root too, under the new root

     

       308
       308
       +
         snprintf (old_root_path, sizeof (path), "%s/%s", new_root, put_old);

     

       309
       309
       +
       

     

       310
       310
       +
         if (mkdir (old_root_path, 0777) == -1)

     

       311
       311
       +
           {

     

       312
       312
       +
             eio_unix_fork_error (errors, "pivot_root-mkdir-put_old",

     

       313
       313
       +
       			   strerror (errno));

     

       314
       314
       +
             _exit (1);

     

       315
       315
       +
           }

     

       316
       316
       +
       

     

       317
       317
       +
         // Pivot the root

     

       318
       318
       +
         if (pivot_root (new_root, old_root_path))

     

       319
       319
       +
           {

     

       320
       320
       +
             eio_unix_fork_error (errors, "pivot_root", strerror (errno));

     

       321
       321
       +
             _exit (1);

     

       322
       322
       +
           }

     

       323
       323
       +
       

     

       324
       324
       +
         // Add mounts

     

       325
       325
       +
         value current_mount = v_mounts;

     

       326
       326
       +
         int mount_result;

     

       327
       327
       +
         int mode;

     

       328
       328
       +
         while (current_mount != Val_emptylist)

     

       329
       329
       +
           {

     

       330
       330
       +
             // TODO: Mode for mounting

     

       331
       331
       +
             mode = Int_val (Field (Field (current_mount, 0), 2));

     

       332
       332
       +
       

     

       333
       333
       +
             // A mount is a record {src; tgt; mode}, we first create the mount point

     

       334
       334
       +
             // directory target

     

       335
       335
       +
             if (mkdir (String_val (Field (Field (current_mount, 0), 1)), 0777) ==

     

       336
       336
       +
       	  -1)

     

       337
       337
       +
       	{

     

       338
       338
       +
       	  eio_unix_fork_error (errors, "pivot_root-mkdir-mount",

     

       339
       339
       +
       			       strerror (errno));

     

       340
       340
       +
       	  _exit (1);

     

       341
       341
       +
       	}

     

       342
       342
       +
       

     

       343
       343
       +
             mount_result = mount (String_val (Field (Field (current_mount, 0), 0)),

     

       344
       344
       +
       			    String_val (Field (Field (current_mount, 0), 1)),

     

       345
       345
       +
       			    NULL, MS_REC | MS_BIND, NULL);

     

       346
       346
       +
       

     

       347
       347
       +
             // Fail early if a mount fails...

     

       348
       348
       +
             if (mount_result < 0)

     

       349
       349
       +
       	{

     

       350
       350
       +
       	  char error[PATH_MAX];

     

       351
       351
       +
       	  snprintf (error, sizeof (error), "mount failed: (%s->%s)",

     

       352
       352
       +
       		    String_val (Field (Field (current_mount, 0), 0)),

     

       353
       353
       +
       		    String_val (Field (Field (current_mount, 0), 1)));

     

       354
       354
       +
       	  eio_unix_fork_error (errors, error, strerror (errno));

     

       355
       355
       +
       	  _exit (1);

     

       356
       356
       +
       	}

     

       357
       357
       +
       

     

       358
       358
       +
             // After mounting for the first time, we can come back and add any

     

       359
       359
       +
             // extra modes that may have been specified, for example RDONLY.

     

       360
       360
       +
             if (mode != 0)

     

       361
       361
       +
       	{

     

       362
       362
       +
       	  mount_result =

     

       363
       363
       +
       	    mount (String_val (Field (Field (current_mount, 0), 0)),

     

       364
       364
       +
       		   String_val (Field (Field (current_mount, 0), 1)), NULL,

     

       365
       365
       +
       		   MS_REMOUNT | MS_BIND | mode, NULL);

     

       366
       366
       +
       

     

       367
       367
       +
       	  if (mount_result < 0)

     

       368
       368
       +
       	    {

     

       369
       369
       +
       	      eio_unix_fork_error (errors, "remount for mode",

     

       370
       370
       +
       				   strerror (errno));

     

       371
       371
       +
       	      _exit (1);

     

       372
       372
       +
       	    }

     

       373
       373
       +
       	}

     

       374
       374
       +
       

     

       375
       375
       +
             // Next mount in the list

     

       376
       376
       +
             current_mount = Field (current_mount, 1);

     

       377
       377
       +
           }

     

       378
       378
       +
       

     

       379
       379
       +
       

     

       380
       380
       +
         // Change to the 'new' root

     

       381
       381
       +
         if (chdir ("/") == -1)

     

       382
       382
       +
           {

     

       383
       383
       +
             eio_unix_fork_error (errors, "pivot_root-chdir", strerror (errno));

     

       384
       384
       +
             _exit (1);

     

       385
       385
       +
           }

     

       386
       386
       +
       

     

       387
       387
       +
         // Unmount the old root and remove it

     

       388
       388
       +
         if (umount2 (put_old, MNT_DETACH) == -1)

     

       389
       389
       +
           {

     

       390
       390
       +
             eio_unix_fork_error (errors, put_old, strerror (errno));

     

       391
       391
       +
             _exit (1);

     

       392
       392
       +
           }

     

       393
       393
       +
       

     

       394
       394
       +
         // Remove the old root

     

       395
       395
       +
         if (rmdir (put_old) == -1)

     

       396
       396
       +
           {

     

       397
       397
       +
             eio_unix_fork_error (errors, put_old, strerror (errno));

     

       398
       398
       +
             _exit (1);

     

       399
       399
       +
           }

     

       400
       400
       +
       

     

       401
       401
       +
       

     

       402
       402
       +
         // Apply any flags to the new root, e.g. RDONLY

     

       403
       403
       +
         if (Int_val (v_root_flags))

     

       404
       404
       +
           {

     

       405
       405
       +
             if (mount

     

       406
       406
       +
       	  ("/", "/", NULL, (MS_REMOUNT | MS_BIND | Int_val (v_root_flags)),

     

       407
       407
       +
       	   NULL) <= -1)

     

       408
       408
       +
       	{

     

       409
       409
       +
       	  eio_unix_fork_error (errors, "pivot_root-rootflags",

     

       410
       410
       +
       			       strerror (errno));

     

       411
       411
       +
       	  _exit (1);

     

       412
       412
       +
       	}

     

       413
       413
       +
           }

     

       414
       414
       +
       }

     

       415
       415
       +
       

     

       416
       416
       +
       CAMLprim value

     

       417
       417
       +
       void_fork_pivot_root (value v_unit)

     

       418
       418
       +
       {

     

       419
       419
       +
         return Val_fork_fn (action_pivot_root);

     

       420
       420
       +
       }

vendor/void/test/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (name main)

     

       3
       3
       +
        (libraries void))

+20

vendor/void/test/main.ml

···

       1
       1
       +
       open Eio.Std

     

       2
       2
       +
       

     

       3
       3
       +
       let _root_filesystem =

     

       4
       4
       +
         "/obuilder-zfs/result/fe532e693c6a86db16b50547aae1345b3515c727b8ed668b3e0c33c1e9a895f9/rootfs"

     

       5
       5
       +
       

     

       6
       6
       +
       let () =

     

       7
       7
       +
         Eio_posix.run @@ fun _ ->

     

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

     

       9
       9
       +
         let open Void in

     

       10
       10
       +
         let void =

     

       11
       11
       +
           empty

     

       12
       12
       +
           |> mount ~mode:R ~src:"/tmp/test" ~tgt:"bin"

     

       13
       13
       +
           |> exec [ "/bin/busybox"; "ls" ]

     

       14
       14
       +
         in

     

       15
       15
       +
         let t = Void.spawn ~sw void in

     

       16
       16
       +
         match Promise.await (Void.exit_status t) with

     

       17
       17
       +
         | Unix.WEXITED 0 -> print_endline "done"

     

       18
       18
       +
         | Unix.WEXITED n -> Printf.printf "Exited with %i\n%!" n

     

       19
       19
       +
         | Unix.WSTOPPED n -> Printf.printf "Stopped with %i\n%!" n

     

       20
       20
       +
         | Unix.WSIGNALED n -> Printf.printf "Signalled with %i\n%!" n

+32

vendor/void/void.opam

···

       1
       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       +
       opam-version: "2.0"

     

       3
       3
       +
       synopsis: "Void Processes in Eio_linux"

     

       4
       4
       +
       description: "A longer description"

     

       5
       5
       +
       maintainer: ["Patrick Ferris"]

     

       6
       6
       +
       authors: ["Patrick Ferris"]

     

       7
       7
       +
       license: "MIT"

     

       8
       8
       +
       tags: ["linux" "process" "spawn"]

     

       9
       9
       +
       homepage: "https://github.com/patricoferris/void"

     

       10
       10
       +
       doc: "https://ocaml.org/p/void"

     

       11
       11
       +
       bug-reports: "https://github.com/patricoferris/void/issues"

     

       12
       12
       +
       depends: [

     

       13
       13
       +
         "ocaml"

     

       14
       14
       +
         "dune" {>= "3.15"}

     

       15
       15
       +
         "eio_posix"

     

       16
       16
       +
         "odoc" {with-doc}

     

       17
       17
       +
       ]

     

       18
       18
       +
       build: [

     

       19
       19
       +
         ["dune" "subst"] {dev}

     

       20
       20
       +
         [

     

       21
       21
       +
           "dune"

     

       22
       22
       +
           "build"

     

       23
       23
       +
           "-p"

     

       24
       24
       +
           name

     

       25
       25
       +
           "-j"

     

       26
       26
       +
           jobs

     

       27
       27
       +
           "@install"

     

       28
       28
       +
           "@runtest" {with-test}

     

       29
       29
       +
           "@doc" {with-doc}

     

       30
       30
       +
         ]

     

       31
       31
       +
       ]

     

       32
       32
       +
       dev-repo: "git+https://github.com/patricoferris/void.git"

vendor/zfs/.gitignore

vendor/zfs/.ocamlformat

···

       1
       1
       +
       version=0.27.0

+12

vendor/zfs/README.md

···

       1
       1
       +
       ocaml-zfs

     

       2
       2
       +
       ---------

     

       3
       3
       +
       

     

       4
       4
       +
       Some very partial and very probably broken bindings to `libzfs`.

     

       5
       5
       +
       

     

       6
       6
       +
       <!-- $MDX file=example/main.ml -->

     

       7
       7
       +
       ```ocaml

     

       8
       8
       +
       let () =

     

       9
       9
       +
         let handle = Zfs.init () in

     

       10
       10
       +
         let props = [ ("compression", `String "lz4") ] in

     

       11
       11
       +
         Zfs.create ~props handle "obuilder-zfs/hello" Zfs.Types.filesystem

     

       12
       12
       +
       ```

vendor/zfs/dune

···

       1
       1
       +
       (mdx)

+31

vendor/zfs/dune-project

···

       1
       1
       +
       (lang dune 3.15)

     

       2
       2
       +
       (using mdx 0.4)

     

       3
       3
       +
       (using ctypes 0.3)

     

       4
       4
       +
       

     

       5
       5
       +
       (name zfs)

     

       6
       6
       +
       

     

       7
       7
       +
       (generate_opam_files true)

     

       8
       8
       +
       

     

       9
       9
       +
       (source

     

       10
       10
       +
        (github patricoferris/ocaml-zfs))

     

       11
       11
       +
       

     

       12
       12
       +
       (authors "Patrick Ferris <patrick@sirref.org>")

     

       13
       13
       +
       

     

       14
       14
       +
       (maintainers "Patrick Ferris <patrick@sirref.org>")

     

       15
       15
       +
       

     

       16
       16
       +
       (license ISC)

     

       17
       17
       +
       

     

       18
       18
       +
       

     

       19
       19
       +
       (package

     

       20
       20
       +
        (name zfs)

     

       21
       21
       +
        (synopsis "libzfs bindings")

     

       22
       22
       +
        (description "OCaml bindings to libzfs")

     

       23
       23
       +
        (depends 

     

       24
       24
       +
          ocaml 

     

       25
       25
       +
          dune

     

       26
       26
       +
          ctypes

     

       27
       27
       +
          (mdx :with-test))

     

       28
       28
       +
        (tags

     

       29
       29
       +
         ("filesystem" "zfs")))

     

       30
       30
       +
       

     

       31
       31
       +
       ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

vendor/zfs/example/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (name main)

     

       3
       3
       +
        (libraries zfs))

vendor/zfs/example/main.ml

···

       1
       1
       +
       let () =

     

       2
       2
       +
         let handle = Zfs.init () in

     

       3
       3
       +
         let props = [ ("compression", `String "lz4") ] in

     

       4
       4
       +
         Zfs.create ~props handle "obuilder-zfs/hello" Zfs.Types.filesystem

+38

vendor/zfs/src/dune

···

       1
       1
       +
       (rule

     

       2
       2
       +
        (targets config.ml c_flags.sexp c_library_flags.sexp)

     

       3
       3
       +
        (action

     

       4
       4
       +
         (run ./include/discover.exe)))

     

       5
       5
       +
       

     

       6
       6
       +
       (library

     

       7
       7
       +
        (name zfs)

     

       8
       8
       +
        (public_name zfs)

     

       9
       9
       +
        (libraries unix)

     

       10
       10
       +
        (c_library_flags

     

       11
       11
       +
         (:include c_library_flags.sexp))

     

       12
       12
       +
        (flags

     

       13
       13
       +
         (:standard -w -9-27))

     

       14
       14
       +
        (ctypes

     

       15
       15
       +
         (external_library_name libzfs)

     

       16
       16
       +
         (build_flags_resolver

     

       17
       17
       +
          (vendored

     

       18
       18
       +
           (c_flags

     

       19
       19
       +
            :standard

     

       20
       20
       +
            -D_GNU_SOURCE

     

       21
       21
       +
            (:include c_flags.sexp))))

     

       22
       22
       +
         (headers

     

       23
       23
       +
          (include

     

       24
       24
       +
           "unistd.h"

     

       25
       25
       +
           "stdio.h"

     

       26
       26
       +
           "stdint.h"

     

       27
       27
       +
           "stdbool.h"

     

       28
       28
       +
           "libzfs_core.h"

     

       29
       29
       +
           "libzfs.h"))

     

       30
       30
       +
         (type_description

     

       31
       31
       +
          (instance Types)

     

       32
       32
       +
          (functor Type_description))

     

       33
       33
       +
         (function_description

     

       34
       34
       +
          (concurrency unlocked)

     

       35
       35
       +
          (instance Functions)

     

       36
       36
       +
          (functor Function_description))

     

       37
       37
       +
         (generated_types Types_generated)

     

       38
       38
       +
         (generated_entry_point C)))

+99

vendor/zfs/src/function_description.ml

···

       1
       1
       +
       open Ctypes

     

       2
       2
       +
       

     

       3
       3
       +
       (* This Types_generated module is an instantiation of the Types

     

       4
       4
       +
          functor defined in the type_description.ml file. It's generated by

     

       5
       5
       +
          a C program that Dune creates and runs behind the scenes. *)

     

       6
       6
       +
       module Types = Types_generated

     

       7
       7
       +
       

     

       8
       8
       +
       module Functions (F : Ctypes.FOREIGN) = struct

     

       9
       9
       +
         open F

     

       10
       10
       +
       

     

       11
       11
       +
         let init = foreign "libzfs_init" (void @-> returning Types.libzfs_handle_t)

     

       12
       12
       +
         let errno = foreign "libzfs_errno" (Types.libzfs_handle_t @-> returning int)

     

       13
       13
       +
       

     

       14
       14
       +
         let debug =

     

       15
       15
       +
           foreign "libzfs_print_on_error"

     

       16
       16
       +
             (Types.libzfs_handle_t @-> bool @-> returning void)

     

       17
       17
       +
       

     

       18
       18
       +
         module Zpool = struct

     

       19
       19
       +
           let open_ =

     

       20
       20
       +
             foreign "zpool_open"

     

       21
       21
       +
               (Types.libzfs_handle_t @-> string @-> returning Types.zpool_handle_t)

     

       22
       22
       +
       

     

       23
       23
       +
           let close = foreign "zpool_close" (Types.zpool_handle_t @-> returning void)

     

       24
       24
       +
       

     

       25
       25
       +
           let get_name =

     

       26
       26
       +
             foreign "zpool_get_name" (Types.zpool_handle_t @-> returning string)

     

       27
       27
       +
       

     

       28
       28
       +
           let get_state =

     

       29
       29
       +
             foreign "zpool_get_state" (Types.zpool_handle_t @-> returning int)

     

       30
       30
       +
         end

     

       31
       31
       +
       

     

       32
       32
       +
         let create_ancestors =

     

       33
       33
       +
           foreign "zfs_create_ancestors" (Types.libzfs_handle_t @-> string @-> returning int)

     

       34
       34
       +
       

     

       35
       35
       +
         let create =

     

       36
       36
       +
           foreign "zfs_create"

     

       37
       37
       +
             (Types.libzfs_handle_t @-> string @-> int @-> ptr Types.nvlist_t

     

       38
       38
       +
            @-> returning int)

     

       39
       39
       +
       

     

       40
       40
       +
         let open_ =

     

       41
       41
       +
           foreign "zfs_open"

     

       42
       42
       +
             (Types.libzfs_handle_t @-> string @-> int @-> returning Types.zfs_handle_t)

     

       43
       43
       +
       

     

       44
       44
       +
         let mount =

     

       45
       45
       +
           foreign "zfs_mount" (Types.zfs_handle_t @-> string @-> int @-> returning int)

     

       46
       46
       +
       

     

       47
       47
       +
         let unmount =

     

       48
       48
       +
           foreign "zfs_unmount"

     

       49
       49
       +
             (Types.zfs_handle_t @-> string @-> int @-> returning int)

     

       50
       50
       +
       

     

       51
       51
       +
         let close = foreign "zfs_close" (Types.zfs_handle_t @-> returning void)

     

       52
       52
       +
         let get_type = foreign "zfs_get_type" (Types.zfs_handle_t @-> returning int)

     

       53
       53
       +
       

     

       54
       54
       +
         module Nvlist = struct

     

       55
       55
       +
           let alloc =

     

       56
       56
       +
             foreign "nvlist_alloc"

     

       57
       57
       +
               (ptr (ptr Types.nvlist_t) @-> int @-> int @-> returning int)

     

       58
       58
       +
       

     

       59
       59
       +
           let free = foreign "nvlist_free" (ptr Types.nvlist_t @-> returning void)

     

       60
       60
       +
       

     

       61
       61
       +
           let add_bool =

     

       62
       62
       +
             foreign "nvlist_add_boolean_value"

     

       63
       63
       +
               (ptr Types.nvlist_t @-> string @-> bool @-> returning int)

     

       64
       64
       +
       

     

       65
       65
       +
           let add_string =

     

       66
       66
       +
             foreign "nvlist_add_string"

     

       67
       67
       +
               (ptr Types.nvlist_t @-> string @-> string @-> returning int)

     

       68
       68
       +
       

     

       69
       69
       +
           let add_byte =

     

       70
       70
       +
             foreign "nvlist_add_byte"

     

       71
       71
       +
               (ptr Types.nvlist_t @-> string @-> uchar @-> returning int)

     

       72
       72
       +
       

     

       73
       73
       +
           let add_int64 =

     

       74
       74
       +
             foreign "nvlist_add_int64"

     

       75
       75
       +
               (ptr Types.nvlist_t @-> string @-> int64_t @-> returning int)

     

       76
       76
       +
         end

     

       77
       77
       +
       

     

       78
       78
       +
         let clone =

     

       79
       79
       +
           foreign "zfs_clone"

     

       80
       80
       +
             (Types.zfs_handle_t @-> string @-> ptr Types.nvlist_t @-> returning int)

     

       81
       81
       +
       

     

       82
       82
       +
         let snapshot =

     

       83
       83
       +
           foreign "zfs_snapshot"

     

       84
       84
       +
             (Types.libzfs_handle_t @-> string @-> bool @-> ptr Types.nvlist_t

     

       85
       85
       +
            @-> returning int)

     

       86
       86
       +
       

     

       87
       87
       +
         let exists =

     

       88
       88
       +
           foreign "zfs_dataset_exists"

     

       89
       89
       +
             (Types.libzfs_handle_t @-> string @-> int @-> returning bool)

     

       90
       90
       +
       

     

       91
       91
       +
         let is_mounted =

     

       92
       92
       +
           foreign "is_mounted"

     

       93
       93
       +
             (Types.libzfs_handle_t @-> string @-> ptr string @-> returning bool)

     

       94
       94
       +
       

     

       95
       95
       +
         let diff =

     

       96
       96
       +
           foreign "zfs_show_diffs"

     

       97
       97
       +
             (Types.zfs_handle_t @-> int @-> string @-> string_opt @-> int

     

       98
       98
       +
            @-> returning int)

     

       99
       99
       +
       end

+209

vendor/zfs/src/include/discover.ml

···

       1
       1
       +
       module C = Configurator.V1

     

       2
       2
       +
       

     

       3
       3
       +
       let starts_with ~prefix s =

     

       4
       4
       +
         try

     

       5
       5
       +
           String.iteri

     

       6
       6
       +
             (fun i c -> if Char.equal (String.get s i) c then () else raise Not_found)

     

       7
       7
       +
             prefix;

     

       8
       8
       +
           let l = String.length s in

     

       9
       9
       +
           let o = String.length prefix in

     

       10
       10
       +
           Some (String.sub s o (l - o))

     

       11
       11
       +
         with Not_found -> None

     

       12
       12
       +
       

     

       13
       13
       +
       let () =

     

       14
       14
       +
         C.main ~name:"discover" (fun c ->

     

       15
       15
       +
             let pkgconf =

     

       16
       16
       +
               C.Pkg_config.get c |> function

     

       17
       17
       +
               | Some p -> p

     

       18
       18
       +
               | None -> failwith "Need pkgconfig"

     

       19
       19
       +
             in

     

       20
       20
       +
             match C.Pkg_config.query pkgconf ~package:"libzfs" with

     

       21
       21
       +
             | None -> failwith "Pkgconfig failed to find libzfs"

     

       22
       22
       +
             | Some conf ->

     

       23
       23
       +
                 C.Flags.write_sexp "c_flags.sexp" conf.cflags;

     

       24
       24
       +
                 C.Flags.write_sexp "c_library_flags.sexp" conf.libs;

     

       25
       25
       +
                 let errs, props, types =

     

       26
       26
       +
                   C.C_define.import c

     

       27
       27
       +
                     ~c_flags:("-D_GNU_SOURCE" :: conf.cflags)

     

       28
       28
       +
                     ~includes:

     

       29
       29
       +
                       [

     

       30
       30
       +
                         "unistd.h";

     

       31
       31
       +
                         "stdio.h";

     

       32
       32
       +
                         "stdint.h";

     

       33
       33
       +
                         "stdbool.h";

     

       34
       34
       +
                         "libzfs_core.h";

     

       35
       35
       +
                         "libzfs.h";

     

       36
       36
       +
                       ]

     

       37
       37
       +
                     C.C_define.Type.

     

       38
       38
       +
                       [

     

       39
       39
       +
                         (* Errors *)

     

       40
       40
       +
                         ("EZFS_SUCCESS", Int);

     

       41
       41
       +
                         ("EZFS_NOMEM", Int);

     

       42
       42
       +
                         ("EZFS_BADPROP", Int);

     

       43
       43
       +
                         ("EZFS_PROPREADONLY", Int);

     

       44
       44
       +
                         ("EZFS_PROPTYPE", Int);

     

       45
       45
       +
                         ("EZFS_PROPNONINHERIT", Int);

     

       46
       46
       +
                         ("EZFS_PROPSPACE", Int);

     

       47
       47
       +
                         ("EZFS_BADTYPE", Int);

     

       48
       48
       +
                         ("EZFS_BUSY", Int);

     

       49
       49
       +
                         ("EZFS_EXISTS", Int);

     

       50
       50
       +
                         ("EZFS_NOENT", Int);

     

       51
       51
       +
                         ("EZFS_BADSTREAM", Int);

     

       52
       52
       +
                         ("EZFS_DSREADONLY", Int);

     

       53
       53
       +
                         ("EZFS_VOLTOOBIG", Int);

     

       54
       54
       +
                         ("EZFS_INVALIDNAME", Int);

     

       55
       55
       +
                         ("EZFS_BADRESTORE", Int);

     

       56
       56
       +
                         ("EZFS_BADBACKUP", Int);

     

       57
       57
       +
                         ("EZFS_BADTARGET", Int);

     

       58
       58
       +
                         ("EZFS_NODEVICE", Int);

     

       59
       59
       +
                         ("EZFS_BADDEV", Int);

     

       60
       60
       +
                         ("EZFS_NOREPLICAS", Int);

     

       61
       61
       +
                         ("EZFS_RESILVERING", Int);

     

       62
       62
       +
                         ("EZFS_BADVERSION", Int);

     

       63
       63
       +
                         ("EZFS_POOLUNAVAIL", Int);

     

       64
       64
       +
                         ("EZFS_DEVOVERFLOW", Int);

     

       65
       65
       +
                         ("EZFS_BADPATH", Int);

     

       66
       66
       +
                         ("EZFS_CROSSTARGET", Int);

     

       67
       67
       +
                         ("EZFS_ZONED", Int);

     

       68
       68
       +
                         ("EZFS_MOUNTFAILED", Int);

     

       69
       69
       +
                         ("EZFS_UMOUNTFAILED", Int);

     

       70
       70
       +
                         ("EZFS_UNSHARENFSFAILED", Int);

     

       71
       71
       +
                         ("EZFS_SHARENFSFAILED", Int);

     

       72
       72
       +
                         ("EZFS_PERM", Int);

     

       73
       73
       +
                         ("EZFS_NOSPC", Int);

     

       74
       74
       +
                         ("EZFS_FAULT", Int);

     

       75
       75
       +
                         ("EZFS_IO", Int);

     

       76
       76
       +
                         ("EZFS_INTR", Int);

     

       77
       77
       +
                         ("EZFS_ISSPARE", Int);

     

       78
       78
       +
                         ("EZFS_INVALCONFIG", Int);

     

       79
       79
       +
                         ("EZFS_RECURSIVE", Int);

     

       80
       80
       +
                         ("EZFS_NOHISTORY", Int);

     

       81
       81
       +
                         ("EZFS_POOLPROPS", Int);

     

       82
       82
       +
                         ("EZFS_POOL_NOTSUP", Int);

     

       83
       83
       +
                         ("EZFS_POOL_INVALARG", Int);

     

       84
       84
       +
                         ("EZFS_NAMETOOLONG", Int);

     

       85
       85
       +
                         ("EZFS_OPENFAILED", Int);

     

       86
       86
       +
                         ("EZFS_NOCAP", Int);

     

       87
       87
       +
                         ("EZFS_LABELFAILED", Int);

     

       88
       88
       +
                         ("EZFS_BADWHO", Int);

     

       89
       89
       +
                         ("EZFS_BADPERM", Int);

     

       90
       90
       +
                         ("EZFS_BADPERMSET", Int);

     

       91
       91
       +
                         ("EZFS_NODELEGATION", Int);

     

       92
       92
       +
                         ("EZFS_UNSHARESMBFAILED", Int);

     

       93
       93
       +
                         ("EZFS_SHARESMBFAILED", Int);

     

       94
       94
       +
                         ("EZFS_BADCACHE", Int);

     

       95
       95
       +
                         ("EZFS_ISL2CACHE", Int);

     

       96
       96
       +
                         ("EZFS_VDEVNOTSUP", Int);

     

       97
       97
       +
                         ("EZFS_NOTSUP", Int);

     

       98
       98
       +
                         ("EZFS_ACTIVE_SPARE", Int);

     

       99
       99
       +
                         ("EZFS_UNPLAYED_LOGS", Int);

     

       100
       100
       +
                         ("EZFS_REFTAG_RELE", Int);

     

       101
       101
       +
                         ("EZFS_REFTAG_HOLD", Int);

     

       102
       102
       +
                         ("EZFS_TAGTOOLONG", Int);

     

       103
       103
       +
                         ("EZFS_PIPEFAILED", Int);

     

       104
       104
       +
                         ("EZFS_THREADCREATEFAILED", Int);

     

       105
       105
       +
                         ("EZFS_POSTSPLIT_ONLINE", Int);

     

       106
       106
       +
                         ("EZFS_SCRUBBING", Int);

     

       107
       107
       +
                         ("EZFS_ERRORSCRUBBING", Int);

     

       108
       108
       +
                         ("EZFS_ERRORSCRUB_PAUSED", Int);

     

       109
       109
       +
                         ("EZFS_NO_SCRUB", Int);

     

       110
       110
       +
                         ("EZFS_DIFF", Int);

     

       111
       111
       +
                         ("EZFS_DIFFDATA", Int);

     

       112
       112
       +
                         ("EZFS_POOLREADONLY", Int);

     

       113
       113
       +
                         ("EZFS_SCRUB_PAUSED", Int);

     

       114
       114
       +
                         ("EZFS_SCRUB_PAUSED_TO_CANCEL", Int);

     

       115
       115
       +
                         ("EZFS_ACTIVE_POOL", Int);

     

       116
       116
       +
                         ("EZFS_CRYPTOFAILED", Int);

     

       117
       117
       +
                         ("EZFS_NO_PENDING", Int);

     

       118
       118
       +
                         ("EZFS_CHECKPOINT_EXISTS", Int);

     

       119
       119
       +
                         ("EZFS_DISCARDING_CHECKPOINT", Int);

     

       120
       120
       +
                         ("EZFS_NO_CHECKPOINT", Int);

     

       121
       121
       +
                         ("EZFS_DEVRM_IN_PROGRESS", Int);

     

       122
       122
       +
                         ("EZFS_VDEV_TOO_BIG", Int);

     

       123
       123
       +
                         ("EZFS_IOC_NOTSUPPORTED", Int);

     

       124
       124
       +
                         ("EZFS_TOOMANY", Int);

     

       125
       125
       +
                         ("EZFS_INITIALIZING", Int);

     

       126
       126
       +
                         ("EZFS_NO_INITIALIZE", Int);

     

       127
       127
       +
                         ("EZFS_WRONG_PARENT", Int);

     

       128
       128
       +
                         ("EZFS_TRIMMING", Int);

     

       129
       129
       +
                         ("EZFS_NO_TRIM", Int);

     

       130
       130
       +
                         ("EZFS_TRIM_NOTSUP", Int);

     

       131
       131
       +
                         ("EZFS_NO_RESILVER_DEFER", Int);

     

       132
       132
       +
                         ("EZFS_EXPORT_IN_PROGRESS", Int);

     

       133
       133
       +
                         ("EZFS_REBUILDING", Int);

     

       134
       134
       +
                         ("EZFS_VDEV_NOTSUP", Int);

     

       135
       135
       +
                         ("EZFS_NOT_USER_NAMESPACE", Int);

     

       136
       136
       +
                         ("EZFS_CKSUM", Int);

     

       137
       137
       +
                         ("EZFS_RESUME_EXISTS", Int);

     

       138
       138
       +
                         ("EZFS_SHAREFAILED", Int);

     

       139
       139
       +
                         ("EZFS_UNKNOWN", Int);

     

       140
       140
       +
                         (* Properties *)

     

       141
       141
       +
                         ("ZFS_PROP_CREATION", Int);

     

       142
       142
       +
                         ("ZFS_PROP_USED", Int);

     

       143
       143
       +
                         ("ZFS_PROP_AVAILABLE", Int);

     

       144
       144
       +
                         ("ZFS_PROP_REFERENCED", Int);

     

       145
       145
       +
                         ("ZFS_PROP_COMPRESSRATIO", Int);

     

       146
       146
       +
                         ("ZFS_PROP_COMPRESSION", Int);

     

       147
       147
       +
                         ("ZFS_PROP_SNAPDIR", Int);

     

       148
       148
       +
                         ("ZFS_PROP_ENCRYPTION", Int);

     

       149
       149
       +
                         (* Types *)

     

       150
       150
       +
                         ("ZFS_TYPE_INVALID", Int);

     

       151
       151
       +
                         ("ZFS_TYPE_FILESYSTEM", Int);

     

       152
       152
       +
                         ("ZFS_TYPE_SNAPSHOT", Int);

     

       153
       153
       +
                         ("ZFS_TYPE_VOLUME", Int);

     

       154
       154
       +
                         ("ZFS_TYPE_POOL", Int);

     

       155
       155
       +
                         ("ZFS_TYPE_BOOKMARK", Int);

     

       156
       156
       +
                         ("ZFS_TYPE_VDEV", Int);

     

       157
       157
       +
                         ("ZFS_TYPE_DATASET", Int);

     

       158
       158
       +
                       ]

     

       159
       159
       +
                   |> List.fold_left

     

       160
       160
       +
                        (fun (errs, props, types) -> function

     

       161
       161
       +
                          | name, C.C_define.Value.Int v -> (

     

       162
       162
       +
                              let type_ name =

     

       163
       163
       +
                                Printf.sprintf "val %s : t"

     

       164
       164
       +
                                  (String.lowercase_ascii name)

     

       165
       165
       +
                              in

     

       166
       166
       +
                              let definition name =

     

       167
       167
       +
                                Printf.sprintf "let %s : t = 0x%x"

     

       168
       168
       +
                                  (String.lowercase_ascii name)

     

       169
       169
       +
                                  v

     

       170
       170
       +
                              in

     

       171
       171
       +
                              match starts_with ~prefix:"EZFS_" name with

     

       172
       172
       +
                              | Some r ->

     

       173
       173
       +
                                  ((type_ r, definition r) :: errs, props, types)

     

       174
       174
       +
                              | None -> (

     

       175
       175
       +
                                  match starts_with ~prefix:"ZFS_PROP_" name with

     

       176
       176
       +
                                  | Some r ->

     

       177
       177
       +
                                      (errs, (type_ r, definition r) :: props, types)

     

       178
       178
       +
                                  | None -> (

     

       179
       179
       +
                                      match starts_with ~prefix:"ZFS_TYPE_" name with

     

       180
       180
       +
                                      | Some t ->

     

       181
       181
       +
                                          ( errs,

     

       182
       182
       +
                                            props,

     

       183
       183
       +
                                            (type_ t, definition t) :: types )

     

       184
       184
       +
                                      | None -> failwith "Unknown ZFS static value")))

     

       185
       185
       +
                          | _ -> assert false)

     

       186
       186
       +
                        ([], [], [])

     

       187
       187
       +
                 in

     

       188
       188
       +
                 let with_module ~name defs =

     

       189
       189
       +
                   [ Printf.sprintf "module %s = struct\n type t =  int\n" name ]

     

       190
       190
       +
                   @ defs @ [ "end" ]

     

       191
       191
       +
                 in

     

       192
       192
       +
                 let with_module_type ~name defs =

     

       193
       193
       +
                   [

     

       194
       194
       +
                     Printf.sprintf "module type %s = sig\n type t = private int\n"

     

       195
       195
       +
                       name;

     

       196
       196
       +
                   ]

     

       197
       197
       +
                   @ defs @ [ "end" ]

     

       198
       198
       +
                 in

     

       199
       199
       +
                 let defs =

     

       200
       200
       +
                   with_module ~name:"Error" (List.map snd errs)

     

       201
       201
       +
                   @ with_module ~name:"Props" (List.map snd props)

     

       202
       202
       +
                   @ with_module ~name:"Types" (List.map snd types)

     

       203
       203
       +
                 in

     

       204
       204
       +
                 let types =

     

       205
       205
       +
                   with_module_type ~name:"ERROR" (List.map fst errs)

     

       206
       206
       +
                   @ with_module_type ~name:"PROPS" (List.map fst props)

     

       207
       207
       +
                   @ with_module_type ~name:"TYPES" (List.map fst types)

     

       208
       208
       +
                 in

     

       209
       209
       +
                 C.Flags.write_lines "config.ml" (defs @ types))

vendor/zfs/src/include/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (name discover)

     

       3
       3
       +
        (modules discover)

     

       4
       4
       +
        (libraries dune-configurator))

+31

vendor/zfs/src/type_description.ml

···

       1
       1
       +
       module Types (F : Ctypes.TYPE) = struct

     

       2
       2
       +
         open F

     

       3
       3
       +
       

     

       4
       4
       +
         type libzfs_handle_t

     

       5
       5
       +
       

     

       6
       6
       +
         let libzfs_handle_t :

     

       7
       7
       +
             libzfs_handle_t Ctypes_static.structure Ctypes_static.ptr typ =

     

       8
       8
       +
           ptr @@ structure "libzfs_handle"

     

       9
       9
       +
       

     

       10
       10
       +
         type zpool_handle_t

     

       11
       11
       +
       

     

       12
       12
       +
         let zpool_handle_t :

     

       13
       13
       +
             zpool_handle_t Ctypes_static.structure Ctypes_static.ptr typ =

     

       14
       14
       +
           ptr @@ structure "zpool_handle"

     

       15
       15
       +
       

     

       16
       16
       +
         type zfs_handle_t

     

       17
       17
       +
       

     

       18
       18
       +
         let zfs_handle_t : zfs_handle_t Ctypes_static.structure Ctypes_static.ptr typ

     

       19
       19
       +
             =

     

       20
       20
       +
           ptr @@ structure "zfs_handle"

     

       21
       21
       +
       

     

       22
       22
       +
         type nvlist_t

     

       23
       23
       +
       

     

       24
       24
       +
         let nvlist_t : nvlist_t Ctypes_static.structure typ = structure "nvlist"

     

       25
       25
       +
         let nvl_version = field nvlist_t "nvl_version" int32_t

     

       26
       26
       +
         let nvl_nvflag = field nvlist_t "nvl_nvflag" uint32_t

     

       27
       27
       +
         let nvl_priv = field nvlist_t "nvl_priv" uint64_t

     

       28
       28
       +
         let nvl_flag = field nvlist_t "nvl_flag" uint32_t

     

       29
       29
       +
         let nvl_pad = field nvlist_t "nvl_pad" int32_t

     

       30
       30
       +
         let () = seal nvlist_t

     

       31
       31
       +
       end

+141

vendor/zfs/src/zfs.ml

···

       1
       1
       +
       module Error = struct

     

       2
       2
       +
         include Config.Error

     

       3
       3
       +
       end

     

       4
       4
       +
       

     

       5
       5
       +
       module Flags = struct

     

       6
       6
       +
         type t = int

     

       7
       7
       +
       

     

       8
       8
       +
         let empty = 0

     

       9
       9
       +
         let of_int x = x

     

       10
       10
       +
         let ( + ) = ( lor )

     

       11
       11
       +
         let mem a b = a land b = a

     

       12
       12
       +
       end

     

       13
       13
       +
       

     

       14
       14
       +
       module Types = struct

     

       15
       15
       +
         include Flags

     

       16
       16
       +
       

     

       17
       17
       +
         let vdev = Config.Types.vdev

     

       18
       18
       +
         let pool = Config.Types.pool

     

       19
       19
       +
         let volume = Config.Types.volume

     

       20
       20
       +
         let invalid = Config.Types.invalid

     

       21
       21
       +
         let bookmark = Config.Types.bookmark

     

       22
       22
       +
         let snapshot = Config.Types.snapshot

     

       23
       23
       +
         let filesystem = Config.Types.filesystem

     

       24
       24
       +
         let dataset = Config.Types.dataset

     

       25
       25
       +
       end

     

       26
       26
       +
       

     

       27
       27
       +
       module Handle = struct

     

       28
       28
       +
         type t = C.Types.libzfs_handle_t Ctypes_static.structure Ctypes_static.ptr

     

       29
       29
       +
       end

     

       30
       30
       +
       

     

       31
       31
       +
       let init : unit -> Handle.t = C.Functions.init

     

       32
       32
       +
       let debug : Handle.t -> bool -> unit = C.Functions.debug

     

       33
       33
       +
       let errno : Handle.t -> int = C.Functions.errno

     

       34
       34
       +
       

     

       35
       35
       +
       module Zpool = struct

     

       36
       36
       +
         type t = C.Types.zpool_handle_t Ctypes_static.structure Ctypes_static.ptr

     

       37
       37
       +
       

     

       38
       38
       +
         let open_ = C.Functions.Zpool.open_

     

       39
       39
       +
         let close = C.Functions.Zpool.close

     

       40
       40
       +
         let get_name = C.Functions.Zpool.get_name

     

       41
       41
       +
       end

     

       42
       42
       +
       

     

       43
       43
       +
       module Nvlist = struct

     

       44
       44
       +
         type t = C.Types.nvlist_t Ctypes_static.structure Ctypes_static.ptr

     

       45
       45
       +
       

     

       46
       46
       +
         type nvlist =

     

       47
       47
       +
           (string

     

       48
       48
       +
           * [ `Bool of bool

     

       49
       49
       +
             | `String of string

     

       50
       50
       +
             | `Byte of Unsigned.uchar

     

       51
       51
       +
             | `Int64 of int64 ])

     

       52
       52
       +
           list

     

       53
       53
       +
       

     

       54
       54
       +
         let check_return i =

     

       55
       55
       +
           if i = 22 then invalid_arg "Nvlist.v: add bool" else assert (i = 0)

     

       56
       56
       +
       

     

       57
       57
       +
         let v (schema : nvlist) : t =

     

       58
       58
       +
           let open Ctypes in

     

       59
       59
       +
           let finalise v = C.Functions.Nvlist.free !@v in

     

       60
       60
       +
           let nv_pp =

     

       61
       61
       +
             allocate ~finalise (ptr C.Types.nvlist_t)

     

       62
       62
       +
               (from_voidp C.Types.nvlist_t null)

     

       63
       63
       +
           in

     

       64
       64
       +
           (* TODO: Unique names or not... *)

     

       65
       65
       +
           C.Functions.Nvlist.alloc nv_pp 0x1 0 |> check_return;

     

       66
       66
       +
           let rec aux = function

     

       67
       67
       +
             | [] -> !@nv_pp

     

       68
       68
       +
             | (k, `Bool b) :: rest ->

     

       69
       69
       +
                 C.Functions.Nvlist.add_bool !@nv_pp k b |> check_return;

     

       70
       70
       +
                 aux rest

     

       71
       71
       +
             | (k, `String s) :: rest ->

     

       72
       72
       +
                 C.Functions.Nvlist.add_string !@nv_pp k s |> check_return;

     

       73
       73
       +
                 aux rest

     

       74
       74
       +
             | (k, `Int64 i64) :: rest ->

     

       75
       75
       +
                 C.Functions.Nvlist.add_int64 !@nv_pp k i64 |> check_return;

     

       76
       76
       +
                 aux rest

     

       77
       77
       +
             | (k, `Byte u) :: rest ->

     

       78
       78
       +
                 C.Functions.Nvlist.add_byte !@nv_pp k u |> check_return;

     

       79
       79
       +
                 aux rest

     

       80
       80
       +
             | _ -> assert false

     

       81
       81
       +
           in

     

       82
       82
       +
           aux schema

     

       83
       83
       +
       

     

       84
       84
       +
         let empty = Ctypes.(coerce (ptr void) (ptr C.Types.nvlist_t) null)

     

       85
       85
       +
       end

     

       86
       86
       +
       

     

       87
       87
       +
       type t = C.Types.zfs_handle_t Ctypes_static.structure Ctypes_static.ptr

     

       88
       88
       +
       

     

       89
       89
       +
       let create_ancestors handle path =

     

       90
       90
       +
         let i = C.Functions.create_ancestors handle path in

     

       91
       91
       +
         if i != 0 then failwith "Failed to create ancestors" else ()

     

       92
       92
       +
       

     

       93
       93
       +
       let create ?(props = []) handle path (type_ : Types.t) =

     

       94
       94
       +
         let i = C.Functions.create handle path type_ (Nvlist.v props) in

     

       95
       95
       +
         if i != 0 then failwith "Failed to create" else ()

     

       96
       96
       +
       

     

       97
       97
       +
       let open_ handle path (type_ : Types.t) = C.Functions.open_ handle path type_

     

       98
       98
       +
       let close : t -> unit = C.Functions.close

     

       99
       99
       +
       let get_type : t -> Types.t = C.Functions.get_type

     

       100
       100
       +
       

     

       101
       101
       +
       let clone ?(options = Nvlist.empty) handle path =

     

       102
       102
       +
         let res = C.Functions.clone handle path options in

     

       103
       103
       +
         if res = 0 then () else invalid_arg "clone"

     

       104
       104
       +
       

     

       105
       105
       +
       let snapshot ?(options = Nvlist.empty) handle path b =

     

       106
       106
       +
         let res = C.Functions.snapshot handle path b options in

     

       107
       107
       +
         if res = 0 then () else invalid_arg "snapshot"

     

       108
       108
       +
       

     

       109
       109
       +
       let exists handle path (type_ : Types.t) = C.Functions.exists handle path type_

     

       110
       110
       +
       

     

       111
       111
       +
       let is_mounted handle path =

     

       112
       112
       +
         let where = Ctypes.allocate Ctypes.string "" in

     

       113
       113
       +
         let v = C.Functions.is_mounted handle path where in

     

       114
       114
       +
         if not v then None else Some (Ctypes.( !@ ) where)

     

       115
       115
       +
       

     

       116
       116
       +
       let null_string = Ctypes.(coerce (ptr void) (ptr char) null)

     

       117
       117
       +
       

     

       118
       118
       +
       let mount ?mount_opts ?(mount_flags = 0) dataset =

     

       119
       119
       +
         let opts =

     

       120
       120
       +
           Option.value

     

       121
       121
       +
             ~default:(Ctypes.string_from_ptr null_string ~length:0)

     

       122
       122
       +
             mount_opts

     

       123
       123
       +
         in

     

       124
       124
       +
         let res = C.Functions.mount dataset opts mount_flags in

     

       125
       125
       +
         if res <> 0 then invalid_arg "mounting dataset"

     

       126
       126
       +
       

     

       127
       127
       +
       let unmount ?mount_opts ?(mount_flags = 0) dataset =

     

       128
       128
       +
         let opts =

     

       129
       129
       +
           Option.value

     

       130
       130
       +
             ~default:(Ctypes.string_from_ptr null_string ~length:0)

     

       131
       131
       +
             mount_opts

     

       132
       132
       +
         in

     

       133
       133
       +
         let res = C.Functions.unmount dataset opts mount_flags in

     

       134
       134
       +
         if res <> 0 then invalid_arg "unmounting dataset"

     

       135
       135
       +
       

     

       136
       136
       +
       let show_diff ?to_ handle ~from_ (fd : Unix.file_descr) =

     

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

     

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

     

       139
       139
       +
         if res = 0 then () else begin

     

       140
       140
       +
           invalid_arg "show_diff"

     

       141
       141
       +
         end

+206

vendor/zfs/src/zfs.mli

···

       1
       1
       +
       module Types : sig

     

       2
       2
       +
         type t = private int

     

       3
       3
       +
       

     

       4
       4
       +
         val empty : int

     

       5
       5
       +
         val of_int : 'a -> 'a

     

       6
       6
       +
         val ( + ) : int -> int -> int

     

       7
       7
       +
         val mem : int -> int -> bool

     

       8
       8
       +
         val vdev : t

     

       9
       9
       +
         val pool : t

     

       10
       10
       +
         val volume : t

     

       11
       11
       +
         val invalid : t

     

       12
       12
       +
         val bookmark : t

     

       13
       13
       +
         val snapshot : t

     

       14
       14
       +
         val filesystem : t

     

       15
       15
       +
         val dataset : t

     

       16
       16
       +
       end

     

       17
       17
       +
       

     

       18
       18
       +
       module Handle : sig

     

       19
       19
       +
         type t

     

       20
       20
       +
         (** An instance handle for the ZFS library *)

     

       21
       21
       +
       end

     

       22
       22
       +
       

     

       23
       23
       +
       val init : unit -> Handle.t

     

       24
       24
       +
       (** Initialise the library *)

     

       25
       25
       +
       

     

       26
       26
       +
       val debug : Handle.t -> bool -> unit

     

       27
       27
       +
       (** Enable/disable printing on error from ZFS *)

     

       28
       28
       +
       

     

       29
       29
       +
       val errno : Handle.t -> int

     

       30
       30
       +
       (** Check for errors on the handle *)

     

       31
       31
       +
       

     

       32
       32
       +
       module Zpool : sig

     

       33
       33
       +
         type t

     

       34
       34
       +
         (** A Zpool handle *)

     

       35
       35
       +
       

     

       36
       36
       +
         val open_ : Handle.t -> string -> t

     

       37
       37
       +
         (** Open a Zpool *)

     

       38
       38
       +
       

     

       39
       39
       +
         val close : t -> unit

     

       40
       40
       +
         (** Close an open Zpool *)

     

       41
       41
       +
       

     

       42
       42
       +
         val get_name : t -> string

     

       43
       43
       +
         (** The name of an open Zpool *)

     

       44
       44
       +
       end

     

       45
       45
       +
       

     

       46
       46
       +
       module Nvlist : sig

     

       47
       47
       +
         type t

     

       48
       48
       +
         (** Generic name-value lists used by ZFS *)

     

       49
       49
       +
       

     

       50
       50
       +
         type nvlist =

     

       51
       51
       +
           (string

     

       52
       52
       +
           * [ `Bool of bool

     

       53
       53
       +
             | `Byte of Unsigned.uchar

     

       54
       54
       +
             | `String of string

     

       55
       55
       +
             | `Int64 of int64 ])

     

       56
       56
       +
           list

     

       57
       57
       +
         (** A partial OCaml representation of an NV list *)

     

       58
       58
       +
       

     

       59
       59
       +
         val v : nvlist -> t

     

       60
       60
       +
         (** Convert the OCaml representation to the C representation *)

     

       61
       61
       +
       end

     

       62
       62
       +
       

     

       63
       63
       +
       type t

     

       64
       64
       +
       (** A ZFS Dataset *)

     

       65
       65
       +
       

     

       66
       66
       +
       val create_ancestors : Handle.t -> string -> unit

     

       67
       67
       +
       (** Often called before {! create} *)

     

       68
       68
       +
       

     

       69
       69
       +
       val create : ?props:Nvlist.nvlist -> Handle.t -> string -> Types.t -> unit

     

       70
       70
       +
       (** Create a new ZFS dataset *)

     

       71
       71
       +
       

     

       72
       72
       +
       val open_ : Handle.t -> string -> Types.t -> t

     

       73
       73
       +
       (** Open an existing ZFS dataset *)

     

       74
       74
       +
       

     

       75
       75
       +
       val close : t -> unit

     

       76
       76
       +
       (** Close a dataset *)

     

       77
       77
       +
       

     

       78
       78
       +
       val exists : Handle.t -> string -> Types.t -> bool

     

       79
       79
       +
       (** Check if a dataset of a specific type exists *)

     

       80
       80
       +
       

     

       81
       81
       +
       val is_mounted : Handle.t -> string -> string option

     

       82
       82
       +
       (** [is_mounted h d = None] if [d] is not mounted, otherwise

     

       83
       83
       +
           [is_mounted h d = Some mountpoint]. *)

     

       84
       84
       +
       

     

       85
       85
       +
       val mount : ?mount_opts:string -> ?mount_flags:int -> t -> unit

     

       86
       86
       +
       (** Mount a dataset *)

     

       87
       87
       +
       

     

       88
       88
       +
       val unmount : ?mount_opts:string -> ?mount_flags:int -> t -> unit

     

       89
       89
       +
       (** Unmount a dataset *)

     

       90
       90
       +
       

     

       91
       91
       +
       val get_type : t -> Types.t

     

       92
       92
       +
       (** Get the type of the dataset *)

     

       93
       93
       +
       

     

       94
       94
       +
       val clone : ?options:Nvlist.t -> t -> string -> unit

     

       95
       95
       +
       (** Clone an open dataset *)

     

       96
       96
       +
       

     

       97
       97
       +
       val snapshot : ?options:Nvlist.t -> Handle.t -> string -> bool -> unit

     

       98
       98
       +
       (** Snapshot a dataset *)

     

       99
       99
       +
       

     

       100
       100
       +
       val show_diff : ?to_:string -> t -> from_:string -> Unix.file_descr -> unit

     

       101
       101
       +
       (** Output diff to the file descriptor *)

     

       102
       102
       +
       

     

       103
       103
       +
       module Error : sig

     

       104
       104
       +
         type t = int

     

       105
       105
       +
       

     

       106
       106
       +
         val unknown : t

     

       107
       107
       +
         val sharefailed : t

     

       108
       108
       +
         val resume_exists : t

     

       109
       109
       +
         val cksum : t

     

       110
       110
       +
         val not_user_namespace : t

     

       111
       111
       +
         val vdev_notsup : t

     

       112
       112
       +
         val rebuilding : t

     

       113
       113
       +
         val export_in_progress : t

     

       114
       114
       +
         val no_resilver_defer : t

     

       115
       115
       +
         val trim_notsup : t

     

       116
       116
       +
         val no_trim : t

     

       117
       117
       +
         val trimming : t

     

       118
       118
       +
         val wrong_parent : t

     

       119
       119
       +
         val no_initialize : t

     

       120
       120
       +
         val initializing : t

     

       121
       121
       +
         val toomany : t

     

       122
       122
       +
         val ioc_notsupported : t

     

       123
       123
       +
         val vdev_too_big : t

     

       124
       124
       +
         val devrm_in_progress : t

     

       125
       125
       +
         val no_checkpoint : t

     

       126
       126
       +
         val discarding_checkpoint : t

     

       127
       127
       +
         val checkpoint_exists : t

     

       128
       128
       +
         val no_pending : t

     

       129
       129
       +
         val cryptofailed : t

     

       130
       130
       +
         val active_pool : t

     

       131
       131
       +
         val scrub_paused_to_cancel : t

     

       132
       132
       +
         val scrub_paused : t

     

       133
       133
       +
         val poolreadonly : t

     

       134
       134
       +
         val diffdata : t

     

       135
       135
       +
         val diff : t

     

       136
       136
       +
         val no_scrub : t

     

       137
       137
       +
         val errorscrub_paused : t

     

       138
       138
       +
         val errorscrubbing : t

     

       139
       139
       +
         val scrubbing : t

     

       140
       140
       +
         val postsplit_online : t

     

       141
       141
       +
         val threadcreatefailed : t

     

       142
       142
       +
         val pipefailed : t

     

       143
       143
       +
         val tagtoolong : t

     

       144
       144
       +
         val reftag_hold : t

     

       145
       145
       +
         val reftag_rele : t

     

       146
       146
       +
         val unplayed_logs : t

     

       147
       147
       +
         val active_spare : t

     

       148
       148
       +
         val notsup : t

     

       149
       149
       +
         val vdevnotsup : t

     

       150
       150
       +
         val isl2cache : t

     

       151
       151
       +
         val badcache : t

     

       152
       152
       +
         val sharesmbfailed : t

     

       153
       153
       +
         val unsharesmbfailed : t

     

       154
       154
       +
         val nodelegation : t

     

       155
       155
       +
         val badpermset : t

     

       156
       156
       +
         val badperm : t

     

       157
       157
       +
         val badwho : t

     

       158
       158
       +
         val labelfailed : t

     

       159
       159
       +
         val nocap : t

     

       160
       160
       +
         val openfailed : t

     

       161
       161
       +
         val nametoolong : t

     

       162
       162
       +
         val pool_invalarg : t

     

       163
       163
       +
         val pool_notsup : t

     

       164
       164
       +
         val poolprops : t

     

       165
       165
       +
         val nohistory : t

     

       166
       166
       +
         val recursive : t

     

       167
       167
       +
         val invalconfig : t

     

       168
       168
       +
         val isspare : t

     

       169
       169
       +
         val intr : t

     

       170
       170
       +
         val io : t

     

       171
       171
       +
         val fault : t

     

       172
       172
       +
         val nospc : t

     

       173
       173
       +
         val perm : t

     

       174
       174
       +
         val sharenfsfailed : t

     

       175
       175
       +
         val unsharenfsfailed : t

     

       176
       176
       +
         val umountfailed : t

     

       177
       177
       +
         val mountfailed : t

     

       178
       178
       +
         val zoned : t

     

       179
       179
       +
         val crosstarget : t

     

       180
       180
       +
         val badpath : t

     

       181
       181
       +
         val devoverflow : t

     

       182
       182
       +
         val poolunavail : t

     

       183
       183
       +
         val badversion : t

     

       184
       184
       +
         val resilvering : t

     

       185
       185
       +
         val noreplicas : t

     

       186
       186
       +
         val baddev : t

     

       187
       187
       +
         val nodevice : t

     

       188
       188
       +
         val badtarget : t

     

       189
       189
       +
         val badbackup : t

     

       190
       190
       +
         val badrestore : t

     

       191
       191
       +
         val invalidname : t

     

       192
       192
       +
         val voltoobig : t

     

       193
       193
       +
         val dsreadonly : t

     

       194
       194
       +
         val badstream : t

     

       195
       195
       +
         val noent : t

     

       196
       196
       +
         val exists : t

     

       197
       197
       +
         val busy : t

     

       198
       198
       +
         val badtype : t

     

       199
       199
       +
         val propspace : t

     

       200
       200
       +
         val propnoninherit : t

     

       201
       201
       +
         val proptype : t

     

       202
       202
       +
         val propreadonly : t

     

       203
       203
       +
         val badprop : t

     

       204
       204
       +
         val nomem : t

     

       205
       205
       +
         val success : t

     

       206
       206
       +
       end

+150

vendor/zfs/src/zfs_stubs.c

···

       1
       1
       +
       /*

     

       2
       2
       +
        * Copyright (C) 2020-2021 Anil Madhavapeddy

     

       3
       3
       +
        * Copyright (C) 2020-2021 Sadiq Jaffer

     

       4
       4
       +
        * Copyright (C) 2022 Christiano Haesbaert

     

       5
       5
       +
        *

     

       6
       6
       +
        * Permission to use, copy, modify, and distribute this software for any

     

       7
       7
       +
        * purpose with or without fee is hereby granted, provided that the above

     

       8
       8
       +
        * copyright notice and this permission notice appear in all copies.

     

       9
       9
       +
        *

     

       10
       10
       +
        * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES

     

       11
       11
       +
        * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF

     

       12
       12
       +
        * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR

     

       13
       13
       +
        * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES

     

       14
       14
       +
        * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN

     

       15
       15
       +
        * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF

     

       16
       16
       +
        * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

     

       17
       17
       +
        */

     

       18
       18
       +
       

     

       19
       19
       +
       #include <unistd.h>

     

       20
       20
       +
       #include <stdio.h>

     

       21
       21
       +
       #include <stdint.h>

     

       22
       22
       +
       #include <stdbool.h> 

     

       23
       23
       +
       

     

       24
       24
       +
       #include <libzfs_core.h>

     

       25
       25
       +
       #include <libzfs.h>

     

       26
       26
       +
       #include <caml/alloc.h>

     

       27
       27
       +
       #include <caml/bigarray.h>

     

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

     

       29
       29
       +
       #include <caml/custom.h>

     

       30
       30
       +
       #include <caml/fail.h>

     

       31
       31
       +
       #include <caml/memory.h>

     

       32
       32
       +
       #include <caml/mlvalues.h>

     

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

     

       34
       34
       +
       #include <caml/unixsupport.h>

     

       35
       35
       +
       #include <caml/socketaddr.h>

     

       36
       36
       +
       

     

       37
       37
       +
       #undef ZFS_DEBUG

     

       38
       38
       +
       #ifdef ZFS_DEBUG

     

       39
       39
       +
       #define dprintf(fmt, ...) fprintf(stderr, fmt, ##__VA_ARGS__)

     

       40
       40
       +
       #else

     

       41
       41
       +
       #define dprintf(fmt, ...) ((void)0)

     

       42
       42
       +
       #endif

     

       43
       43
       +
       

     

       44
       44
       +
       value ocaml_zfs_prop_is_string(value v_prop){

     

       45
       45
       +
         int res;

     

       46
       46
       +
         res = zfs_prop_is_string(Int_val(v_prop));

     

       47
       47
       +
         if (res < 0) {

     

       48
       48
       +
           caml_failwith("Error occurred!");

     

       49
       49
       +
         }

     

       50
       50
       +
         return Val_bool(res);

     

       51
       51
       +
       }

     

       52
       52
       +
       

     

       53
       53
       +
       #define Zfs_list_val(v) (*((struct nv_list **) Data_custom_val(v)))

     

       54
       54
       +
       #define Zfs_handle_val(v) (*((libzfs_handle_t **) Data_custom_val(v)))

     

       55
       55
       +
       #define Zfs_pool_val(v) (*((zpool_handle_t **) Data_custom_val(v)))

     

       56
       56
       +
       

     

       57
       57
       +
       static void finalize_zfs_list(value v) {

     

       58
       58
       +
         caml_stat_free(Zfs_list_val(v));

     

       59
       59
       +
         Zfs_list_val(v) = NULL;

     

       60
       60
       +
       }

     

       61
       61
       +
       

     

       62
       62
       +
       static struct custom_operations zfs_list_ops = {

     

       63
       63
       +
         "zfs.zfs_list_ops",

     

       64
       64
       +
         finalize_zfs_list,

     

       65
       65
       +
         custom_compare_default,

     

       66
       66
       +
         custom_hash_default,

     

       67
       67
       +
         custom_serialize_default,

     

       68
       68
       +
         custom_deserialize_default,

     

       69
       69
       +
         custom_compare_ext_default,

     

       70
       70
       +
         custom_fixed_length_default

     

       71
       71
       +
       };

     

       72
       72
       +
       

     

       73
       73
       +
       static void finalize_zfs_handle(value v) {

     

       74
       74
       +
         caml_stat_free(Zfs_handle_val(v));

     

       75
       75
       +
         Zfs_handle_val(v) = NULL;

     

       76
       76
       +
       }

     

       77
       77
       +
       

     

       78
       78
       +
       static struct custom_operations zfs_handle_ops = {

     

       79
       79
       +
         "zfs.zfs_handle",

     

       80
       80
       +
         finalize_zfs_handle,

     

       81
       81
       +
         custom_compare_default,

     

       82
       82
       +
         custom_hash_default,

     

       83
       83
       +
         custom_serialize_default,

     

       84
       84
       +
         custom_deserialize_default,

     

       85
       85
       +
         custom_compare_ext_default,

     

       86
       86
       +
         custom_fixed_length_default

     

       87
       87
       +
       };

     

       88
       88
       +
       

     

       89
       89
       +
       static void finalize_zfs_pool(value v) {

     

       90
       90
       +
         caml_stat_free(Zfs_pool_val(v));

     

       91
       91
       +
         Zfs_pool_val(v) = NULL;

     

       92
       92
       +
       }

     

       93
       93
       +
       

     

       94
       94
       +
       static struct custom_operations zfs_pool_ops = {

     

       95
       95
       +
         "zfs.zfs_pool",

     

       96
       96
       +
         finalize_zfs_pool,

     

       97
       97
       +
         custom_compare_default,

     

       98
       98
       +
         custom_hash_default,

     

       99
       99
       +
         custom_serialize_default,

     

       100
       100
       +
         custom_deserialize_default,

     

       101
       101
       +
         custom_compare_ext_default,

     

       102
       102
       +
         custom_fixed_length_default

     

       103
       103
       +
       };

     

       104
       104
       +
       

     

       105
       105
       +
       // ZFS Initialisation

     

       106
       106
       +
       

     

       107
       107
       +
       value

     

       108
       108
       +
       ocaml_zfs_init(value v_unit) {

     

       109
       109
       +
       	CAMLparam0();

     

       110
       110
       +
       	libzfs_handle_t* res;

     

       111
       111
       +
       	CAMLlocal1(v_handle);

     

       112
       112
       +
       

     

       113
       113
       +
       	v_handle = caml_alloc_custom_mem(&zfs_handle_ops, sizeof(libzfs_handle_t*), 64);

     

       114
       114
       +
       	res = libzfs_init();

     

       115
       115
       +
       	Zfs_handle_val(v_handle) = res; 

     

       116
       116
       +
       

     

       117
       117
       +
       	CAMLreturn(v_handle);

     

       118
       118
       +
       }

     

       119
       119
       +
       

     

       120
       120
       +
       // ZFS Pools 

     

       121
       121
       +
       

     

       122
       122
       +
       value

     

       123
       123
       +
       ocaml_zfs_pool_open(value v_handle, value v_path) {

     

       124
       124
       +
       	CAMLparam2(v_handle, v_path);

     

       125
       125
       +
       	zpool_handle_t* res;

     

       126
       126
       +
       	CAMLlocal1(v_pool);

     

       127
       127
       +
       

     

       128
       128
       +
       	if (!caml_string_is_c_safe(v_path))

     

       129
       129
       +
             caml_invalid_argument("ocaml_zfs_pool_open: path is not C-safe");

     

       130
       130
       +
       

     

       131
       131
       +
       	v_pool = caml_alloc_custom_mem(&zfs_pool_ops, sizeof(zpool_handle_t*), 64);

     

       132
       132
       +
       	res = zpool_open(Zfs_handle_val(v_handle), String_val(v_path));

     

       133
       133
       +
       	Zfs_pool_val(v_handle) = res;

     

       134
       134
       +
       

     

       135
       135
       +
       	CAMLreturn(v_handle);

     

       136
       136
       +
       }

     

       137
       137
       +
       

     

       138
       138
       +
       value

     

       139
       139
       +
       ocaml_zfs_pool_get_name(value v_pool) {

     

       140
       140
       +
         CAMLparam1(v_pool);

     

       141
       141
       +
         CAMLlocal1(v_path);

     

       142
       142
       +
         const char* result;

     

       143
       143
       +
       

     

       144
       144
       +
         result = zpool_get_name(Zfs_pool_val(v_pool));

     

       145
       145
       +
         v_path = caml_copy_string(result);

     

       146
       146
       +
       

     

       147
       147
       +
         CAMLreturn(v_path);

     

       148
       148
       +
       }

     

       149
       149
       +
       

     

       150
       150
       +

+32

vendor/zfs/zfs.opam

···

       1
       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       +
       opam-version: "2.0"

     

       3
       3
       +
       synopsis: "libzfs bindings"

     

       4
       4
       +
       description: "OCaml bindings to libzfs"

     

       5
       5
       +
       maintainer: ["Patrick Ferris <patrick@sirref.org>"]

     

       6
       6
       +
       authors: ["Patrick Ferris <patrick@sirref.org>"]

     

       7
       7
       +
       license: "ISC"

     

       8
       8
       +
       tags: ["filesystem" "zfs"]

     

       9
       9
       +
       homepage: "https://github.com/patricoferris/ocaml-zfs"

     

       10
       10
       +
       bug-reports: "https://github.com/patricoferris/ocaml-zfs/issues"

     

       11
       11
       +
       depends: [

     

       12
       12
       +
         "ocaml"

     

       13
       13
       +
         "dune" {>= "3.15"}

     

       14
       14
       +
         "ctypes"

     

       15
       15
       +
         "mdx" {with-test}

     

       16
       16
       +
         "odoc" {with-doc}

     

       17
       17
       +
       ]

     

       18
       18
       +
       build: [

     

       19
       19
       +
         ["dune" "subst"] {dev}

     

       20
       20
       +
         [

     

       21
       21
       +
           "dune"

     

       22
       22
       +
           "build"

     

       23
       23
       +
           "-p"

     

       24
       24
       +
           name

     

       25
       25
       +
           "-j"

     

       26
       26
       +
           jobs

     

       27
       27
       +
           "@install"

     

       28
       28
       +
           "@runtest" {with-test}

     

       29
       29
       +
           "@doc" {with-doc}

     

       30
       30
       +
         ]

     

       31
       31
       +
       ]

     

       32
       32
       +
       dev-repo: "git+https://github.com/patricoferris/ocaml-zfs.git"

Compare changes