guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

linux-initrd: Rewrite using gexps. 

* gnu/system/linux-initrd.scm (expression->initrd): Rename 'inputs'
  parameter to 'to-copy'.  Remove 'files-to-copy'.  Rewrite 'builder' as
  a gexp, and use 'gexp->derivation'.
  (qemu-initrd): Adjust accordingly.
version-0.8.3
Ludovic Courtès 8 years ago
parent
8c35bfb68c
commit
0c21d92b1c
1 changed files with 137 additions and 161 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 298
      gnu/system/linux-initrd.scm

298
gnu/system/linux-initrd.scm
View File

@ -18,6 +18,7 @@
(define-module (gnu system linux-initrd)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module ((guix store)
#:select (%store-prefix))
@ -52,14 +53,14 @@
(name "guile-initrd")
(system (%current-system))
(modules '())
(inputs '())
(to-copy '())
(linux #f)
(linux-modules '()))
"Return a package that contains a Linux initrd (a gzipped cpio archive)
containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list
of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list
of additional inputs to be copied in the initrd. MODULES is a list of Guile
module names to be embedded in the initrd."
of `.ko' file names to be copied from LINUX into the initrd. TO-COPY is a
list of additional derivations or packages to copy to the initrd. MODULES is
a list of Guile module names to be embedded in the initrd."
;; General Linux overview in `Documentation/early-userspace/README' and
;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
@ -68,154 +69,129 @@ module names to be embedded in the initrd."
;; Return a regexp that matches STR exactly.
(string-append "^" (regexp-quote str) "$"))
(define (files-to-copy)
(mlet %store-monad ((inputs (lower-inputs inputs)))
(return (map (match-lambda
((_ drv)
(derivation->output-path drv))
((_ drv sub-drv)
(derivation->output-path drv sub-drv)))
inputs))))
(mlet* %store-monad ((source (imported-modules modules))
(compiled (compiled-modules modules)))
(define builder
;; TODO: Move most of this code to (guix build linux-initrd).
#~(begin
(use-modules (guix build utils)
(ice-9 pretty-print)
(ice-9 popen)
(ice-9 match)
(ice-9 ftw)
(srfi srfi-26)
(system base compile)
(rnrs bytevectors)
((system foreign) #:select (sizeof)))
(define (builder to-copy)
`(begin
(use-modules (guix build utils)
(ice-9 pretty-print)
(ice-9 popen)
(ice-9 match)
(ice-9 ftw)
(srfi srfi-26)
(system base compile)
(rnrs bytevectors)
((system foreign) #:select (sizeof)))
(let ((cpio (string-append #$cpio "/bin/cpio"))
(gzip (string-append #$gzip "/bin/gzip"))
(modules #$source)
(gos #$compiled)
(scm-dir (string-append "share/guile/" (effective-version)))
(go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a"
(effective-version)
(if (eq? (native-endianness) (endianness little))
"LE"
"BE")
(sizeof '*)
(effective-version))))
(mkdir #$output)
(mkdir "contents")
(with-directory-excursion "contents"
(copy-recursively #$guile ".")
(call-with-output-file "init"
(lambda (p)
(format p "#!/bin/guile -ds~%!#~%" #$guile)
(pretty-print '#$exp p)))
(chmod "init" #o555)
(chmod "bin/guile" #o555)
(let ((guile (assoc-ref %build-inputs "guile"))
(cpio (string-append (assoc-ref %build-inputs "cpio")
"/bin/cpio"))
(gzip (string-append (assoc-ref %build-inputs "gzip")
"/bin/gzip"))
(modules (assoc-ref %build-inputs "modules"))
(gos (assoc-ref %build-inputs "modules/compiled"))
(scm-dir (string-append "share/guile/" (effective-version)))
(go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a"
(effective-version)
(if (eq? (native-endianness) (endianness little))
"LE"
"BE")
(sizeof '*)
(effective-version)))
(out (assoc-ref %outputs "out")))
(mkdir out)
(mkdir "contents")
(with-directory-excursion "contents"
(copy-recursively guile ".")
(call-with-output-file "init"
(lambda (p)
(format p "#!/bin/guile -ds~%!#~%" guile)
(pretty-print ',exp p)))
(chmod "init" #o555)
(chmod "bin/guile" #o555)
;; Copy Guile modules.
(chmod scm-dir #o777)
(copy-recursively modules scm-dir
#:follow-symlinks? #t)
(copy-recursively gos (string-append "lib/guile/"
(effective-version) "/ccache")
#:follow-symlinks? #t)
;; Copy Guile modules.
(chmod scm-dir #o777)
(copy-recursively modules scm-dir
#:follow-symlinks? #t)
(copy-recursively gos (string-append "lib/guile/"
(effective-version) "/ccache")
#:follow-symlinks? #t)
;; Compile `init'.
(mkdir-p go-dir)
(set! %load-path (cons modules %load-path))
(set! %load-compiled-path (cons gos %load-compiled-path))
(compile-file "init"
#:opts %auto-compilation-options
#:output-file (string-append go-dir "/init.go"))
;; Compile `init'.
(mkdir-p go-dir)
(set! %load-path (cons modules %load-path))
(set! %load-compiled-path (cons gos %load-compiled-path))
(compile-file "init"
#:opts %auto-compilation-options
#: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))
;; Copy Linux modules.
(let* ((linux (assoc-ref %build-inputs "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))
,@(if (null? to-copy)
'()
`((let ((store ,(string-append "." (%store-prefix))))
(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))))
;; Reset the timestamps of all the files that will make it in the
;; initrd.
(for-each (cut utime <> 0 0 0 0)
(find-files "." ".*"))
;; 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)))))
(system* cpio "--version")
(let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
"-O" (string-append out "/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
".")
;; 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")))))))))
(and (zero? (close-pipe pipe))
(with-directory-excursion out
(and (zero? (system* gzip "--best" "initrd"))
(rename-file "initrd.gz" "initrd")))))))))
(mlet* %store-monad
((source (imported-modules modules))
(compiled (compiled-modules modules))
(inputs (lower-inputs
`(("guile" ,guile)
("cpio" ,cpio)
("gzip" ,gzip)
("modules" ,source)
("modules/compiled" ,compiled)
,@(if linux
`(("linux" ,linux))
'())
,@inputs)))
(to-copy (files-to-copy)))
(derivation-expression name (builder to-copy)
#:modules '((guix build utils))
#:inputs inputs)))
(gexp->derivation name builder
#:modules '((guix build utils)))))
(define* (qemu-initrd #:key
guile-modules-in-chroot?
@ -257,26 +233,26 @@ to it are lost."
'("fuse.ko")
'())))
(mlet %store-monad
((unionfs (package-file unionfs-fuse/static "bin/unionfs")))
(expression->initrd
`(begin
(use-modules (guix build linux-initrd))
(expression->initrd
#~(begin
(use-modules (guix build linux-initrd)
(srfi srfi-26))
(boot-system #:mounts ',mounts
#:linux-modules ',linux-modules
#:qemu-guest-networking? #t
#:guile-modules-in-chroot? ',guile-modules-in-chroot?
#:unionfs ,unionfs
#:volatile-root? ',volatile-root?))
#:name "qemu-initrd"
#:modules '((guix build utils)
(guix build linux-initrd))
#:linux linux-libre
#:linux-modules linux-modules
#:inputs (if volatile-root?
`(("unionfs" ,unionfs-fuse/static))
'()))))
(boot-system #:mounts '#$mounts
#:linux-modules '#$linux-modules
#:qemu-guest-networking? #t
#:guile-modules-in-chroot? '#$guile-modules-in-chroot?
#:unionfs (and=> #$(and volatile-root? unionfs-fuse/static)
(cut string-append <> "/bin/unionfs"))
#:volatile-root? '#$volatile-root?))
#:name "qemu-initrd"
#:modules '((guix build utils)
(guix build linux-initrd))
#:to-copy (if volatile-root?
(list unionfs-fuse/static)
'())
#:linux linux-libre
#:linux-modules linux-modules))
(define (gnu-system-initrd)
"Initrd for the GNU system itself, with nothing QEMU-specific."

Write Preview
Loading…
Cancel
Save