guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

13/19: build-derivations: use call-with-container


From: guix-commits
Subject: 13/19: build-derivations: use call-with-container
Date: Tue, 29 Jan 2019 14:19:51 -0500 (EST)

reepca pushed a commit to branch guile-daemon
in repository guix.

commit 2d2ef4487661884e509316312a5d65e120843ae1
Author: Caleb Ristvedt <address@hidden>
Date:   Mon Aug 28 23:46:34 2017 -0500

    build-derivations: use call-with-container
    
    * guix/store/build-derivations.scm:
      (<build-environment>): new fields filesystems, user, group,
      build-dir-inside.
      (default-/dev, add-special-filesystems, start-builder-child): replaced to
      better accommodate call-with-container.
      (mkdir-p*, path-already-assigned?, close-most-files, inputs->mounts): new
      procedures.
---
 guix/store/build-derivations.scm | 439 +++++++++++++++++----------------------
 1 file changed, 187 insertions(+), 252 deletions(-)

diff --git a/guix/store/build-derivations.scm b/guix/store/build-derivations.scm
index 4684433..a9c0a08 100644
--- a/guix/store/build-derivations.scm
+++ b/guix/store/build-derivations.scm
@@ -35,6 +35,8 @@
   #:use-module ((guix build utils) #:select (delete-file-recursively
                                              mkdir-p
                                              copy-recursively))
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu build linux-container)
   #:use-module (ice-9 textual-ports)
   #:use-module (ice-9 match)
   #:use-module (rnrs io ports)
@@ -47,13 +49,17 @@
 
 
 (define-record-type <build-environment>
-  (make-build-environment drv chroot-dir build-dir env-vars input-paths)
+  (make-build-environment drv build-dir-inside build-dir env-vars input-paths
+                          filesystems user group)
   build-environment?
   (drv        build-environment-derivation) ; <derivation> this is for.
-  (chroot-dir build-chroot-dir)             ; path of chroot directory.
+  (build-dir-inside build-directory-inside) ; path of chroot directory.
   (build-dir  build-directory)              ; build dir (outside chroot).
   (env-vars   build-environment-variables)  ; alist of environment variables.
-  (input-paths build-input-paths))          ; list of paths or pairs of paths.
+  (input-paths build-input-paths)           ; list of paths or pairs of paths.
+  (filesystems build-filesystems)           ; list of <file-system> objects.
+  (user        build-environment-user)      ; the user id to build with.
+  (group       build-environment-group))    ; the group id to build with.      
 
 ;;; The derivation building process:
 ;;; 1. Build inputs if necessary.
@@ -124,27 +130,8 @@
             (try-again (+ attempt-number 1))
             (throw args))))))
 
-(define* (parse-delimited str #:optional (delimiter #\space))
-  "Returns a list of strings gathered by parsing STR and separating each group
-of characters separated by DELIMITER."
-  (let next ((strings '())
-             (index (string-skip str delimiter 0)))
-    (if index
-        (let ((next-index (string-index str delimiter index)))
-          (if next-index
-              (next (cons (substring str index next-index)
-                          strings)
-                    (string-skip str delimiter next-index))
-              ;; last thing
-              (reverse! (cons (substring str index)
-                              strings))))
-        ;; it's probably expected that this will be parsed
-        ;; left-to-right... which it is, but that means the start of the list
-        ;; has the rightmost thing. So it should be reversed.
-        (reverse! strings))))
-
-
-(define (build-environment-vars drv)
+
+(define (build-environment-vars drv in-chroot-build-dir)
   "Returns an alist of environment variable / value pairs for every
 environment variable that should be set during the build execution."
   (let ((leaked-vars (and
@@ -153,8 +140,7 @@ environment variable that should be set during the build 
execution."
                              (assoc-ref (derivation-builder-environment-vars 
drv)
                                         "impureEnvVars")))
                         (and leak-string
-                             (parse-delimited leak-string)))))
-        (in-chroot-build-dir (build-directory-name drv 0 "/tmp")))
+                             (parse-delimited leak-string))))))
     (append `(("PATH"             .  "/path-not-set")
               ("HOME"             .  "/homeless-shelter")
               ("NIX_STORE"        .  ,%store-directory)
@@ -169,8 +155,7 @@ environment variable that should be set during the build 
execution."
               ("TEMPDIR"          .  ,in-chroot-build-dir)
               ("TMP"              .  ,in-chroot-build-dir)
               ("TEMP"             .  ,in-chroot-build-dir)
-              ("PWD"              .  ,in-chroot-build-dir)
-              ("GUILE_AUTO_COMPILE" . "0"))
+              ("PWD"              .  ,in-chroot-build-dir))
             (if (fixed-output-derivation? drv)
                 '(("NIX_OUTPUT_CHECKED" . "1"))
                 '())
@@ -179,31 +164,20 @@ environment variable that should be set during the build 
execution."
                        (cons leaked-var (getenv leaked-var)))
                      leaked-vars)
                 '())
-            (map (match-lambda
-                   ((outid . output)
-                    (cons outid (derivation-output-path output))))
-                 (derivation-outputs drv))
             (derivation-builder-environment-vars drv))))
 
-(define (default-/dev chroot-dir)
-  "Sets up the default /dev environment in CHROOT-DIR and returns the
-files/directories from the host /dev that should be in the chroot."
-  (define (in-chroot file-name)
-    (string-append chroot-dir file-name))
-  (mkdir (in-chroot "/dev"))
-  (symlink "/proc/self/fd" (in-chroot "/dev/fd"))
-  (symlink "/proc/self/fd/0" (in-chroot "/dev/stdin"))
-  (symlink "/proc/self/fd/1" (in-chroot "/dev/stdout"))
-  (symlink "/proc/self/fd/2" (in-chroot "/dev/stderr"))
-  (append '("/dev/full"
-            "/dev/null"
-            "/dev/random"
-            "/dev/tty"
-            "/dev/urandom"
-            "/dev/zero")
-          (if (file-exists? "/dev/kvm")
-              '("/dev/kvm")
-              '())))
+(define (default-files drv)
+  "Returns a list of the files to be bind-mounted that aren't store items or
+already added by call-with-container."
+  `(,@(if (file-exists? "/dev/kvm")
+          '("/dev/kvm")
+          '())
+    ,@(if (fixed-output-derivation? drv)
+          '("/etc/resolv.conf"
+            "/etc/nsswitch.conf"
+            "/etc/services"
+            "/etc/hosts")
+          '())))
 
 ;; yes, there is most likely already something that does this.
 (define (format-file file-name . args)
@@ -211,82 +185,73 @@ files/directories from the host /dev that should be in 
the chroot."
     (lambda (port)
       (apply simple-format port args))))
 
-(define* (mkdir-new dir-name #:optional mode)
-  (when (file-exists? dir-name)
-    (delete-file-recursively dir-name))
-  (if mode
-      (mkdir dir-name mode)
-      (mkdir dir-name)))
+(define* (mkdir-p* dir #:optional permissions)
+  (mkdir-p dir)
+  (when permissions
+    (chmod dir permissions)))
 
-(define (add-core-files chroot-dir drv)
+(define (add-core-files environment)
   "Creates core files that will not vary when the derivation is constant. That
 is, whether these files are present or not is influenced solely by the
 derivation itself."
-  (define (in-chroot file-name)
-    (string-append chroot-dir file-name))
-  
-  (mkdir-new chroot-dir #o0750)
-  (mkdir-p (in-chroot %store-directory))
-  (chmod (in-chroot %store-directory) #o1775)
-  (mkdir (in-chroot "/tmp") #o1777)
-  (mkdir (in-chroot "/etc"))
-
-  ;; The output can be a file or a directory (!) so let the builder pick
-  ;; whatever it wants and then just copy the thing to the real store after.
-  ;; (for-each (lambda (output-pair)
-  ;;             (mkdir-new (derivation-output-path (cdr output-pair))))
-  ;;           (derivation-outputs drv))
-  (format-file (in-chroot "/etc/passwd")
-               (string-append "nixblkd:x:~a:~a:Nix build user:/:/noshell~%"
-                              "nobody:x:65535:65534:Nobody:/:/noshell~%")
-               (getuid)
-               (getgid))
-  (format-file (in-chroot "/etc/group")
+  (mkdir-p* %store-directory #o1775)
+  (mkdir-p* "/tmp" #o1777)
+  (mkdir-p* "/etc")
+
+  (format-file "/etc/passwd"
+               (string-append "nixbld:x:~a:~a:Nix build user:/:/noshell~%"
+                              "nobody:x:65534:65534:Nobody:/:/noshell~%")
+               (build-environment-user environment)
+               (build-environment-group environment))
+  (format-file "/etc/group"
                "nixbld:!:~a:~%"
-               (getgid))
-  (unless (fixed-output-derivation? drv)
-    (format-file (in-chroot "/etc/hosts")
-                 "127.0.0.1 localhost~%")))
+               (build-environment-group environment))
+  (unless (fixed-output-derivation?
+           (build-environment-derivation environment))
+    (format-file "/etc/hosts" "127.0.0.1 localhost~%")))
+
+(define (path-already-assigned? path paths)
+  "Determines whether something is already going to be bind-mounted to PATH
+based on what is in PATHS, which should be a list of paths or path pairs."
+  (find (match-lambda
+          ((source . target)
+           (string= target path))
+          (target
+           (string= target path)))
+        paths))
 
 (define* (prepare-build-environment drv #:key
                                     build-chroot-dirs 
-                                    (extra-chroot-dirs '()))
+                                    (extra-chroot-dirs '())
+                                    (build-user (getuid))
+                                    (build-group (getgid)))
   "Creates a <build-environment> for the derivation DRV. BUILD-CHROOT-DIRS
 will override the default chroot directories, EXTRA-CHROOT-DIRS will
-not. Those two arguments should be lists of either file names or pairs of file
-names of the form (outside . inside). Returns the <build-environment> and a
-list of all the files to be added from the store (useful for scanning for
-references to them)."
+not. Those two arguments should be #f or lists of either file names or pairs
+of file names of the form (outside . inside). Returns the <build-environment>
+and a list of all the files to be added from the store (useful for scanning
+for references to them)."
   (let* ((build-dir (make-build-directory drv))
-         (build-chroot (string-append (derivation-file-name drv) ".chroot"))
-         (env-vars (build-environment-vars drv))
-         (additional-files (append (or build-chroot-dirs
-                                       %default-chroot-dirs)
-                                   extra-chroot-dirs
-                                   (if (fixed-output-derivation? drv)
-                                       '("/etc/resolv.conf"
-                                         "/etc/nsswitch.conf"
-                                         "/etc/services"
-                                         "/etc/hosts")
-                                       '())))
-         (inputs-from-store (all-transitive-inputs drv)))
-    (define (in-chroot file)
-      (string-append build-chroot file))
+         (build-dir-inside (build-directory-name drv 0 "/tmp"))
+         (env-vars (build-environment-vars drv build-dir-inside))
+         (inputs-from-store (all-transitive-inputs drv))
+         (all-inputs `(,@(or build-chroot-dirs
+                             %default-chroot-dirs)
+                       ,@extra-chroot-dirs
+                       ,@(default-files drv)
+                       ,(cons build-dir
+                              build-dir-inside)
+                       ,@inputs-from-store
+                       ,@(derivation-sources drv))))
     ;; 4. Honor "environment variables" passed through the derivation.
     ;;    these include "impureEnvVars", "exportReferencesGraph",
     ;;    "build-chroot-dirs", "build-extra-chroot-dirs", "preferLocalBuild"
-    
-    (add-core-files build-chroot drv)
     (values
-     (make-build-environment drv build-chroot build-dir env-vars
-                             `(,@(if (member "/dev" additional-files)
-                                     '()
-                                     (default-/dev build-chroot))
-                               ,(cons build-dir
-                                      (build-directory-name drv 0 "/tmp"))
-                               ,@inputs-from-store
-                               ,@(derivation-sources drv)
-                               ,@additional-files))
+     (make-build-environment drv build-dir-inside build-dir env-vars
+                             all-inputs
+                             (special-filesystems all-inputs)
+                             build-user
+                             build-group)
      inputs-from-store)))
 
 (define (all-transitive-inputs drv)
@@ -326,59 +291,31 @@ code points."
       (()
        (list->string (reverse! result-list))))))
 
-(define (current-mounts)
-  "Returns a list of mounts obtained by reading /proc/self/mountinfo"
-  (call-with-input-file "/proc/self/mountinfo"
-    (lambda (mountinfo)
-      (let next-mount ((mounts '()))
-        (if (port-eof? mountinfo)
-            mounts
-            (next-mount (cons (octal-escaped
-                               (list-ref (parse-delimited
-                                          (read-line mountinfo))
-                                         4))
-                              mounts)))))))
-
-(define (make-current-mounts-private)
-  "Makes all mounts in the current process's namespace be of MS_PRIVATE
-propagation type."
-  (for-each (lambda (some-mount)
-              (mount "none" some-mount "none" MS_PRIVATE))
-            (current-mounts)))
-
-
-(define (touch file)
-  (call-with-output-file file noop))
-
-(define (bind-mount from to)
-  (unless (file-exists? to)
-    (if (file-is-directory? from)
-        (mkdir-p to)
-        (touch to)))
-  (mount from to "none" MS_BIND))
-
-(define (add-special-filesystems environment)
-  (define (in-chroot file)
-    (string-append (build-chroot-dir environment) file))
-  
-  (when (file-exists? "/dev/shm")
-    (mkdir-p (in-chroot "/dev/shm"))
-    (mount "none" (in-chroot "/dev/shm") "tmpfs"))
-  
-  (mkdir-p (in-chroot "/proc"))
-  (mount "none" (in-chroot "/proc") "proc")
-
-  ;; Indicates CONFIG_DEVPTS_MULTIPLE_INSTANCES=y in the kernel.
-  (when (and (file-exists? "/dev/pts/ptmx")
-             (not (file-exists?
-                   (in-chroot "/dev/ptmx")))
-             (not (member "/dev/pts"
-                          (build-input-paths environment))))
-    (mkdir-p (in-chroot "/dev/pts"))
-    (mount "none" (in-chroot "/dev/pts") "devpts"
-           0 "newinstance,mode=0620")
-    (symlink "/dev/pts/ptmx" (in-chroot "/dev/ptmx"))
-    (chmod (in-chroot "/dev/pts/ptmx") #o0666)))
+(define (special-filesystems input-paths)
+  "Returns whatever new filesystems need to be created in the container, which
+depends on whether they're already set to be bind-mounted. INPUT-PATHS must be
+a list of paths or pairs of paths."
+  ;; procfs is already taken care of by call-with-container
+  `(,@(if (file-exists? "/dev/shm")
+          (list (file-system
+                  (device "none")
+                  (mount-point "/dev/shm")
+                  (type "tmpfs")
+                  (check? #f)))
+          '())
+    
+    ;; Indicates CONFIG_DEVPTS_MULTIPLE_INSTANCES=y in the kernel.
+    ,@(if  (and (file-exists? "/dev/pts/ptmx")
+                (not (file-exists? "/dev/ptmx"))
+                (not (path-already-assigned? "/dev/pts"
+                                             input-paths)))
+           (list (file-system
+                   (device "none")
+                   (mount-point "/dev/pts")
+                   (type "devpts")
+                   (options "newinstance,mode=0620")
+                   (check? #f)))
+           '())))
 
 (define (initialize-loopback)
   ;; XXX: Implement this. I couldn't find anything in the manual about ioctl,
@@ -393,82 +330,86 @@ environment variables and bind-mounting the listed files. 
Importantly, this
 assumes that it is in a separate namespace at this point."
   ;; warning: the order in which a lot of this happens is significant and
   ;; partially based on guesswork / copying what the c++ does.
-  (define (in-chroot file-name)
-    (string-append (build-chroot-dir build-environment)
-                   file-name))
+
+  (add-core-files build-environment)
   ;; local communication within the build environment should still be
   ;; possible.
   (initialize-loopback)
-  (make-current-mounts-private)
-  ;; "new_root and put_old must not be on the same filesystem as the current
-  ;; root" - man pivot_root(2). This has to happen before special filesystems
-  ;; are added.
-  (bind-mount (build-chroot-dir build-environment)
-              (build-chroot-dir build-environment))
-  (environ (map (lambda (env-pair)
-                  (string-append (car env-pair) "=" (cdr env-pair)))
-                (build-environment-variables build-environment)))
-  (for-each (match-lambda
-              ((outside . inside)
-               (bind-mount outside
-                           (in-chroot inside)))
-              (file
-               (bind-mount file
-                           (in-chroot file))))
-            (build-input-paths build-environment))
-  (add-special-filesystems build-environment))
-
-(define (super-chroot new-root)
-  "Whereas a normal chroot makes everything outside a directory invisible,
-this makes it not exist at all! Namespace-local, be careful. If more than one
-process is in this namespace, weird stuff might happen."
-  (let ((real-root (string-append new-root "/real-root")))
-    (mkdir real-root)
-    (pivot-root new-root real-root)
-    (chdir "/")
-    (umount "real-root" MNT_DETACH)
-    (rmdir "real-root")))
-
-(define (start-builder-child environment)
-  "Clones the process and sets the child to work building the build described
-by the <build-environment> ENVIRONMENT in a new namespace of many sorts."
-  (let* ((drv (build-environment-derivation environment))
-         (ret (clone (logior CLONE_NEWPID
-                             CLONE_NEWNS
-                             CLONE_NEWIPC
-                             CLONE_NEWUTS
-                             (if (fixed-output-derivation? drv)
-                                 0
-                                        ;CLONE_NEWNET
-                                 0
-                                 )
-                             SIGCHLD))))
-    (if (= ret 0)
-        (catch
-          #t
-          (lambda ()
-            (enact-build-environment environment)
-            (super-chroot (build-chroot-dir environment))
-            ;; DROP PRIVILEGES HERE
-            (chdir (build-directory-name drv 0 "/tmp"))
-            (format #t "command line: ~a~%"
-                    (cons (derivation-builder drv)
-                          (derivation-builder-arguments drv)))
-            (if (zero? (status:exit-val
-                        (apply execl
-                               (derivation-builder drv)
-                               (basename (derivation-builder drv))
-                               (derivation-builder-arguments drv))))
-                (quit 0)
-                (throw 'build-failed-but-lets-debug)))
-          (lambda (type . args)
-            (format #t "Something went wrong in the child...~%")
-            (display type)
-            (display args)
-            (format #t "Here was the top-level directory:~a~%" (scandir "/"))
-            (apply throw type args)
-            (quit)))
-        (status:exit-val (cdr (waitpid ret))))))
+  ;; This couldn't really be described by a <file-system> object, so we have
+  ;; to do this extra bit ourselves. 
+  (when (find (lambda (fs)
+                (string=? (file-system-type fs) "devpts"))
+              (build-filesystems build-environment))
+    (symlink "/dev/pts/ptmx" "/dev/ptmx")
+    (chmod "/dev/pts/ptmx" #o0666))
+  (environ (map (match-lambda
+                  ((key . val)
+                   (string-append key "=" val)))
+                (build-environment-variables build-environment))))
+
+;; The C++ stuff does this, and in pursuit of a bug I will mindlessly mimic
+;; anything.
+(define (close-most-files)
+  (port-for-each (lambda (port)
+                   (when (port-filename port)
+                     (let ((port-fd (port->fdes port)))
+                       (unless (or
+                                (= port-fd (port->fdes (current-input-port)))
+                                (= port-fd (port->fdes (current-output-port)))
+                                (= port-fd (port->fdes (current-error-port))))
+                         (close port-fd)))))))
+
+(define (inputs->mounts inputs)
+  (map (match-lambda
+         ((source . dest)
+          (file-system
+            (device source)
+            (mount-point dest)
+            (type "none")
+            (flags '(bind-mount))
+            (check? #f)))
+         (source
+          (file-system
+            (device source)
+            (mount-point source)
+            (type "none")
+            (flags '(bind-mount))
+            (check? #f))))
+       inputs))
+
+(define (run-builder environment)
+  "Runs the builder in the environment ENVIRONMENT."
+  (let ((drv (build-environment-derivation environment)))
+    (call-with-container
+        (append (inputs->mounts (build-input-paths environment))
+                (build-filesystems environment))
+      (lambda ()
+        (enact-build-environment environment)
+        ;(close-most-files)
+        ;; DROP PRIVILEGES HERE
+        (chdir (build-directory-inside environment))
+        
+        (format #t "command line: ~a~%"
+                (cons (derivation-builder drv)
+                      (derivation-builder-arguments drv)))
+        (if (zero? (status:exit-val
+                    (apply system*
+                           (derivation-builder drv)
+                                        ;(basename (derivation-builder drv))
+                           (derivation-builder-arguments drv))))
+            0
+            (throw 'build-failed-but-lets-debug drv)))
+      #:namespaces `(mnt pid ipc uts ,@(if (fixed-output-derivation? drv)
+                                           '(net)
+                                           '()))
+      #:host-uids (1+ (build-environment-user environment))
+      #:use-output (lambda (root)
+                     (for-each (match-lambda
+                                 ((outid . ($ <derivation-output> output-path))
+                                  (copy-recursively (string-append root
+                                                                   output-path)
+                                                    output-path)))
+                               (derivation-outputs drv))))))
 
 ;; I want to be able to test if a derivation's outputs exist without reading
 ;; it in. The database makes this possible. But we can't figure out WHICH
@@ -709,28 +650,22 @@ nar, and the length of the nar."
 ;; provide 3 pieces of metadata: the size of the nar, the references of each
 ;; output, and the hash of each output. We happen to have ways of getting all
 ;; of those as long as we know which references to be looking for.
-
+;;~/Programming/guix/test-tmp/store/3zazs4zzhv0iw4xw0bi0im0wi55cl4gv-hello-2.10.drv
 (define (do-derivation-build drv)
-  (ensure-input-outputs-exist (derivation-inputs drv))
   (format #t "Starting build of derivation ~a~%~%" drv)
   ;; inputs should all exist as of now
-  (let-values (((build-env store-inputs) (prepare-build-environment drv)))
-    (define (in-chroot file)
-      (string-append (build-chroot-dir build-env) file))
-    
-    (if (zero? (start-builder-child build-env))
-        (begin
-          (for-each (match-lambda
-                      ((outid . ($ <derivation-output> output-path))
-                       (copy-recursively (in-chroot output-path)
-                                         output-path)))
-                    (derivation-outputs drv))
-          (get-output-specs drv store-inputs))
+  (let-values (((build-env store-inputs)
+                (prepare-build-environment drv #:extra-chroot-dirs '())))
+    (if (zero? (run-builder build-env))
+        (get-output-specs drv store-inputs)
         #f)))
 
 (define (%build-derivation drv) 
   "Given a <derivation> DRV, builds/substitutes the derivation unconditionally
 even if its outputs already exist."
+  ;; Inputs need to exist regardless of how we're getting the outputs of this
+  ;; derivation.
+  (ensure-input-outputs-exist (derivation-inputs drv))
   (let ((output-specs
          (or (attempt-substitute drv)
              (maybe-use-builtin drv)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]