[PATCH 07/15] build: syscalls: Add pivot-root.

[David Thompson <dthompson2@worcester.edu>]

From: David Thompson <davet@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)))))))
+
 \f
 ;;;
 ;;; 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