aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/dmd.scm172
-rw-r--r--gnu/system/grub.scm51
-rw-r--r--gnu/system/linux.scm22
-rw-r--r--gnu/system/shadow.scm40
-rw-r--r--gnu/system/vm.scm833
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
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-13 19:24:54 +0000