From: David Thompson <da...@gnu.org> * guix/build/syscalls.scm (pivot-root): New procedure. * tests/syscalls.scm: Test it. --- guix/build/syscalls.scm | 15 +++++++++++++++ tests/syscalls.scm | 24 ++++++++++++++++++++++++ 2 files changed, 39 insertions(+)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 827a79d..e319368 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,6 +46,7 @@ swapoff processes mkdtemp! + pivot-root CLONE_NEWNS CLONE_NEWUTS @@ -326,6 +327,20 @@ reassociated with, or 0 if there is no such limitation." (list fdes nstype (strerror err)) (list err))))))) +(define pivot-root + (let* ((ptr (dynamic-func "pivot_root" (dynamic-link))) + (proc (pointer->procedure int ptr (list '* '*)))) + (lambda (new-root put-old) + "Change the root file system to NEW-ROOT and move the current root file +system to PUT-OLD." + (let ((ret (proc (string->pointer new-root) + (string->pointer put-old))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "pivot_root" "~S ~S: ~A" + (list new-root put-old (strerror err)) + (list err))))))) + ;;; ;;; Packed structures. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 80d2788..e34d37d 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (test-syscalls) + #:use-module (guix utils) #:use-module (guix build syscalls) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -112,6 +113,29 @@ (equal? (readlink (user-namespace clone-pid)) (readlink (user-namespace fork-pid)))))))))) +(test-assert "pivot-root" + (match (pipe) + ((in . out) + (match (clone (logior CLONE_NEWUSER CLONE_NEWNS)) + (0 + (close in) + (call-with-temporary-directory + (lambda (root) + (let ((put-old (string-append root "/real-root"))) + (mount "none" root "tmpfs") + (mkdir put-old) + (call-with-output-file (string-append root "/test") + (lambda (port) + (display "testing\n" port))) + (pivot-root root put-old) + ;; The test file should now be located inside the root directory. + (write (file-exists "/test") out) + (close out)))) + (primitive-exit 0)) + (pid + (close out) + (read in)))))) + (test-assert "all-network-interfaces" (match (all-network-interfaces) (((? string? names) ..1) -- 2.4.3