commit 72ca76f2ab52d1c584bf93b9130be290ffebe615 · anil.recoil.org/shelter

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

+202

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
       +
         rootfs : (string * mode) option;

     

       13
       13
       +
         mounts : mount list;

     

       14
       14
       +
       }

     

       15
       15
       +
       

     

       16
       16
       +
       and mount = { src : string; tgt : string; mode : int [@warning "-69"] }

     

       17
       17
       +
       

     

       18
       18
       +
       (* Actions for namespacing *)

     

       19
       19
       +
       module Mount = struct

     

       20
       20
       +
         module Flags = struct

     

       21
       21
       +
           include Config.Mount_flags

     

       22
       22
       +
       

     

       23
       23
       +
           let empty : t = 0

     

       24
       24
       +
           let ( + ) = ( lor )

     

       25
       25
       +
         end

     

       26
       26
       +
       

     

       27
       27
       +
         module Types = struct

     

       28
       28
       +
           type t = string

     

       29
       29
       +
       

     

       30
       30
       +
           let btrfs = "btrfs"

     

       31
       31
       +
           let ext4 = "ext4"

     

       32
       32
       +
           let auto = "auto"

     

       33
       33
       +
         end

     

       34
       34
       +
       end

     

       35
       35
       +
       

     

       36
       36
       +
       external action_mount : unit -> Fork_action.fork_fn = "void_fork_mount"

     

       37
       37
       +
       

     

       38
       38
       +
       let action_mount = action_mount ()

     

       39
       39
       +
       

     

       40
       40
       +
       let _mount ~(src : string) ~(target : string) (type_ : Mount.Types.t)

     

       41
       41
       +
           (flags : Mount.Flags.t) =

     

       42
       42
       +
         Fork_action.

     

       43
       43
       +
           { run = (fun k -> k (Obj.repr (action_mount, src, target, type_, flags))) }

     

       44
       44
       +
       

     

       45
       45
       +
       external action_pivot_root : unit -> Fork_action.fork_fn

     

       46
       46
       +
         = "void_fork_pivot_root"

     

       47
       47
       +
       

     

       48
       48
       +
       let action_pivot_root = action_pivot_root ()

     

       49
       49
       +
       

     

       50
       50
       +
       let pivot_root (new_root : string) (new_root_flags : Mount.Flags.t)

     

       51
       51
       +
           (tmpfs : bool) (mounts : mount list) =

     

       52
       52
       +
         Fork_action.

     

       53
       53
       +
           {

     

       54
       54
       +
             run =

     

       55
       55
       +
               (fun k ->

     

       56
       56
       +
                 k

     

       57
       57
       +
                   (Obj.repr

     

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

     

       59
       59
       +
           }

     

       60
       60
       +
       

     

       61
       61
       +
       external action_map_uid_gid : unit -> Fork_action.fork_fn

     

       62
       62
       +
         = "void_fork_map_uid_gid"

     

       63
       63
       +
       

     

       64
       64
       +
       let action_map_uid_gid = action_map_uid_gid ()

     

       65
       65
       +
       

     

       66
       66
       +
       let map_uid_gid ~uid ~gid =

     

       67
       67
       +
         Fork_action.{ run = (fun k -> k (Obj.repr (action_map_uid_gid, uid, gid))) }

     

       68
       68
       +
       

     

       69
       69
       +
       module Flags = struct

     

       70
       70
       +
         include Config.Clone_flags

     

       71
       71
       +
       

     

       72
       72
       +
         let ( + ) = ( lor )

     

       73
       73
       +
       end

     

       74
       74
       +
       

     

       75
       75
       +
       external eio_spawn :

     

       76
       76
       +
         Unix.file_descr ->

     

       77
       77
       +
         Flags.t ->

     

       78
       78
       +
         Eio_unix.Private.Fork_action.c_action list ->

     

       79
       79
       +
         int * Unix.file_descr = "caml_void_clone3"

     

       80
       80
       +
       

     

       81
       81
       +
       type t = {

     

       82
       82
       +
         pid : int;

     

       83
       83
       +
         pid_fd : Fd.t;

     

       84
       84
       +
         exit_status : Unix.process_status Promise.t;

     

       85
       85
       +
       }

     

       86
       86
       +
       

     

       87
       87
       +
       let exit_status t = t.exit_status

     

       88
       88
       +
       let pid t = t.pid

     

       89
       89
       +
       

     

       90
       90
       +
       (* Read a (typically short) error message from a child process. *)

     

       91
       91
       +
       let rec read_response fd =

     

       92
       92
       +
         let buf = Cstruct.create 256 in

     

       93
       93
       +
         match Eio_posix.Low_level.readv fd [| buf |] with

     

       94
       94
       +
         | 0 | (exception End_of_file) -> ""

     

       95
       95
       +
         | len -> Cstruct.to_string buf ~len ^ read_response fd

     

       96
       96
       +
       

     

       97
       97
       +
       let void_flags = List.fold_left Flags.( + ) 0 Flags.all

     

       98
       98
       +
       

     

       99
       99
       +
       type path = string

     

       100
       100
       +
       

     

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

     

       102
       102
       +
       

     

       103
       103
       +
       let actions v : Fork_action.t list =

     

       104
       104
       +
         let root, tmpfs, root_mode =

     

       105
       105
       +
           match v.rootfs with

     

       106
       106
       +
           | None -> (Filename.temp_dir "void-" "-tmpdir", true, R)

     

       107
       107
       +
           | Some (s, m) -> (s, false, m)

     

       108
       108
       +
         in

     

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

     

       110
       110
       +
         let e =

     

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

     

       112
       112
       +
             ~argv:(Array.of_list args)

     

       113
       113
       +
         in

     

       114
       114
       +
         (* Process mount point points *)

     

       115
       115
       +
         let mounts =

     

       116
       116
       +
           List.map

     

       117
       117
       +
             (fun mnt ->

     

       118
       118
       +
               let src = Filename.concat "/.old_root" mnt.src in

     

       119
       119
       +
               let tgt = Filename.concat "/" mnt.tgt in

     

       120
       120
       +
               { mnt with tgt; src })

     

       121
       121
       +
             v.mounts

     

       122
       122
       +
         in

     

       123
       123
       +
         let root_flags =

     

       124
       124
       +
           if root_mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty

     

       125
       125
       +
         in

     

       126
       126
       +
         let mounts = pivot_root root root_flags tmpfs mounts in

     

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

     

       128
       128
       +
         let user_namespace = map_uid_gid ~uid ~gid in

     

       129
       129
       +
         [ user_namespace; mounts; e ]

     

       130
       130
       +
       

     

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

     

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

     

       133
       133
       +
       

     

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

     

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

     

       136
       136
       +
         { v with mounts = { src; tgt; mode } :: v.mounts }

     

       137
       137
       +
       

     

       138
       138
       +
       (* From eio_linux/eio_posix *)

     

       139
       139
       +
       let with_pipe fn =

     

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

     

       141
       141
       +
         let r, w = Eio_posix.Low_level.pipe ~sw in

     

       142
       142
       +
         fn r w

     

       143
       143
       +
       

     

       144
       144
       +
       external pidfd_send_signal : Unix.file_descr -> int -> unit

     

       145
       145
       +
         = "caml_void_pidfd_send_signal"

     

       146
       146
       +
       

     

       147
       147
       +
       let signal t signum =

     

       148
       148
       +
         Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd ->

     

       149
       149
       +
         pidfd_send_signal pid_fd signum

     

       150
       150
       +
       

     

       151
       151
       +
       let rec waitpid pid =

     

       152
       152
       +
         match Unix.waitpid [] pid with

     

       153
       153
       +
         | p, status ->

     

       154
       154
       +
             assert (p = pid);

     

       155
       155
       +
             status

     

       156
       156
       +
         | exception Unix.Unix_error (EINTR, _, _) -> waitpid pid

     

       157
       157
       +
       

     

       158
       158
       +
       let spawn ~sw v =

     

       159
       159
       +
         with_pipe @@ fun errors_r errors_w ->

     

       160
       160
       +
         Eio_unix.Private.Fork_action.with_actions (actions v) @@ fun c_actions ->

     

       161
       161
       +
         Switch.check sw;

     

       162
       162
       +
         let exit_status, set_exit_status = Promise.create () in

     

       163
       163
       +
         let t =

     

       164
       164
       +
           let pid, pid_fd =

     

       165
       165
       +
             Fd.use_exn "errors-w" errors_w @@ fun errors_w ->

     

       166
       166
       +
             Eio.Private.Trace.with_span "spawn" @@ fun () ->

     

       167
       167
       +
             let flags = Flags.(clone_pidfd + void_flags) in

     

       168
       168
       +
             eio_spawn errors_w flags c_actions

     

       169
       169
       +
           in

     

       170
       170
       +
           let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in

     

       171
       171
       +
           { pid; pid_fd; exit_status }

     

       172
       172
       +
         in

     

       173
       173
       +
         Fd.close errors_w;

     

       174
       174
       +
         Fiber.fork_daemon ~sw (fun () ->

     

       175
       175
       +
             let cleanup () =

     

       176
       176
       +
               Fd.close t.pid_fd;

     

       177
       177
       +
               Promise.resolve set_exit_status (waitpid t.pid);

     

       178
       178
       +
               `Stop_daemon

     

       179
       179
       +
             in

     

       180
       180
       +
             match Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd with

     

       181
       181
       +
             | () -> Eio.Cancel.protect cleanup

     

       182
       182
       +
             | exception Eio.Cancel.Cancelled _ ->

     

       183
       183
       +
                 Eio.Cancel.protect (fun () ->

     

       184
       184
       +
                     Printf.eprintf "Cancelled?";

     

       185
       185
       +
                     signal t Sys.sigkill;

     

       186
       186
       +
                     Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd;

     

       187
       187
       +
                     cleanup ()));

     

       188
       188
       +
         (* Check for errors starting the process. *)

     

       189
       189
       +
         match read_response errors_r with

     

       190
       190
       +
         | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *)

     

       191
       191
       +
         | err -> failwith err

     

       192
       192
       +
       

     

       193
       193
       +
       let to_eio_status t =

     

       194
       194
       +
         match t with

     

       195
       195
       +
         | Unix.WEXITED i -> `Exited i

     

       196
       196
       +
         | Unix.WSIGNALED i -> `Signaled i

     

       197
       197
       +
         | Unix.WSTOPPED _ -> assert false

     

       198
       198
       +
       

     

       199
       199
       +
       let exit_status_to_string = function

     

       200
       200
       +
         | Unix.WEXITED n -> Printf.sprintf "Exited with %i" n

     

       201
       201
       +
         | Unix.WSTOPPED n -> Printf.sprintf "Stopped with %i" n

     

       202
       202
       +
         | Unix.WSIGNALED n -> Printf.sprintf "Signalled with %i" n

+61

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
       +
       val exec : string list -> void -> void

     

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

     

       52
       52
       +
       

     

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

     

       54
       54
       +
       (** Spawn a void process *)

     

       55
       55
       +
       

     

       56
       56
       +
       val pid : t -> int

     

       57
       57
       +
       (** The pid of a running void process *)

     

       58
       58
       +
       

     

       59
       59
       +
       val exit_status : t -> Unix.process_status Eio.Promise.t

     

       60
       60
       +
       val exit_status_to_string : Unix.process_status -> string

     

       61
       61
       +
       val to_eio_status : Unix.process_status -> Eio.Process.exit_status

+399

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
       +
       #include <caml/mlvalues.h>

     

       24
       24
       +
       #include <caml/unixsupport.h>

     

       25
       25
       +
       #include <caml/memory.h>

     

       26
       26
       +
       #include <caml/custom.h>

     

       27
       27
       +
       #include <caml/fail.h>

     

       28
       28
       +
       

     

       29
       29
       +
       // From Eio

     

       30
       30
       +
       #include <include/fork_action.h>

     

       31
       31
       +
       

     

       32
       32
       +
       #ifndef SYS_pidfd_send_signal

     

       33
       33
       +
       #define SYS_pidfd_send_signal 424

     

       34
       34
       +
       #endif

     

       35
       35
       +
       

     

       36
       36
       +
       // struct clone_args isn't defined in linux-lts headers, so define it here

     

       37
       37
       +
       // Note that this struct is versioned by size. See linux/sched.h for details

     

       38
       38
       +
       struct caml_void_clone_args

     

       39
       39
       +
       {

     

       40
       40
       +
         uint64_t flags;

     

       41
       41
       +
         uint64_t pidfd;

     

       42
       42
       +
         uint64_t child_tid;

     

       43
       43
       +
         uint64_t parent_tid;

     

       44
       44
       +
         uint64_t exit_signal;

     

       45
       45
       +
         uint64_t stack;

     

       46
       46
       +
         uint64_t stack_size;

     

       47
       47
       +
         uint64_t tls;

     

       48
       48
       +
       };

     

       49
       49
       +
       

     

       50
       50
       +
       static int

     

       51
       51
       +
       pidfd_send_signal (int pidfd, int sig, siginfo_t *info, unsigned int flags)

     

       52
       52
       +
       {

     

       53
       53
       +
         return syscall (SYS_pidfd_send_signal, pidfd, sig, info, flags);

     

       54
       54
       +
       }

     

       55
       55
       +
       

     

       56
       56
       +
       CAMLprim value

     

       57
       57
       +
       caml_void_pidfd_send_signal (value v_pidfd, value v_signal)

     

       58
       58
       +
       {

     

       59
       59
       +
         CAMLparam0 ();

     

       60
       60
       +
         int res;

     

       61
       61
       +
       

     

       62
       62
       +
         res =

     

       63
       63
       +
           pidfd_send_signal (Int_val (v_pidfd),

     

       64
       64
       +
       		       caml_convert_signal_number (Int_val (v_signal)), NULL,

     

       65
       65
       +
       		       0);

     

       66
       66
       +
         if (res == -1)

     

       67
       67
       +
           uerror ("pidfd_send_signal", Nothing);

     

       68
       68
       +
         CAMLreturn (Val_unit);

     

       69
       69
       +
       }

     

       70
       70
       +
       

     

       71
       71
       +
       static pid_t

     

       72
       72
       +
       clone3_no_fallback (struct caml_void_clone_args *cl_args)

     

       73
       73
       +
       {

     

       74
       74
       +
         int *pidfd = (int *) (uintptr_t) cl_args->pidfd;

     

       75
       75
       +
         pid_t child_pid =

     

       76
       76
       +
           syscall (SYS_clone3, cl_args, sizeof (struct caml_void_clone_args));

     

       77
       77
       +
       

     

       78
       78
       +
         if (child_pid >= 0)

     

       79
       79
       +
           return child_pid;		/* Success! */

     

       80
       80
       +
       

     

       81
       81
       +
         if (errno != ENOSYS && errno != EPERM)

     

       82
       82
       +
           {

     

       83
       83
       +
             uerror ("clone3", Nothing);	/* Unknown error */

     

       84
       84
       +
           }

     

       85
       85
       +
       

     

       86
       86
       +
         uerror ("clone3", Nothing);

     

       87
       87
       +
       }

     

       88
       88
       +
       

     

       89
       89
       +
       CAMLprim value

     

       90
       90
       +
       caml_void_clone3 (value v_errors, value v_flags, value v_actions)

     

       91
       91
       +
       {

     

       92
       92
       +
         CAMLparam1 (v_actions);

     

       93
       93
       +
         CAMLlocal1 (v_result);

     

       94
       94
       +
         pid_t child_pid;

     

       95
       95
       +
         int pidfd = -1;		/* Is automatically close-on-exec */

     

       96
       96
       +
       

     

       97
       97
       +
         struct caml_void_clone_args cl_args = {

     

       98
       98
       +
           .flags = Int_val (v_flags),

     

       99
       99
       +
           .pidfd = (uintptr_t) & pidfd,

     

       100
       100
       +
           .exit_signal = SIGCHLD,	/* Needed for wait4 to work if we exit before exec */

     

       101
       101
       +
           .stack = (uintptr_t) NULL,	/* Use copy-on-write parent stack */

     

       102
       102
       +
           .stack_size = 0,

     

       103
       103
       +
         };

     

       104
       104
       +
       

     

       105
       105
       +
         child_pid = clone3_no_fallback (&cl_args);

     

       106
       106
       +
         if (child_pid == 0)

     

       107
       107
       +
           {

     

       108
       108
       +
             /* Run child actions (doesn't return) */

     

       109
       109
       +
             eio_unix_run_fork_actions (Int_val (v_errors), v_actions);

     

       110
       110
       +
           }

     

       111
       111
       +
       

     

       112
       112
       +
         v_result = caml_alloc_tuple (2);

     

       113
       113
       +
         Store_field (v_result, 0, Val_long (child_pid));

     

       114
       114
       +
         Store_field (v_result, 1, Val_int (pidfd));

     

       115
       115
       +
       

     

       116
       116
       +
         CAMLreturn (v_result);

     

       117
       117
       +
       }

     

       118
       118
       +
       

     

       119
       119
       +
       

     

       120
       120
       +
       // Actions 

     

       121
       121
       +
       

     

       122
       122
       +
       // MOUNT/UNMOUNT

     

       123
       123
       +
       static void

     

       124
       124
       +
       action_mount (int errors, value v_config)

     

       125
       125
       +
       {

     

       126
       126
       +
         value v_src = Field (v_config, 1);

     

       127
       127
       +
         value v_tgt = Field (v_config, 2);

     

       128
       128
       +
         value v_type = Field (v_config, 3);

     

       129
       129
       +
         value v_flags = Field (v_config, 4);

     

       130
       130
       +
       

     

       131
       131
       +
         int r;

     

       132
       132
       +
       

     

       133
       133
       +
         r =

     

       134
       134
       +
           mount (String_val (v_src), String_val (v_tgt), String_val (v_type),

     

       135
       135
       +
       	   Int_val (v_flags), NULL);

     

       136
       136
       +
       

     

       137
       137
       +
         if (r != 0)

     

       138
       138
       +
           {

     

       139
       139
       +
             eio_unix_fork_error (errors, "mount", strerror (errno));

     

       140
       140
       +
             _exit (1);

     

       141
       141
       +
           }

     

       142
       142
       +
       }

     

       143
       143
       +
       

     

       144
       144
       +
       CAMLprim value

     

       145
       145
       +
       void_fork_mount (value v_unit)

     

       146
       146
       +
       {

     

       147
       147
       +
         return Val_fork_fn (action_mount);

     

       148
       148
       +
       }

     

       149
       149
       +
       

     

       150
       150
       +
       // Writes a single line to a file

     

       151
       151
       +
       static int

     

       152
       152
       +
       put_line (const char *filename, const char *line)

     

       153
       153
       +
       {

     

       154
       154
       +
         int fd;

     

       155
       155
       +
         int written;

     

       156
       156
       +
       

     

       157
       157
       +
         fd = open (filename, O_WRONLY | O_CLOEXEC | O_CREAT | O_TRUNC, 0644);

     

       158
       158
       +
       

     

       159
       159
       +
         if (fd < 0)

     

       160
       160
       +
           {

     

       161
       161
       +
             return fd;

     

       162
       162
       +
           }

     

       163
       163
       +
       

     

       164
       164
       +
         written = write (fd, line, strlen (line));

     

       165
       165
       +
       

     

       166
       166
       +
         close (fd);

     

       167
       167
       +
       

     

       168
       168
       +
         if (written != strlen (line))

     

       169
       169
       +
           {

     

       170
       170
       +
             return -1;

     

       171
       171
       +
           }

     

       172
       172
       +
       

     

       173
       173
       +
         return 0;

     

       174
       174
       +
       }

     

       175
       175
       +
       

     

       176
       176
       +
       // MAP UID/GID to root

     

       177
       177
       +
       static void

     

       178
       178
       +
       action_map_uid_gid (int errors, value v_config)

     

       179
       179
       +
       {

     

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

     

       181
       181
       +
         value v_gid = Field (v_config, 2);

     

       182
       182
       +
         int result;

     

       183
       183
       +
         char uid_line[30];

     

       184
       184
       +
         char gid_line[30];

     

       185
       185
       +
       

     

       186
       186
       +
         // We map root onto the calling UID

     

       187
       187
       +
         snprintf (uid_line, sizeof (uid_line), "0 %i 1\n", Int_val (v_uid));

     

       188
       188
       +
         result = put_line ("/proc/self/uid_map", uid_line);

     

       189
       189
       +
       

     

       190
       190
       +
         if (result < 0)

     

       191
       191
       +
           {

     

       192
       192
       +
             eio_unix_fork_error (errors, "map_uid_gid-uid", strerror (errno));

     

       193
       193
       +
             _exit (1);

     

       194
       194
       +
           }

     

       195
       195
       +
       

     

       196
       196
       +
         /* From user_namespaces(7)

     

       197
       197
       +
          *

     

       198
       198
       +
          * Writing "deny" to the /proc/pid/setgroups file before writing to

     

       199
       199
       +
          * /proc/pid/gid_map will permanently disable setgroups(2) in a user

     

       200
       200
       +
          * namespace and allow writing to /proc/pid/gid_map without having

     

       201
       201
       +
          * the CAP_SETGID capability in the parent user namespace.

     

       202
       202
       +
          *

     

       203
       203
       +
          * See also: https://lwn.net/Articles/626665/ */

     

       204
       204
       +
       

     

       205
       205
       +
         put_line ("/proc/self/setgroups", "deny\n");

     

       206
       206
       +
       

     

       207
       207
       +
         if (result < 0)

     

       208
       208
       +
           {

     

       209
       209
       +
             eio_unix_fork_error (errors, "map_uid_gid-setgroups", strerror (errno));

     

       210
       210
       +
             _exit (1);

     

       211
       211
       +
           }

     

       212
       212
       +
       

     

       213
       213
       +
         result =

     

       214
       214
       +
           snprintf (gid_line, sizeof (gid_line), "0 %i 1\n", Int_val (v_gid));

     

       215
       215
       +
         put_line ("/proc/self/gid_map", gid_line);

     

       216
       216
       +
       

     

       217
       217
       +
         if (result < 0)

     

       218
       218
       +
           {

     

       219
       219
       +
             eio_unix_fork_error (errors, "map_uid_gid-gid", strerror (errno));

     

       220
       220
       +
             _exit (1);

     

       221
       221
       +
           }

     

       222
       222
       +
       }

     

       223
       223
       +
       

     

       224
       224
       +
       

     

       225
       225
       +
       CAMLprim value

     

       226
       226
       +
       void_fork_map_uid_gid (value v_unit)

     

       227
       227
       +
       {

     

       228
       228
       +
         return Val_fork_fn (action_map_uid_gid);

     

       229
       229
       +
       }

     

       230
       230
       +
       

     

       231
       231
       +
       // PIVOT ROOT

     

       232
       232
       +
       //

     

       233
       233
       +
       static int

     

       234
       234
       +
       pivot_root (const char *new_root, const char *put_old)

     

       235
       235
       +
       {

     

       236
       236
       +
         return syscall (SYS_pivot_root, new_root, put_old);

     

       237
       237
       +
       }

     

       238
       238
       +
       

     

       239
       239
       +
       // Is there too much OCaml stuff going on here for a fork_action ?

     

       240
       240
       +
       static void

     

       241
       241
       +
       action_pivot_root (int errors, value v_config)

     

       242
       242
       +
       {

     

       243
       243
       +
         value v_new_root = Field (v_config, 1);

     

       244
       244
       +
         value v_root_flags = Field (v_config, 2);

     

       245
       245
       +
         value v_no_root = Field (v_config, 3);

     

       246
       246
       +
         value v_mounts = Field (v_config, 4);

     

       247
       247
       +
         char path[PATH_MAX];

     

       248
       248
       +
         char old_root_path[PATH_MAX];

     

       249
       249
       +
         char *new_root = String_val (v_new_root);

     

       250
       250
       +
         const char *put_old = ".old_root";

     

       251
       251
       +
       

     

       252
       252
       +
         // From pivot_root example: We want to change the propagation type

     

       253
       253
       +
         // of root to be private so we can pivot it.

     

       254
       254
       +
         if (mount (NULL, "/", NULL, MS_REC | MS_PRIVATE, NULL) == -1)

     

       255
       255
       +
           {

     

       256
       256
       +
             eio_unix_fork_error (errors, "pivot_root-private", strerror (errno));

     

       257
       257
       +
             _exit (1);

     

       258
       258
       +
           }

     

       259
       259
       +
       

     

       260
       260
       +
         // If no pivot_root was given, then we tmpfs the tmpdir we assume was passed.

     

       261
       261
       +
         if (Bool_val (v_no_root))

     

       262
       262
       +
           {

     

       263
       263
       +
             // Make a temporary directory... can't because it allocates ?

     

       264
       264
       +
             //if (mkdtemp(new_root) != NULL) {

     

       265
       265
       +
             //  eio_unix_fork_error(errors, new_root, strerror(errno));

     

       266
       266
       +
             //  _exit(1);

     

       267
       267
       +
             //}

     

       268
       268
       +
       

     

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

     

       270
       270
       +
       	{

     

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

     

       272
       272
       +
       	  _exit (1);

     

       273
       273
       +
       	}

     

       274
       274
       +
           }

     

       275
       275
       +
         else

     

       276
       276
       +
           {

     

       277
       277
       +
             // From pivot_root example: we check that new_root is indeed a mountpoint 

     

       278
       278
       +
             if (mount (new_root, new_root, NULL, MS_BIND, NULL) <= -1)

     

       279
       279
       +
       	{

     

       280
       280
       +
       	  eio_unix_fork_error (errors, "pivot_root-new_root",

     

       281
       281
       +
       			       strerror (errno));

     

       282
       282
       +
       	  _exit (1);

     

       283
       283
       +
       	}

     

       284
       284
       +
           }

     

       285
       285
       +
       

     

       286
       286
       +
         // Make the place to pivot the old root too, under the new root

     

       287
       287
       +
         snprintf (old_root_path, sizeof (path), "%s/%s", new_root, put_old);

     

       288
       288
       +
       

     

       289
       289
       +
         if (mkdir (old_root_path, 0777) == -1)

     

       290
       290
       +
           {

     

       291
       291
       +
             eio_unix_fork_error (errors, "pivot_root-mkdir-put_old",

     

       292
       292
       +
       			   strerror (errno));

     

       293
       293
       +
             _exit (1);

     

       294
       294
       +
           }

     

       295
       295
       +
       

     

       296
       296
       +
         // Pivot the root

     

       297
       297
       +
         if (pivot_root (new_root, old_root_path))

     

       298
       298
       +
           {

     

       299
       299
       +
             eio_unix_fork_error (errors, "pivot_root", strerror (errno));

     

       300
       300
       +
             _exit (1);

     

       301
       301
       +
           }

     

       302
       302
       +
       

     

       303
       303
       +
         // Add mounts

     

       304
       304
       +
         value current_mount = v_mounts;

     

       305
       305
       +
         int mount_result;

     

       306
       306
       +
         int mode;

     

       307
       307
       +
         while (current_mount != Val_emptylist)

     

       308
       308
       +
           {

     

       309
       309
       +
             // TODO: Mode for mounting

     

       310
       310
       +
             mode = Int_val (Field (Field (current_mount, 0), 2));

     

       311
       311
       +
       

     

       312
       312
       +
             // A mount is a record {src; tgt; mode}, we first create the mount point

     

       313
       313
       +
             // directory target

     

       314
       314
       +
             if (mkdir (String_val (Field (Field (current_mount, 0), 1)), 0777) ==

     

       315
       315
       +
       	  -1)

     

       316
       316
       +
       	{

     

       317
       317
       +
       	  eio_unix_fork_error (errors, "pivot_root-mkdir-mount",

     

       318
       318
       +
       			       strerror (errno));

     

       319
       319
       +
       	  _exit (1);

     

       320
       320
       +
       	}

     

       321
       321
       +
       

     

       322
       322
       +
             mount_result = mount (String_val (Field (Field (current_mount, 0), 0)),

     

       323
       323
       +
       			    String_val (Field (Field (current_mount, 0), 1)),

     

       324
       324
       +
       			    NULL, MS_REC | MS_BIND, NULL);

     

       325
       325
       +
       

     

       326
       326
       +
             // Fail early if a mount fails...

     

       327
       327
       +
             if (mount_result < 0)

     

       328
       328
       +
       	{

     

       329
       329
       +
       	  char error[PATH_MAX];

     

       330
       330
       +
       	  snprintf (error, sizeof (error), "mount failed: (%s->%s)",

     

       331
       331
       +
       		    String_val (Field (Field (current_mount, 0), 0)),

     

       332
       332
       +
       		    String_val (Field (Field (current_mount, 0), 1)));

     

       333
       333
       +
       	  eio_unix_fork_error (errors, error, strerror (errno));

     

       334
       334
       +
       	  _exit (1);

     

       335
       335
       +
       	}

     

       336
       336
       +
       

     

       337
       337
       +
             // After mounting for the first time, we can come back and add any

     

       338
       338
       +
             // extra modes that may have been specified, for example RDONLY.

     

       339
       339
       +
             if (mode != 0)

     

       340
       340
       +
       	{

     

       341
       341
       +
       	  mount_result =

     

       342
       342
       +
       	    mount (String_val (Field (Field (current_mount, 0), 0)),

     

       343
       343
       +
       		   String_val (Field (Field (current_mount, 0), 1)), NULL,

     

       344
       344
       +
       		   MS_REMOUNT | MS_BIND | mode, NULL);

     

       345
       345
       +
       

     

       346
       346
       +
       	  if (mount_result < 0)

     

       347
       347
       +
       	    {

     

       348
       348
       +
       	      eio_unix_fork_error (errors, "remount for mode",

     

       349
       349
       +
       				   strerror (errno));

     

       350
       350
       +
       	      _exit (1);

     

       351
       351
       +
       	    }

     

       352
       352
       +
       	}

     

       353
       353
       +
       

     

       354
       354
       +
             // Next mount in the list

     

       355
       355
       +
             current_mount = Field (current_mount, 1);

     

       356
       356
       +
           }

     

       357
       357
       +
       

     

       358
       358
       +
       

     

       359
       359
       +
         // Change to the 'new' root

     

       360
       360
       +
         if (chdir ("/") == -1)

     

       361
       361
       +
           {

     

       362
       362
       +
             eio_unix_fork_error (errors, "pivot_root-chdir", strerror (errno));

     

       363
       363
       +
             _exit (1);

     

       364
       364
       +
           }

     

       365
       365
       +
       

     

       366
       366
       +
         // Unmount the old root and remove it

     

       367
       367
       +
         if (umount2 (put_old, MNT_DETACH) == -1)

     

       368
       368
       +
           {

     

       369
       369
       +
             eio_unix_fork_error (errors, put_old, strerror (errno));

     

       370
       370
       +
             _exit (1);

     

       371
       371
       +
           }

     

       372
       372
       +
       

     

       373
       373
       +
         // Remove the old root

     

       374
       374
       +
         if (rmdir (put_old) == -1)

     

       375
       375
       +
           {

     

       376
       376
       +
             eio_unix_fork_error (errors, put_old, strerror (errno));

     

       377
       377
       +
             _exit (1);

     

       378
       378
       +
           }

     

       379
       379
       +
       

     

       380
       380
       +
       

     

       381
       381
       +
         // Apply any flags to the new root, e.g. RDONLY

     

       382
       382
       +
         if (Int_val (v_root_flags))

     

       383
       383
       +
           {

     

       384
       384
       +
             if (mount

     

       385
       385
       +
       	  ("/", "/", NULL, (MS_REMOUNT | MS_BIND | Int_val (v_root_flags)),

     

       386
       386
       +
       	   NULL) <= -1)

     

       387
       387
       +
       	{

     

       388
       388
       +
       	  eio_unix_fork_error (errors, "pivot_root-rootflags",

     

       389
       389
       +
       			       strerror (errno));

     

       390
       390
       +
       	  _exit (1);

     

       391
       391
       +
       	}

     

       392
       392
       +
           }

     

       393
       393
       +
       }

     

       394
       394
       +
       

     

       395
       395
       +
       CAMLprim value

     

       396
       396
       +
       void_fork_pivot_root (value v_unit)

     

       397
       397
       +
       {

     

       398
       398
       +
         return Val_fork_fn (action_pivot_root);

     

       399
       399
       +
       }

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

+142

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
       +
           Format.printf "Diff got %i\n%!" res;

     

       141
       141
       +
           invalid_arg "show_diff"

     

       142
       142
       +
         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"