diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/linux-initrd.scm | 136 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 96 |
2 files changed, 111 insertions, 121 deletions
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index e48b399a9d..627d17bac2 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -68,16 +68,22 @@ initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. - (define (string->regexp str) - ;; Return a regexp that matches STR exactly. - (string-append "^" (regexp-quote str) "$")) - - (mlet* %store-monad ((source (imported-modules modules)) - (compiled (compiled-modules modules))) + (define graph-files + (unfold-right zero? + number->string + 1- + (length to-copy))) + + (mlet %store-monad ((source (imported-modules modules)) + (compiled (compiled-modules modules)) + (module-dir (flat-linux-module-directory linux + linux-modules))) (define builder - ;; TODO: Move most of this code to (guix build linux-initrd). + ;; TODO: Move most of this code to (gnu build linux-initrd). #~(begin - (use-modules (guix build utils) + (use-modules (gnu build linux-initrd) + (guix build utils) + (guix build store-copy) (ice-9 pretty-print) (ice-9 popen) (ice-9 match) @@ -87,9 +93,7 @@ initrd." (rnrs bytevectors) ((system foreign) #:select (sizeof))) - (let ((cpio (string-append #$cpio "/bin/cpio")) - (gzip (string-append #$gzip "/bin/gzip")) - (modules #$source) + (let ((modules #$source) (gos #$compiled) (scm-dir (string-append "share/guile/" (effective-version))) (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" @@ -101,6 +105,7 @@ initrd." (effective-version)))) (mkdir #$output) (mkdir "contents") + (with-directory-excursion "contents" (copy-recursively #$guile ".") (call-with-output-file "init" @@ -127,74 +132,58 @@ initrd." #:output-file (string-append go-dir "/init.go")) ;; Copy Linux modules. - (let* ((linux #$linux) - (module-dir (and linux - (string-append linux "/lib/modules")))) - (mkdir "modules") - #$@(map (lambda (module) - #~(match (find-files module-dir - #$(string->regexp module)) - ((file) - (format #t "copying '~a'...~%" file) - (copy-file file (string-append "modules/" - #$module))) - (() - (error "module not found" #$module module-dir)) - ((_ ...) - (error "several modules by that name" - #$module module-dir)))) - linux-modules)) - - (let ((store #$(string-append "." (%store-prefix))) - (to-copy '#$to-copy)) - (unless (null? to-copy) - (mkdir-p store)) - ;; XXX: Should we do export-references-graph? - (for-each (lambda (input) - (let ((target - (string-append store "/" - (basename input)))) - (copy-recursively input target))) - to-copy)) + (mkdir "modules") + (copy-recursively #$module-dir "modules") + + ;; Populate the initrd's store. + (with-directory-excursion ".." + (populate-store '#$graph-files "contents")) ;; Reset the timestamps of all the files that will make it in the ;; initrd. (for-each (cut utime <> 0 0 0 0) (find-files "." ".*")) - (system* cpio "--version") - (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" - "-O" (string-append #$output "/initrd") - "-H" "newc" "--null"))) - (define print0 - (let ((len (string-length "./"))) - (lambda (file) - (format pipe "~a\0" (string-drop file len))))) - - ;; Note: as per `ramfs-rootfs-initramfs.txt', always add - ;; directory entries before the files that are inside of it: "The - ;; Linux kernel cpio extractor won't create files in a directory - ;; that doesn't exist, so the directory entries must go before - ;; the files that go in those directories." - (file-system-fold (const #t) - (lambda (file stat result) ; leaf - (print0 file)) - (lambda (dir stat result) ; down - (unless (string=? dir ".") - (print0 dir))) - (const #f) ; up - (const #f) ; skip - (const #f) - #f - ".") - - (and (zero? (close-pipe pipe)) - (with-directory-excursion #$output - (and (zero? (system* gzip "--best" "initrd")) - (rename-file "initrd.gz" "initrd"))))))))) + (write-cpio-archive (string-append #$output "/initrd") "." + #:cpio (string-append #$cpio "/bin/cpio") + #:gzip (string-append #$gzip "/bin/gzip")))))) (gexp->derivation name builder - #:modules '((guix build utils))))) + #:modules '((guix build utils) + (guix build store-copy) + (gnu build linux-initrd)) + #:references-graphs (zip graph-files to-copy)))) + +(define (flat-linux-module-directory linux modules) + "Return a flat directory containing the Linux kernel modules listed in +MODULES and taken from LINUX." + (define build-exp + #~(begin + (use-modules (ice-9 match) (ice-9 regex) + (guix build utils)) + + (define (string->regexp str) + ;; Return a regexp that matches STR exactly. + (string-append "^" (regexp-quote str) "$")) + + (define module-dir + (string-append #$linux "/lib/modules")) + + (mkdir #$output) + (for-each (lambda (module) + (match (find-files module-dir (string->regexp module)) + ((file) + (format #t "copying '~a'...~%" file) + (copy-file file (string-append #$output "/" module))) + (() + (error "module not found" module module-dir)) + ((_ ...) + (error "several modules by that name" + module module-dir)))) + '#$modules))) + + (gexp->derivation "linux-modules" build-exp + #:modules '((guix build utils)))) (define (file-system->spec fs) "Return a list corresponding to file-system FS that can be passed to the @@ -277,7 +266,7 @@ exception and backtrace!)." (expression->initrd #~(begin - (use-modules (guix build linux-initrd) + (use-modules (gnu build linux-boot) (guix build utils) (srfi srfi-26)) @@ -293,7 +282,8 @@ exception and backtrace!)." #:volatile-root? '#$volatile-root?)) #:name "base-initrd" #:modules '((guix build utils) - (guix build linux-initrd)) + (gnu build linux-boot) + (gnu build file-systems)) #:to-copy helper-packages #:linux linux-libre #:linux-modules linux-modules)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 42fc23ee8f..205bf2cb19 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -23,7 +23,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix monads) - #:use-module ((guix build vm) + #:use-module ((gnu build vm) #:select (qemu-command)) #:use-module (gnu packages base) #:use-module (gnu packages guile) @@ -112,10 +112,12 @@ input tuple. The output file name is when building for SYSTEM." (qemu qemu-headless) (env-vars '()) (modules - '((guix build vm) - (guix build install) - (guix build linux-initrd) - (guix build utils))) + '((gnu build vm) + (gnu build install) + (gnu build linux-boot) + (gnu build file-systems) + (guix build utils) + (guix build store-copy))) (guile-for-build (%guile-for-build)) @@ -164,7 +166,7 @@ made available under the /xchg CIFS share." ;; Code that launches the VM that evaluates EXP. #~(begin (use-modules (guix build utils) - (guix build vm)) + (gnu build vm)) (let ((inputs '#$(list qemu coreutils)) (linux (string-append #$linux "/bzImage")) @@ -217,48 +219,46 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in the image." - (mlet %store-monad - ((graph (sequence %store-monad (map input->name+output inputs)))) - (expression->derivation-in-linux-vm - name - #~(begin - (use-modules (guix build vm) - (guix build utils)) - - (let ((inputs - '#$(append (list qemu parted grub e2fsprogs util-linux) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - (let ((graphs '#$(match inputs - (((names . _) ...) - names)))) - (initialize-hard-disk "/dev/vda" - #:system-directory #$os-derivation - #:grub.cfg #$grub-configuration - #:closures graphs - #:copy-closures? #$copy-inputs? - #:register-closures? #$register-closures? - #:disk-image-size #$disk-image-size - #:file-system-type #$file-system-type - #:file-system-label #$file-system-label) - (reboot)))) - #:system system - #:make-disk-image? #t - #:disk-image-size disk-image-size - #:disk-image-format disk-image-format - #:references-graphs graph))) + (expression->derivation-in-linux-vm + name + #~(begin + (use-modules (gnu build vm) + (guix build utils)) + + (let ((inputs + '#$(append (list qemu parted grub e2fsprogs util-linux) + (map canonical-package + (list sed grep coreutils findutils gawk)) + (if register-closures? (list guix) '()))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let ((graphs '#$(match inputs + (((names . _) ...) + names)))) + (initialize-hard-disk "/dev/vda" + #:system-directory #$os-derivation + #:grub.cfg #$grub-configuration + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? + #:disk-image-size #$disk-image-size + #:file-system-type #$file-system-type + #:file-system-label #$file-system-label) + (reboot)))) + #:system system + #:make-disk-image? #t + #:disk-image-size disk-image-size + #:disk-image-format disk-image-format + #:references-graphs inputs)) ;;; |