diff options
| -rw-r--r-- | guix/build/syscalls.scm | 15 | ||||
| -rw-r--r-- | tests/syscalls.scm | 29 |
2 files changed, 44 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3f0a0c92f8..dcca5fc339 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,6 +46,7 @@ swapoff processes mkdtemp! + pivot-root CLONE_NEWNS CLONE_NEWUTS @@ -329,6 +330,20 @@ 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 9b8ac9e603..8598f747f1 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) @@ -117,6 +118,34 @@ (waitpid fork-pid) result)))))))) +(test-assert "pivot-root" + (match (pipe) + ((in . out) + (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD)) + (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) + (let ((result (read in))) + (close in) + (and (zero? (match (waitpid pid) + ((_ . status) + (status:exit-val status)))) + (eq? #t result)))))))) + (test-assert "all-network-interfaces" (match (all-network-interfaces) (((? string? names) ..1) |