build: syscalls: Add pivot-root.

* guix/build/syscalls.scm (pivot-root): New procedure.
* tests/syscalls.scm ("pivot-root"): New test.
This commit is contained in:
David Thompson 2015-06-25 20:17:46 -04:00 committed by David Thompson
parent 43ace6ea76
commit df3ce5c123
2 changed files with 44 additions and 0 deletions

View File

@ -46,6 +46,7 @@
swapoff swapoff
processes processes
mkdtemp! mkdtemp!
pivot-root
CLONE_NEWNS CLONE_NEWNS
CLONE_NEWUTS CLONE_NEWUTS
@ -329,6 +330,20 @@ there is no such limitation."
(list fdes nstype (strerror err)) (list fdes nstype (strerror err))
(list 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. ;;; Packed structures.

View File

@ -18,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-syscalls) (define-module (test-syscalls)
#:use-module (guix utils)
#:use-module (guix build syscalls) #:use-module (guix build syscalls)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -117,6 +118,34 @@
(waitpid fork-pid) (waitpid fork-pid)
result)))))))) 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" (test-assert "all-network-interfaces"
(match (all-network-interfaces) (match (all-network-interfaces)
(((? string? names) ..1) (((? string? names) ..1)