diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/system/dmd.scm | 172 | ||||
| -rw-r--r-- | gnu/system/grub.scm | 51 | ||||
| -rw-r--r-- | gnu/system/linux.scm | 22 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 40 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 833 |
5 files changed, 560 insertions, 558 deletions
diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm index 4d3b4b31f0..946b6a7937 100644 --- a/gnu/system/dmd.scm +++ b/gnu/system/dmd.scm @@ -31,6 +31,7 @@ #:select (net-tools)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (guix monads) #:export (service? service service-provision @@ -69,53 +70,51 @@ (inputs service-inputs ; list of inputs (default '()))) -(define (host-name-service store name) +(define (host-name-service name) "Return a service that sets the host name to NAME." - (service - (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) - (respawn? #f))) - -(define (mingetty-service store tty) + (with-monad %store-monad + (return (service + (provision '(host-name)) + (start `(lambda _ + (sethostname ,name))) + (respawn? #f))))) + +(define (mingetty-service tty) "Return a service to run mingetty on TTY." - (let* ((mingetty-drv (package-derivation store mingetty)) - (mingetty-bin (string-append (derivation->output-path mingetty-drv) - "/sbin/mingetty"))) - (service - (provision (list (symbol-append 'term- (string->symbol tty)))) + (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty"))) + (return + (service + (provision (list (symbol-append 'term- (string->symbol tty)))) - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. - (requirement '(host-name)) + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. + (requirement '(host-name)) - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (inputs `(("mingetty" ,mingetty)))))) + (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) + (inputs `(("mingetty" ,mingetty))))))) -(define* (nscd-service store - #:key (glibc glibc-final)) +(define* (nscd-service #:key (glibc glibc-final)) "Return a service that runs libc's name service cache daemon (nscd)." - (let ((nscd (string-append (package-output store glibc) "/sbin/nscd"))) - (service - (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null")) - - ;; XXX: Local copy of 'make-kill-destructor' because the one upstream - ;; uses the broken 'opt-lambda' macro. - (stop `(lambda* (#:optional (signal SIGTERM)) - (lambda (pid . args) - (kill pid signal) - #f))) - - (respawn? #f) - (inputs `(("glibc" ,glibc)))))) - -(define (syslog-service store) + (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (return (service + (provision '(nscd)) + (start `(make-forkexec-constructor ,nscd "-f" "/dev/null")) + + ;; XXX: Local copy of 'make-kill-destructor' because the one upstream + ;; uses the broken 'opt-lambda' macro. + (stop `(lambda* (#:optional (signal SIGTERM)) + (lambda (pid . args) + (kill pid signal) + #f))) + + (respawn? #f) + (inputs `(("glibc" ,glibc))))))) + +(define (syslog-service) "Return a service that runs 'syslogd' with reasonable default settings." - (define syslog.conf - ;; Snippet adapted from the GNU inetutils manual. - (add-text-to-store store "syslog.conf" " + ;; Snippet adapted from the GNU inetutils manual. + (define contents " # Log all kernel messages, authentication messages of # level notice or higher and anything of level err or # higher to the console. @@ -134,31 +133,30 @@ # Log all the mail messages in one place. mail.* /var/log/maillog -")) - - (let* ((inetutils-drv (package-derivation store inetutils)) - (syslogd (string-append (derivation->output-path inetutils-drv) - "/libexec/syslogd"))) - (service - (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd - "--rcfile" ,syslog.conf)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf)))))) - -(define* (guix-service store #:key (guix guix) (builder-group "guixbuild")) +") + + (mlet %store-monad + ((syslog.conf (text-file "syslog.conf" contents)) + (syslogd (package-file inetutils "libexec/syslogd"))) + (return + (service + (provision '(syslogd)) + (start `(make-forkexec-constructor ,syslogd + "--rcfile" ,syslog.conf)) + (inputs `(("inetutils" ,inetutils) + ("syslog.conf" ,syslog.conf))))))) + +(define* (guix-service #:key (guix guix) (builder-group "guixbuild")) "Return a service that runs the build daemon from GUIX." - (let* ((drv (package-derivation store guix)) - (daemon (string-append (derivation->output-path drv) - "/bin/guix-daemon"))) - (service - (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (inputs `(("guix" ,guix)))))) - -(define* (static-networking-service store interface ip + (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon"))) + (return (service + (provision '(guix-daemon)) + (start `(make-forkexec-constructor ,daemon + "--build-users-group" + ,builder-group)) + (inputs `(("guix" ,guix))))))) + +(define* (static-networking-service interface ip #:key gateway (inetutils inetutils) @@ -169,31 +167,30 @@ true, it must be a string specifying the default network gateway." ;; TODO: Eventually we should do this using Guile's networking procedures, ;; like 'configure-qemu-networking' does, but the patch that does this is ;; not yet in stock Guile. - (let ((ifconfig (string-append (package-output store inetutils) - "/bin/ifconfig")) - (route (string-append (package-output store net-tools) - "/sbin/route"))) - (service - (provision '(networking)) - (start `(lambda _ - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(begin - (sleep 3) ; XXX - (zero? (system* ,route "add" "-net" "default" - "gw" ,gateway))) - #t)))) - (stop `(lambda _ - (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '())))))) + (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) + (route (package-file net-tools "sbin/route"))) + (return + (service + (provision '(networking)) + (start `(lambda _ + (and (zero? (system* ,ifconfig ,interface ,ip "up")) + ,(if gateway + `(begin + (sleep 3) ; XXX + (zero? (system* ,route "add" "-net" "default" + "gw" ,gateway))) + #t)))) + (stop `(lambda _ + (system* ,ifconfig ,interface "down") + (system* ,route "del" "-net" "default"))) + (respawn? #f) + (inputs `(("inetutils" ,inetutils) + ,@(if gateway + `(("net-tools" ,net-tools)) + '()))))))) -(define (dmd-configuration-file store services) +(define (dmd-configuration-file services) "Return the dmd configuration file for SERVICES." (define config `(begin @@ -209,7 +206,6 @@ true, it must be a string specifying the default network gateway." services)) (for-each start ',(append-map service-provision services)))) - (add-text-to-store store "dmd.conf" - (object->string config))) + (text-file "dmd.conf" (object->string config))) ;;; dmd.scm ends here diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index b2438b9c5b..abc220b532 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -21,6 +21,7 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix records) + #:use-module (guix monads) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (menu-entry @@ -42,43 +43,45 @@ (default '())) (initrd menu-entry-initrd)) -(define* (grub-configuration-file store entries +(define* (grub-configuration-file entries #:key (default-entry 1) (timeout 5) (system (%current-system))) - "Return the GRUB configuration file in STORE for ENTRIES, a list of + "Return the GRUB configuration file for ENTRIES, a list of <menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT." - (define prologue + (define (prologue kernel) (format #f " set default=~a set timeout=~a search.file ~a~%" - default-entry timeout - (any (match-lambda - (($ <menu-entry> _ linux) - (let* ((drv (package-derivation store linux system)) - (out (derivation->output-path drv))) - (string-append out "/bzImage")))) - entries))) + default-entry timeout kernel)) + + (define (bzImage) + (anym %store-monad + (match-lambda + (($ <menu-entry> _ linux) + (package-file linux "bzImage" + #:system system))) + entries)) (define entry->text (match-lambda (($ <menu-entry> label linux arguments initrd) - (let ((linux-drv (package-derivation store linux system)) - (initrd-drv (package-derivation store initrd system))) + (mlet %store-monad ((linux (package-file linux "bzImage" + #:system system)) + (initrd (package-file initrd "initrd" + #:system system))) ;; XXX: Assume that INITRD is a directory containing an 'initrd' file. - (format #f "menuentry ~s { - linux ~a/bzImage ~a - initrd ~a/initrd + (return (format #f "menuentry ~s { + linux ~a ~a + initrd ~a }~%" - label - (derivation->output-path linux-drv) - (string-join arguments) - (derivation->output-path initrd-drv)))))) + label + linux (string-join arguments) initrd)))))) - (add-text-to-store store "grub.cfg" - (string-append prologue - (string-concatenate - (map entry->text entries))) - '())) + (mlet %store-monad ((kernel (bzImage)) + (body (mapm %store-monad entry->text entries))) + (text-file "grub.cfg" + (string-append (prologue kernel) + (string-concatenate body))))) ;;; grub.scm ends here diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 6aebe159ba..eb3e133044 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix records) #:use-module (guix derivations) + #:use-module (guix monads) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -81,17 +82,20 @@ (map (cut entry->string "password" <>) password) (map (cut entry->string "session" <>) session)))))) -(define (pam-services->directory store services) +(define (pam-services->directory services) "Return the derivation to build the configuration directory to be used as /etc/pam.d for SERVICES." - (let ((names (map pam-service-name services)) - (files (map (match-lambda + (mlet %store-monad + ((names -> (map pam-service-name services)) + (files (mapm %store-monad + (match-lambda ((and service ($ <pam-service> name)) (let ((config (pam-service->configuration service))) - (add-text-to-store store - (string-append name ".pam") - config '())))) - services))) + (text-file (string-append name ".pam") config)))) + + ;; XXX: Eventually, SERVICES may be a list of monadic + ;; values instead of plain values. + (map return services)))) (define builder '(begin (use-modules (ice-9 match)) @@ -104,9 +108,7 @@ %build-inputs) #t))) - (build-expression->derivation store "pam.d" (%current-system) - builder - (zip names files)))) + (derivation-expression "pam.d" (%current-system) builder (zip names files)))) (define %pam-other-services ;; The "other" PAM configuration, which denies everything (see diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 4f59b2b325..654fd4d55b 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix monads) #:use-module ((gnu packages system) #:select (shadow)) #:use-module (srfi srfi-1) @@ -72,7 +73,7 @@ (id user-group-id) (members user-group-members (default '()))) -(define (group-file store groups) +(define (group-file groups) "Return a /etc/group file for GROUPS, a list of <user-group> objects." (define contents (let loop ((groups groups) @@ -87,9 +88,9 @@ (() (string-join (reverse result) "\n" 'suffix))))) - (add-text-to-store store "group" contents)) + (text-file "group" contents)) -(define* (passwd-file store accounts #:key shadow?) +(define* (passwd-file accounts #:key shadow?) "Return a password file for ACCOUNTS, a list of <user-account> objects. If SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd file." @@ -114,28 +115,27 @@ file." (() (string-join (reverse result) "\n" 'suffix))))) - (add-text-to-store store (if shadow? "shadow" "passwd") - contents '())) + (text-file (if shadow? "shadow" "passwd") contents)) -(define* (guix-build-accounts store count #:key +(define* (guix-build-accounts count #:key (first-uid 30001) (gid 30000) (shadow shadow)) "Return a list of COUNT user accounts for Guix build users, with UIDs starting at FIRST-UID, and under GID." - (let* ((gid* gid) - (no-login (string-append (package-output store shadow) "/sbin/nologin"))) - (unfold (cut > <> count) - (lambda (n) - (user-account - (name (format #f "guixbuilder~2,'0d" n)) - (password "!") - (uid (+ first-uid n -1)) - (gid gid*) - (comment (format #f "Guix Build User ~2d" n)) - (home-directory "/var/empty") - (shell no-login))) - 1+ - 1))) + (mlet* %store-monad ((gid* -> gid) + (no-login (package-file shadow "sbin/nologin"))) + (return (unfold (cut > <> count) + (lambda (n) + (user-account + (name (format #f "guixbuilder~2,'0d" n)) + (password "!") + (uid (+ first-uid n -1)) + (gid gid*) + (comment (format #f "Guix Build User ~2d" n)) + (home-directory "/var/empty") + (shell no-login))) + 1+ + 1)))) ;;; shadow.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 83b9f33456..db055fa5fc 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -21,6 +21,7 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix monads) #:use-module ((gnu packages base) #:select (%final-inputs guile-final gcc-final glibc-final @@ -58,7 +59,7 @@ ;;; ;;; Code: -(define* (expression->derivation-in-linux-vm store name exp +(define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) (inputs '()) @@ -89,23 +90,23 @@ made available under the /xchg CIFS share." ;; `build-expression->derivation'. (define input-alist - (map (match-lambda - ((input (? package? package)) - `(,input . ,(package-output store package "out" system))) - ((input (? package? package) sub-drv) - `(,input . ,(package-output store package sub-drv system))) - ((input (? derivation? drv)) - `(,input . ,(derivation->output-path drv))) - ((input (? derivation? drv) sub-drv) - `(,input . ,(derivation->output-path drv sub-drv))) - ((input (and (? string?) (? store-path?) file)) - `(,input . ,file))) - inputs)) - - (define exp* - ;; EXP, but with INPUTS available. - `(let ((%build-inputs ',input-alist)) - ,exp)) + (with-monad %store-monad + (map (match-lambda + ((input (? package? package)) + (mlet %store-monad ((out (package-file package #:system system))) + (return `(,input . ,out)))) + ((input (? package? package) sub-drv) + (mlet %store-monad ((out (package-file package + #:output sub-drv + #:system system))) + (return `(,input . ,out)))) + ((input (? derivation? drv)) + (return `(,input . ,(derivation->output-path drv)))) + ((input (? derivation? drv) sub-drv) + (return `(,input . ,(derivation->output-path drv sub-drv)))) + ((input (and (? string?) (? store-path?) file)) + (return `(,input . ,file)))) + inputs))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -167,34 +168,43 @@ made available under the /xchg CIFS share." (mkdir out) (copy-recursively "xchg" out))))))) - (let ((user-builder (add-text-to-store store "builder-in-linux-vm" - (object->string exp*) - '())) - (->drv (cut package-derivation store <> system)) - (coreutils (car (assoc-ref %final-inputs "coreutils")))) - (build-expression->derivation store name system builder - `(("qemu" ,(->drv qemu)) - ("linux" ,(->drv linux)) - ("initrd" ,(->drv initrd)) - ("coreutils" ,(->drv coreutils)) - ("builder" ,user-builder) - ,@(map (match-lambda - ((name (? package? package) - sub-drv ...) - `(,name ,(->drv package) - ,@sub-drv)) - ((name (? string? file)) - `(,name ,file)) - (tuple tuple)) - inputs)) - #:env-vars env-vars - #:modules (delete-duplicates - `((guix build utils) - ,@modules)) - #:guile-for-build guile-for-build - #:references-graphs references-graphs))) - -(define* (qemu-image store #:key + + (define (lower-inputs inputs) + ;; Turn any package in INPUTS into a derivation. + (with-monad %store-monad + (sequence %store-monad + (map (match-lambda + ((name (? package? package) sub-drv ...) + (mlet %store-monad ((drv (package->derivation package))) + (return `(,name ,drv ,@sub-drv)))) + ((name (? string? file)) + (return `(,name ,file))) + (tuple + (return tuple))) + inputs)))) + + (mlet* %store-monad + ((input-alist (sequence %store-monad input-alist)) + (exp* -> `(let ((%build-inputs ',input-alist)) + ,exp)) + (user-builder (text-file "builder-in-linux-vm" + (object->string exp*))) + (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) + (inputs (lower-inputs `(("qemu" ,qemu) + ("linux" ,linux) + ("initrd" ,initrd) + ("coreutils" ,coreutils) + ("builder" ,user-builder) + ,@inputs)))) + (derivation-expression name system builder inputs + #:env-vars env-vars + #:modules (delete-duplicates + `((guix build utils) + ,@modules)) + #:guile-for-build guile-for-build + #:references-graphs references-graphs))) + +(define* (qemu-image #:key (name "qemu-image") (system (%current-system)) (disk-image-size (* 100 (expt 2 20))) @@ -215,203 +225,206 @@ POPULATE is a list of directives stating directories or symlinks to be created in the disk image partition. It is evaluated once the image has been populated with INPUTS-TO-COPY. It can be used to provide additional files, such as /etc files." - (define input->name+derivation - (match-lambda - ((name (? package? package)) - `(,name . ,(derivation->output-path - (package-derivation store package system)))) - ((name (? package? package) sub-drv) - `(,name . ,(derivation->output-path - (package-derivation store package system) - sub-drv))) - ((name (? derivation? drv)) - `(,name . ,(derivation->output-path drv))) - ((name (? derivation? drv) sub-drv) - `(,name . ,(derivation->output-path drv sub-drv))) - ((input (and (? string?) (? store-path?) file)) - `(,input . ,file)))) - - (expression->derivation-in-linux-vm - store "qemu-image" - `(let () - (use-modules (ice-9 rdelim) - (srfi srfi-1) - (guix build utils) - (guix build linux-initrd)) - - (let ((parted (string-append (assoc-ref %build-inputs "parted") - "/sbin/parted")) - (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") - "/sbin/mkfs.ext3")) - (grub (string-append (assoc-ref %build-inputs "grub") - "/sbin/grub-install")) - (umount (string-append (assoc-ref %build-inputs "util-linux") - "/bin/umount")) ; XXX: add to Guile - (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) - - (define (read-reference-graph port) - ;; Return a list of store paths from the reference graph at PORT. - ;; The data at PORT is the format produced by #:references-graphs. - (let loop ((line (read-line port)) - (result '())) - (cond ((eof-object? line) - (delete-duplicates result)) - ((string-prefix? "/" line) - (loop (read-line port) - (cons line result))) - (else - (loop (read-line port) - result))))) - - (define (things-to-copy) - ;; Return the list of store files to copy to the image. - (define (graph-from-file file) - (call-with-input-file file - read-reference-graph)) - - ,(match inputs-to-copy - (((graph-files . _) ...) - `(let* ((graph-files ',(map (cut string-append "/xchg/" <>) - graph-files)) - (paths (append-map graph-from-file graph-files))) - (delete-duplicates paths))) - (#f ''()))) - - ;; GRUB is full of shell scripts. - (setenv "PATH" - (string-append (dirname grub) ":" - (assoc-ref %build-inputs "coreutils") "/bin:" - (assoc-ref %build-inputs "findutils") "/bin:" - (assoc-ref %build-inputs "sed") "/bin:" - (assoc-ref %build-inputs "grep") "/bin:" - (assoc-ref %build-inputs "gawk") "/bin")) - - (display "creating partition table...\n") - (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" - "mkpart" "primary" "ext2" "1MiB" - ,(format #f "~aB" - (- disk-image-size - (* 5 (expt 2 20)))))) - (begin - (display "creating ext3 partition...\n") - (and (zero? (system* mkfs "-F" "/dev/vda1")) - (let ((store (string-append "/fs" ,%store-directory))) - (display "mounting partition...\n") - (mkdir "/fs") - (mount "/dev/vda1" "/fs" "ext3") - (mkdir-p "/fs/boot/grub") - (symlink grub.cfg "/fs/boot/grub/grub.cfg") - - ;; Populate the image's store. - (mkdir-p store) - (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append "/fs" - thing))) - (cons grub.cfg (things-to-copy))) - - ;; Populate /dev. - (make-essential-device-nodes #:root "/fs") - - ;; Optionally, register the inputs in the image's store. - (let* ((guix (assoc-ref %build-inputs "guix")) - (register (string-append guix - "/sbin/guix-register"))) - ,@(if initialize-store? - (match inputs-to-copy - (((graph-files . _) ...) - (map (lambda (closure) - `(system* register "--prefix" "/fs" - ,(string-append "/xchg/" - closure))) - graph-files))) - '(#f))) - - ;; Evaluate the POPULATE directives. - ,@(let loop ((directives populate) - (statements '())) - (match directives - (() - (reverse statements)) - ((('directory name) rest ...) - (loop rest - (cons `(mkdir-p ,(string-append "/fs" name)) - statements))) - ((('directory name uid gid) rest ...) - (let ((dir (string-append "/fs" name))) - (loop rest - (cons* `(chown ,dir ,uid ,gid) - `(mkdir-p ,dir) - statements)))) - (((new '-> old) rest ...) - (loop rest - (cons `(symlink ,old - ,(string-append "/fs" new)) - statements))))) - - (and=> (assoc-ref %build-inputs "populate") - (lambda (populate) - (chdir "/fs") - (primitive-load populate) - (chdir "/"))) - - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function - ;; (not 'futime'), so the timestamp of - ;; symlinks cannot be changed, and there - ;; are symlinks here pointing to - ;; /nix/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files "/fs" ".*")) - - (and (zero? - (system* grub "--no-floppy" - "--boot-directory" "/fs/boot" - "/dev/vda")) - (zero? (system* umount "/fs")) - (reboot)))))))) - #:system system - #:inputs `(("parted" ,parted) - ("grub" ,grub) - ("e2fsprogs" ,e2fsprogs) - ("grub.cfg" ,grub-configuration) - - ;; For shell scripts. - ("sed" ,(car (assoc-ref %final-inputs "sed"))) - ("grep" ,(car (assoc-ref %final-inputs "grep"))) - ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) - ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) - ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) - ("util-linux" ,util-linux) - - ,@(if initialize-store? - `(("guix" ,guix)) - '()) - - ,@inputs-to-copy) - #:make-disk-image? #t - #:disk-image-size disk-image-size - #:references-graphs (map input->name+derivation inputs-to-copy) - #:modules '((guix build utils) - (guix build linux-initrd)))) + (define (input->name+derivation tuple) + (with-monad %store-monad + (match tuple + ((name (? package? package)) + (mlet %store-monad ((drv (package->derivation package system))) + (return `(,name . ,(derivation->output-path drv))))) + ((name (? package? package) sub-drv) + (mlet %store-monad ((drv (package->derivation package system))) + (return `(,name . ,(derivation->output-path drv sub-drv))))) + ((name (? derivation? drv)) + (return `(,name . ,(derivation->output-path drv)))) + ((name (? derivation? drv) sub-drv) + (return `(,name . ,(derivation->output-path drv sub-drv)))) + ((input (and (? string?) (? store-path?) file)) + (return `(,input . ,file)))))) + + (mlet %store-monad + ((graph (sequence %store-monad + (map input->name+derivation inputs-to-copy)))) + (expression->derivation-in-linux-vm + "qemu-image" + `(let () + (use-modules (ice-9 rdelim) + (srfi srfi-1) + (guix build utils) + (guix build linux-initrd)) + + (let ((parted (string-append (assoc-ref %build-inputs "parted") + "/sbin/parted")) + (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") + "/sbin/mkfs.ext3")) + (grub (string-append (assoc-ref %build-inputs "grub") + "/sbin/grub-install")) + (umount (string-append (assoc-ref %build-inputs "util-linux") + "/bin/umount")) ; XXX: add to Guile + (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) + + (define (read-reference-graph port) + ;; Return a list of store paths from the reference graph at PORT. + ;; The data at PORT is the format produced by #:references-graphs. + (let loop ((line (read-line port)) + (result '())) + (cond ((eof-object? line) + (delete-duplicates result)) + ((string-prefix? "/" line) + (loop (read-line port) + (cons line result))) + (else + (loop (read-line port) + result))))) + + (define (things-to-copy) + ;; Return the list of store files to copy to the image. + (define (graph-from-file file) + (call-with-input-file file + read-reference-graph)) + + ,(match inputs-to-copy + (((graph-files . _) ...) + `(let* ((graph-files ',(map (cut string-append "/xchg/" <>) + graph-files)) + (paths (append-map graph-from-file graph-files))) + (delete-duplicates paths))) + (#f ''()))) + + ;; GRUB is full of shell scripts. + (setenv "PATH" + (string-append (dirname grub) ":" + (assoc-ref %build-inputs "coreutils") "/bin:" + (assoc-ref %build-inputs "findutils") "/bin:" + (assoc-ref %build-inputs "sed") "/bin:" + (assoc-ref %build-inputs "grep") "/bin:" + (assoc-ref %build-inputs "gawk") "/bin")) + + (display "creating partition table...\n") + (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" + "mkpart" "primary" "ext2" "1MiB" + ,(format #f "~aB" + (- disk-image-size + (* 5 (expt 2 20)))))) + (begin + (display "creating ext3 partition...\n") + (and (zero? (system* mkfs "-F" "/dev/vda1")) + (let ((store (string-append "/fs" ,%store-directory))) + (display "mounting partition...\n") + (mkdir "/fs") + (mount "/dev/vda1" "/fs" "ext3") + (mkdir-p "/fs/boot/grub") + (symlink grub.cfg "/fs/boot/grub/grub.cfg") + + ;; Populate the image's store. + (mkdir-p store) + (chmod store #o1775) + (for-each (lambda (thing) + (copy-recursively thing + (string-append "/fs" + thing))) + (cons grub.cfg (things-to-copy))) + + ;; Populate /dev. + (make-essential-device-nodes #:root "/fs") + + ;; Optionally, register the inputs in the image's store. + (let* ((guix (assoc-ref %build-inputs "guix")) + (register (string-append guix + "/sbin/guix-register"))) + ,@(if initialize-store? + (match inputs-to-copy + (((graph-files . _) ...) + (map (lambda (closure) + `(system* register "--prefix" "/fs" + ,(string-append "/xchg/" + closure))) + graph-files))) + '(#f))) + + ;; Evaluate the POPULATE directives. + ,@(let loop ((directives populate) + (statements '())) + (match directives + (() + (reverse statements)) + ((('directory name) rest ...) + (loop rest + (cons `(mkdir-p ,(string-append "/fs" name)) + statements))) + ((('directory name uid gid) rest ...) + (let ((dir (string-append "/fs" name))) + (loop rest + (cons* `(chown ,dir ,uid ,gid) + `(mkdir-p ,dir) + statements)))) + (((new '-> old) rest ...) + (loop rest + (cons `(symlink ,old + ,(string-append "/fs" new)) + statements))))) + + (and=> (assoc-ref %build-inputs "populate") + (lambda (populate) + (chdir "/fs") + (primitive-load populate) + (chdir "/"))) + + (display "clearing file timestamps...\n") + (for-each (lambda (file) + (let ((s (lstat file))) + ;; XXX: Guile uses libc's 'utime' function + ;; (not 'futime'), so the timestamp of + ;; symlinks cannot be changed, and there + ;; are symlinks here pointing to + ;; /nix/store, which is the host, + ;; read-only store. + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files "/fs" ".*")) + + (and (zero? + (system* grub "--no-floppy" + "--boot-directory" "/fs/boot" + "/dev/vda")) + (zero? (system* umount "/fs")) + (reboot)))))))) + #:system system + #:inputs `(("parted" ,parted) + ("grub" ,grub) + ("e2fsprogs" ,e2fsprogs) + ("grub.cfg" ,grub-configuration) + + ;; For shell scripts. + ("sed" ,(car (assoc-ref %final-inputs "sed"))) + ("grep" ,(car (assoc-ref %final-inputs "grep"))) + ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) + ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) + ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) + ("util-linux" ,util-linux) + + ,@(if initialize-store? + `(("guix" ,guix)) + '()) + + ,@inputs-to-copy) + #:make-disk-image? #t + #:disk-image-size disk-image-size + #:references-graphs graph + #:modules '((guix build utils) + (guix build linux-initrd))))) ;;; ;;; Stand-alone VM image. ;;; -(define* (union store inputs +(define* (union inputs #:key (guile (%guile-for-build)) (system (%current-system)) (name "union")) "Return a derivation that builds the union of INPUTS. INPUTS is a list of input tuples." (define builder - `(begin + '(begin (use-modules (guix build union)) (setvbuf (current-output-port) _IOLBF) @@ -423,132 +436,124 @@ input tuples." output (length inputs)) (union-build output inputs)))) - (build-expression->derivation store name system builder - (map (match-lambda - ((name (? package? p)) - `(,name ,(package-derivation store p - system))) - ((name (? package? p) output) - `(,name ,(package-derivation store p - system) - ,output)) - (x x)) - inputs) - #:modules '((guix build union)) - #:guile-for-build guile)) - -(define (system-qemu-image store) + (mlet %store-monad + ((inputs (sequence %store-monad + (map (match-lambda + ((name (? package? p)) + (mlet %store-monad + ((drv (package->derivation p system))) + (return `(,name ,drv)))) + ((name (? package? p) output) + (mlet %store-monad + ((drv (package->derivation p system))) + (return `(,name ,drv ,output)))) + (x + (return x))) + inputs)))) + (derivation-expression name system builder + inputs + #:modules '((guix build union)) + #:guile-for-build guile))) + +(define (system-qemu-image) "Return the derivation of a QEMU image of the GNU system." - (define motd - (add-text-to-store store "motd" " + (define build-user-gid 30000) + + (mlet* %store-monad + ((motd (text-file "motd" " Happy birthday, GNU! http://www.gnu.org/gnu30 ")) - (define %pam-services - ;; Services known to PAM. - (list %pam-other-services - (unix-pam-service "login" - #:allow-empty-passwords? #t - #:motd motd))) - - (define %dmd-services - ;; Services run by dmd. - (list (host-name-service store "gnu") - (mingetty-service store "tty1") - (mingetty-service store "tty2") - (mingetty-service store "tty3") - (mingetty-service store "tty4") - (mingetty-service store "tty5") - (mingetty-service store "tty6") - (syslog-service store) - (guix-service store) - (nscd-service store) - - ;; QEMU networking settings. - (static-networking-service store "eth0" "10.0.2.10" - #:gateway "10.0.2.2"))) - - (define build-user-gid 30000) - - (define build-accounts - (guix-build-accounts store 10 #:gid build-user-gid)) - - (define resolv.conf - ;; Name resolution for default QEMU settings. - (add-text-to-store store "resolv.conf" - "nameserver 10.0.2.3\n")) - - (define etc-services - (string-append (package-output store net-base) "/etc/services")) - (define etc-protocols - (string-append (package-output store net-base) "/etc/protocols")) - (define etc-rpc - (string-append (package-output store net-base) "/etc/rpc")) - - (parameterize ((%guile-for-build (package-derivation store guile-final))) - (let* ((bash-drv (package-derivation store bash)) - (bash-file (string-append (derivation->output-path bash-drv) - "/bin/bash")) - (dmd-drv (package-derivation store dmd)) - (dmd-file (string-append (derivation->output-path dmd-drv) - "/bin/dmd")) - (dmd-conf (dmd-configuration-file store %dmd-services)) - (accounts (cons* (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/") - (shell bash-file)) - (user-account - (name "guest") - (password "") - (uid 1000) (gid 100) - (comment "Guest of GNU") - (home-directory "/home/guest") - (shell bash-file)) - build-accounts)) - (passwd (passwd-file store accounts)) - (shadow (passwd-file store accounts #:shadow? #t)) - (group (group-file store - (list (user-group - (name "root") - (id 0)) - (user-group - (name "users") - (id 100) - (members '("guest"))) - (user-group - (name "guixbuild") - (id build-user-gid) - (members (map user-account-name - build-accounts)))))) - (pam.d-drv (pam-services->directory store %pam-services)) - (pam.d (derivation->output-path pam.d-drv)) - - (packages `(("coreutils" ,coreutils) - ("bash" ,bash) - ("guile" ,guile-2.0) - ("dmd" ,dmd) - ("gcc" ,gcc-final) - ("libc" ,glibc-final) - ("inetutils" ,inetutils) - ("findutils" ,findutils) - ("grep" ,grep) - ("sed" ,sed) - ("procps" ,procps) - ("psmisc" ,psmisc) - ("zile" ,zile) - ("guix" ,guix))) - - ;; TODO: Replace with a real profile with a manifest. - ;; TODO: Generate bashrc from packages' search-paths. - (profile-drv (union store packages - #:name "default-profile")) - (profile (derivation->output-path profile-drv)) - (bashrc (add-text-to-store store "bashrc" - (string-append " + (%pam-services -> + ;; Services known to PAM. + (list %pam-other-services + (unix-pam-service "login" + #:allow-empty-passwords? #t + #:motd motd))) + + (services (listm %store-monad + (host-name-service "gnu") + (mingetty-service "tty1") + (mingetty-service "tty2") + (mingetty-service "tty3") + (mingetty-service "tty4") + (mingetty-service "tty5") + (mingetty-service "tty6") + (syslog-service) + (guix-service) + (nscd-service) + + ;; QEMU networking settings. + (static-networking-service "eth0" "10.0.2.10" + #:gateway "10.0.2.2"))) + + (build-accounts (guix-build-accounts 10 #:gid build-user-gid)) + + (resolv.conf + ;; Name resolution for default QEMU settings. + (text-file "resolv.conf" "nameserver 10.0.2.3\n")) + + (etc-services (package-file net-base "etc/services")) + (etc-protocols (package-file net-base "etc/protocols")) + (etc-rpc (package-file net-base "etc/rpc")) + + (bash-file (package-file bash "bin/bash")) + (dmd-file (package-file dmd "bin/dmd")) + (dmd-conf (dmd-configuration-file services)) + (accounts -> (cons* (user-account + (name "root") + (password "") + (uid 0) (gid 0) + (comment "System administrator") + (home-directory "/") + (shell bash-file)) + (user-account + (name "guest") + (password "") + (uid 1000) (gid 100) + (comment "Guest of GNU") + (home-directory "/home/guest") + (shell bash-file)) + build-accounts)) + (passwd (passwd-file accounts)) + (shadow (passwd-file accounts #:shadow? #t)) + (group (group-file (list (user-group + (name "root") + (id 0)) + (user-group + (name "users") + (id 100) + (members '("guest"))) + (user-group + (name "guixbuild") + (id build-user-gid) + (members (map user-account-name + build-accounts)))))) + (pam.d-drv (pam-services->directory %pam-services)) + (pam.d -> (derivation->output-path pam.d-drv)) + + (packages -> `(("coreutils" ,coreutils) + ("bash" ,bash) + ("guile" ,guile-2.0) + ("dmd" ,dmd) + ("gcc" ,gcc-final) + ("libc" ,glibc-final) + ("inetutils" ,inetutils) + ("findutils" ,findutils) + ("grep" ,grep) + ("sed" ,sed) + ("procps" ,procps) + ("psmisc" ,psmisc) + ("zile" ,zile) + ("guix" ,guix))) + + ;; TODO: Replace with a real profile with a manifest. + ;; TODO: Generate bashrc from packages' search-paths. + (profile-drv (union packages + #:name "default-profile")) + (profile -> (derivation->output-path profile-drv)) + (bashrc (text-file "bashrc" (string-append " export PS1='\\u@\\h\\$ ' export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin export CPATH=$HOME/.guix-profile/include:" profile "/include @@ -557,7 +562,7 @@ alias ls='ls -p --color' alias ll='ls -l' "))) - (issue (add-text-to-store store "issue" " + (issue (text-file "issue" " This is an alpha preview of the GNU system. Welcome. This image features the GNU Guix package manager, which was used to @@ -567,67 +572,63 @@ GNU dmd (http://www.gnu.org/software/dmd/). You can log in as 'guest' or 'root' with no password. ")) - (populate `((directory "/nix/store" 0 ,build-user-gid) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - ("/etc/shadow" -> ,shadow) - ("/etc/passwd" -> ,passwd) - ("/etc/group" -> ,group) - ("/etc/login.defs" -> "/dev/null") - ("/etc/pam.d" -> ,pam.d) - ("/etc/resolv.conf" -> ,resolv.conf) - ("/etc/profile" -> ,bashrc) - ("/etc/issue" -> ,issue) - ("/etc/services" -> ,etc-services) - ("/etc/protocols" -> ,etc-protocols) - ("/etc/rpc" -> ,etc-rpc) - (directory "/var/nix/gcroots") - ("/var/nix/gcroots/default-profile" -> ,profile) - (directory "/tmp") - (directory "/var/nix/profiles/per-user/root" 0 0) - (directory "/var/nix/profiles/per-user/guest" - 1000 100) - (directory "/home/guest" 1000 100))) - (out (derivation->output-path - (package-derivation store mingetty))) - (boot (add-text-to-store store "boot" - (object->string - `(execl ,dmd-file "dmd" - "--config" ,dmd-conf)))) - (entries (list (menu-entry - (label (string-append - "GNU System with Linux-Libre " - (package-version linux-libre) - " (technology preview)")) - (linux linux-libre) - (linux-arguments `("--root=/dev/vda1" - ,(string-append "--load=" boot))) - (initrd gnu-system-initrd)))) - (grub.cfg (grub-configuration-file store entries))) - (qemu-image store - #:grub-configuration grub.cfg - #:populate populate - #:disk-image-size (* 550 (expt 2 20)) - #:initialize-store? #t - #:inputs-to-copy `(("boot" ,boot) - ("linux" ,linux-libre) - ("initrd" ,gnu-system-initrd) - ("pam.d" ,pam.d-drv) - ("profile" ,profile-drv) - - ;; Configuration. - ("dmd.conf" ,dmd-conf) - ("etc-pam.d" ,pam.d-drv) - ("etc-passwd" ,passwd) - ("etc-shadow" ,shadow) - ("etc-group" ,group) - ("etc-resolv.conf" ,resolv.conf) - ("etc-bashrc" ,bashrc) - ("etc-issue" ,issue) - ("etc-motd" ,motd) - ("net-base" ,net-base) - ,@(append-map service-inputs - %dmd-services)))))) + (populate -> `((directory "/nix/store" 0 ,build-user-gid) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + ("/etc/shadow" -> ,shadow) + ("/etc/passwd" -> ,passwd) + ("/etc/group" -> ,group) + ("/etc/login.defs" -> "/dev/null") + ("/etc/pam.d" -> ,pam.d) + ("/etc/resolv.conf" -> ,resolv.conf) + ("/etc/profile" -> ,bashrc) + ("/etc/issue" -> ,issue) + ("/etc/services" -> ,etc-services) + ("/etc/protocols" -> ,etc-protocols) + ("/etc/rpc" -> ,etc-rpc) + (directory "/var/nix/gcroots") + ("/var/nix/gcroots/default-profile" -> ,profile) + (directory "/tmp") + (directory "/var/nix/profiles/per-user/root" 0 0) + (directory "/var/nix/profiles/per-user/guest" + 1000 100) + (directory "/home/guest" 1000 100))) + (boot (text-file "boot" (object->string + `(execl ,dmd-file "dmd" + "--config" ,dmd-conf)))) + (entries -> (list (return (menu-entry + (label (string-append + "GNU system with Linux-Libre " + (package-version linux-libre) + " (technology preview)")) + (linux linux-libre) + (linux-arguments `("--root=/dev/vda1" + ,(string-append "--load=" boot))) + (initrd gnu-system-initrd))))) + (grub.cfg (grub-configuration-file entries))) + (qemu-image #:grub-configuration grub.cfg + #:populate populate + #:disk-image-size (* 550 (expt 2 20)) + #:initialize-store? #t + #:inputs-to-copy `(("boot" ,boot) + ("linux" ,linux-libre) + ("initrd" ,gnu-system-initrd) + ("pam.d" ,pam.d-drv) + ("profile" ,profile-drv) + + ;; Configuration. + ("dmd.conf" ,dmd-conf) + ("etc-pam.d" ,pam.d-drv) + ("etc-passwd" ,passwd) + ("etc-shadow" ,shadow) + ("etc-group" ,group) + ("etc-resolv.conf" ,resolv.conf) + ("etc-bashrc" ,bashrc) + ("etc-issue" ,issue) + ("etc-motd" ,motd) + ("net-base" ,net-base) + ,@(append-map service-inputs + services))))) ;;; vm.scm ends here |