nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gnu: vm: Rewrite helper functions as monadic functions. 

* gnu/system/dmd.scm (host-name-service, nscd-service, mingetty-service,
  syslog-service, guix-service, static-networking-service): Rewrite as
  monadic functions.
  (dmd-configuration-file): Use 'text-file' instead of
  'add-text-to-store'.
* gnu/system/grub.scm (grub-configuration-file): Rewrite as a monadic
  function.
* gnu/system/linux.scm (pam-services->directory): Likewise.
* gnu/system/shadow.scm (group-file, passwd-file, guix-build-accounts):
  Likewise.
* gnu/system/vm.scm (expression->derivation-in-linux-vm, qemu-image,
  union, system-qemu-image): Likewise.
master
Ludovic Courtès 2013-10-03 21:30:30 +02:00
parent b860f38244
commit d9f0a23704
5 changed files with 525 additions and 523 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

158
gnu/system/dmd.scm
View File

@ -31,6 +31,7 @@
#:select (net-tools)) #:select (net-tools))
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (guix monads)
#:export (service? #:export (service?
service service
service-provision service-provision
@ -69,53 +70,51 @@
(inputs service-inputs ; list of inputs (inputs service-inputs ; list of inputs
(default '()))) (default '())))
(define (host-name-service store name) (define (host-name-service name)
"Return a service that sets the host name to NAME." "Return a service that sets the host name to NAME."
(service (with-monad %store-monad
(provision '(host-name)) (return (service
(start `(lambda _ (provision '(host-name))
(sethostname ,name))) (start `(lambda _
(respawn? #f))) (sethostname ,name)))
(respawn? #f)))))
(define (mingetty-service store tty) (define (mingetty-service tty)
"Return a service to run mingetty on TTY." "Return a service to run mingetty on TTY."
(let* ((mingetty-drv (package-derivation store mingetty)) (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")))
(mingetty-bin (string-append (derivation->output-path mingetty-drv) (return
"/sbin/mingetty"))) (service
(service (provision (list (symbol-append 'term- (string->symbol tty))))
(provision (list (symbol-append 'term- (string->symbol tty))))
;; Since the login prompt shows the host name, wait for the 'host-name' ;; Since the login prompt shows the host name, wait for the 'host-name'
;; service to be done. ;; service to be done.
(requirement '(host-name)) (requirement '(host-name))
(start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
(inputs `(("mingetty" ,mingetty)))))) (inputs `(("mingetty" ,mingetty)))))))
(define* (nscd-service store (define* (nscd-service #:key (glibc glibc-final))
#:key (glibc glibc-final))
"Return a service that runs libc's name service cache daemon (nscd)." "Return a service that runs libc's name service cache daemon (nscd)."
(let ((nscd (string-append (package-output store glibc) "/sbin/nscd"))) (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
(service (return (service
(provision '(nscd)) (provision '(nscd))
(start `(make-forkexec-constructor ,nscd "-f" "/dev/null")) (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
;; XXX: Local copy of 'make-kill-destructor' because the one upstream ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
;; uses the broken 'opt-lambda' macro. ;; uses the broken 'opt-lambda' macro.
(stop `(lambda* (#:optional (signal SIGTERM)) (stop `(lambda* (#:optional (signal SIGTERM))
(lambda (pid . args) (lambda (pid . args)
(kill pid signal) (kill pid signal)
#f))) #f)))
(respawn? #f) (respawn? #f)
(inputs `(("glibc" ,glibc)))))) (inputs `(("glibc" ,glibc)))))))
(define (syslog-service store) (define (syslog-service)
"Return a service that runs 'syslogd' with reasonable default settings." "Return a service that runs 'syslogd' with reasonable default settings."
(define syslog.conf ;; Snippet adapted from the GNU inetutils manual.
;; Snippet adapted from the GNU inetutils manual. (define contents "
(add-text-to-store store "syslog.conf" "
# Log all kernel messages, authentication messages of # Log all kernel messages, authentication messages of
# level notice or higher and anything of level err or # level notice or higher and anything of level err or
# higher to the console. # higher to the console.
@ -134,31 +133,30 @@
# Log all the mail messages in one place. # Log all the mail messages in one place.
mail.* /var/log/maillog mail.* /var/log/maillog
")) ")
(let* ((inetutils-drv (package-derivation store inetutils)) (mlet %store-monad
(syslogd (string-append (derivation->output-path inetutils-drv) ((syslog.conf (text-file "syslog.conf" contents))
"/libexec/syslogd"))) (syslogd (package-file inetutils "libexec/syslogd")))
(service (return
(provision '(syslogd)) (service
(start `(make-forkexec-constructor ,syslogd (provision '(syslogd))
"--rcfile" ,syslog.conf)) (start `(make-forkexec-constructor ,syslogd
(inputs `(("inetutils" ,inetutils) "--rcfile" ,syslog.conf))
("syslog.conf" ,syslog.conf)))))) (inputs `(("inetutils" ,inetutils)
("syslog.conf" ,syslog.conf)))))))
(define* (guix-service store #:key (guix guix) (builder-group "guixbuild")) (define* (guix-service #:key (guix guix) (builder-group "guixbuild"))
"Return a service that runs the build daemon from GUIX." "Return a service that runs the build daemon from GUIX."
(let* ((drv (package-derivation store guix)) (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")))
(daemon (string-append (derivation->output-path drv) (return (service
"/bin/guix-daemon"))) (provision '(guix-daemon))
(service (start `(make-forkexec-constructor ,daemon
(provision '(guix-daemon)) "--build-users-group"
(start `(make-forkexec-constructor ,daemon ,builder-group))
"--build-users-group" (inputs `(("guix" ,guix)))))))
,builder-group))
(inputs `(("guix" ,guix))))))
(define* (static-networking-service store interface ip (define* (static-networking-service interface ip
#:key #:key
gateway gateway
(inetutils inetutils) (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, ;; TODO: Eventually we should do this using Guile's networking procedures,
;; like 'configure-qemu-networking' does, but the patch that does this is ;; like 'configure-qemu-networking' does, but the patch that does this is
;; not yet in stock Guile. ;; not yet in stock Guile.
(let ((ifconfig (string-append (package-output store inetutils) (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig"))
"/bin/ifconfig")) (route (package-file net-tools "sbin/route")))
(route (string-append (package-output store net-tools) (return
"/sbin/route"))) (service
(service (provision '(networking))
(provision '(networking)) (start `(lambda _
(start `(lambda _ (and (zero? (system* ,ifconfig ,interface ,ip "up"))
(and (zero? (system* ,ifconfig ,interface ,ip "up")) ,(if gateway
,(if gateway `(begin
`(begin (sleep 3) ; XXX
(sleep 3) ; XXX (zero? (system* ,route "add" "-net" "default"
(zero? (system* ,route "add" "-net" "default" "gw" ,gateway)))
"gw" ,gateway))) #t))))
#t)))) (stop `(lambda _
(stop `(lambda _ (system* ,ifconfig ,interface "down")
(system* ,ifconfig ,interface "down") (system* ,route "del" "-net" "default")))
(system* ,route "del" "-net" "default"))) (respawn? #f)
(respawn? #f) (inputs `(("inetutils" ,inetutils)
(inputs `(("inetutils" ,inetutils) ,@(if gateway
,@(if gateway `(("net-tools" ,net-tools))
`(("net-tools" ,net-tools)) '())))))))
'()))))))
(define (dmd-configuration-file store services) (define (dmd-configuration-file services)
"Return the dmd configuration file for SERVICES." "Return the dmd configuration file for SERVICES."
(define config (define config
`(begin `(begin
@ -209,7 +206,6 @@ true, it must be a string specifying the default network gateway."
services)) services))
(for-each start ',(append-map service-provision services)))) (for-each start ',(append-map service-provision services))))
(add-text-to-store store "dmd.conf" (text-file "dmd.conf" (object->string config)))
(object->string config)))
;;; dmd.scm ends here ;;; dmd.scm ends here

51
gnu/system/grub.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix monads)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (menu-entry #:export (menu-entry
@ -42,43 +43,45 @@
(default '())) (default '()))
(initrd menu-entry-initrd)) (initrd menu-entry-initrd))
(define* (grub-configuration-file store entries (define* (grub-configuration-file entries
#:key (default-entry 1) (timeout 5) #:key (default-entry 1) (timeout 5)
(system (%current-system))) (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." <menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
(define prologue (define (prologue kernel)
(format #f " (format #f "
set default=~a set default=~a
set timeout=~a set timeout=~a
search.file ~a~%" search.file ~a~%"
default-entry timeout default-entry timeout kernel))
(any (match-lambda
(($ <menu-entry> _ linux) (define (bzImage)
(let* ((drv (package-derivation store linux system)) (anym %store-monad
(out (derivation->output-path drv))) (match-lambda
(string-append out "/bzImage")))) (($ <menu-entry> _ linux)
entries))) (package-file linux "bzImage"
#:system system)))
entries))
(define entry->text (define entry->text
(match-lambda (match-lambda
(($ <menu-entry> label linux arguments initrd) (($ <menu-entry> label linux arguments initrd)
(let ((linux-drv (package-derivation store linux system)) (mlet %store-monad ((linux (package-file linux "bzImage"
(initrd-drv (package-derivation store initrd system))) #:system system))
(initrd (package-file initrd "initrd"
#:system system)))
;; XXX: Assume that INITRD is a directory containing an 'initrd' file. ;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
(format #f "menuentry ~s { (return (format #f "menuentry ~s {
linux ~a/bzImage ~a linux ~a ~a
initrd ~a/initrd initrd ~a
}~%" }~%"
label label
(derivation->output-path linux-drv) linux (string-join arguments) initrd))))))
(string-join arguments)
(derivation->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg" (mlet %store-monad ((kernel (bzImage))
(string-append prologue (body (mapm %store-monad entry->text entries)))
(string-concatenate (text-file "grub.cfg"
(map entry->text entries))) (string-append (prologue kernel)
'())) (string-concatenate body)))))
;;; grub.scm ends here ;;; grub.scm ends here

22
gnu/system/linux.scm
View File

@ -20,6 +20,7 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix monads)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -81,17 +82,20 @@
(map (cut entry->string "password" <>) password) (map (cut entry->string "password" <>) password)
(map (cut entry->string "session" <>) session)))))) (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 "Return the derivation to build the configuration directory to be used as
/etc/pam.d for SERVICES." /etc/pam.d for SERVICES."
(let ((names (map pam-service-name services)) (mlet %store-monad
(files (map (match-lambda ((names -> (map pam-service-name services))
(files (mapm %store-monad
(match-lambda
((and service ($ <pam-service> name)) ((and service ($ <pam-service> name))
(let ((config (pam-service->configuration service))) (let ((config (pam-service->configuration service)))
(add-text-to-store store (text-file (string-append name ".pam") config))))
(string-append name ".pam")
config '())))) ;; XXX: Eventually, SERVICES may be a list of monadic
services))) ;; values instead of plain values.
(map return services))))
(define builder (define builder
'(begin '(begin
(use-modules (ice-9 match)) (use-modules (ice-9 match))
@ -104,9 +108,7 @@
%build-inputs) %build-inputs)
#t))) #t)))
(build-expression->derivation store "pam.d" (%current-system) (derivation-expression "pam.d" (%current-system) builder (zip names files))))
builder
(zip names files))))
(define %pam-other-services (define %pam-other-services
;; The "other" PAM configuration, which denies everything (see ;; The "other" PAM configuration, which denies everything (see

40
gnu/system/shadow.scm
View File

@ -20,6 +20,7 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix monads)
#:use-module ((gnu packages system) #:use-module ((gnu packages system)
#:select (shadow)) #:select (shadow))
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -72,7 +73,7 @@
(id user-group-id) (id user-group-id)
(members user-group-members (default '()))) (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." "Return a /etc/group file for GROUPS, a list of <user-group> objects."
(define contents (define contents
(let loop ((groups groups) (let loop ((groups groups)
@ -87,9 +88,9 @@
(() (()
(string-join (reverse result) "\n" 'suffix))))) (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 "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 SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd
file." file."
@ -114,28 +115,27 @@ file."
(() (()
(string-join (reverse result) "\n" 'suffix))))) (string-join (reverse result) "\n" 'suffix)))))
(add-text-to-store store (if shadow? "shadow" "passwd") (text-file (if shadow? "shadow" "passwd") contents))
contents '()))
(define* (guix-build-accounts store count #:key (define* (guix-build-accounts count #:key
(first-uid 30001) (first-uid 30001)
(gid 30000) (gid 30000)
(shadow shadow)) (shadow shadow))
"Return a list of COUNT user accounts for Guix build users, with UIDs "Return a list of COUNT user accounts for Guix build users, with UIDs
starting at FIRST-UID, and under GID." starting at FIRST-UID, and under GID."
(let* ((gid* gid) (mlet* %store-monad ((gid* -> gid)
(no-login (string-append (package-output store shadow) "/sbin/nologin"))) (no-login (package-file shadow "sbin/nologin")))
(unfold (cut > <> count) (return (unfold (cut > <> count)
(lambda (n) (lambda (n)
(user-account (user-account
(name (format #f "guixbuilder~2,'0d" n)) (name (format #f "guixbuilder~2,'0d" n))
(password "!") (password "!")
(uid (+ first-uid n -1)) (uid (+ first-uid n -1))
(gid gid*) (gid gid*)
(comment (format #f "Guix Build User ~2d" n)) (comment (format #f "Guix Build User ~2d" n))
(home-directory "/var/empty") (home-directory "/var/empty")
(shell no-login))) (shell no-login)))
1+ 1+
1))) 1))))
;;; shadow.scm ends here ;;; shadow.scm ends here

777
gnu/system/vm.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix monads)
#:use-module ((gnu packages base) #:use-module ((gnu packages base)
#:select (%final-inputs #:select (%final-inputs
guile-final gcc-final glibc-final guile-final gcc-final glibc-final
@ -58,7 +59,7 @@
;;; ;;;
;;; Code: ;;; Code:
(define* (expression->derivation-in-linux-vm store name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
(system (%current-system)) (system (%current-system))
(inputs '()) (inputs '())
@ -89,23 +90,23 @@ made available under the /xchg CIFS share."
;; `build-expression->derivation'. ;; `build-expression->derivation'.
(define input-alist (define input-alist
(map (match-lambda (with-monad %store-monad
((input (? package? package)) (map (match-lambda
`(,input . ,(package-output store package "out" system))) ((input (? package? package))
((input (? package? package) sub-drv) (mlet %store-monad ((out (package-file package #:system system)))
`(,input . ,(package-output store package sub-drv system))) (return `(,input . ,out))))
((input (? derivation? drv)) ((input (? package? package) sub-drv)
`(,input . ,(derivation->output-path drv))) (mlet %store-monad ((out (package-file package
((input (? derivation? drv) sub-drv) #:output sub-drv
`(,input . ,(derivation->output-path drv sub-drv))) #:system system)))
((input (and (? string?) (? store-path?) file)) (return `(,input . ,out))))
`(,input . ,file))) ((input (? derivation? drv))
inputs)) (return `(,input . ,(derivation->output-path drv))))
((input (? derivation? drv) sub-drv)
(define exp* (return `(,input . ,(derivation->output-path drv sub-drv))))
;; EXP, but with INPUTS available. ((input (and (? string?) (? store-path?) file))
`(let ((%build-inputs ',input-alist)) (return `(,input . ,file))))
,exp)) inputs)))
(define builder (define builder
;; Code that launches the VM that evaluates EXP. ;; Code that launches the VM that evaluates EXP.
@ -167,34 +168,43 @@ made available under the /xchg CIFS share."
(mkdir out) (mkdir out)
(copy-recursively "xchg" 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") (name "qemu-image")
(system (%current-system)) (system (%current-system))
(disk-image-size (* 100 (expt 2 20))) (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 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, populated with INPUTS-TO-COPY. It can be used to provide additional files,
such as /etc files." such as /etc files."
(define input->name+derivation (define (input->name+derivation tuple)
(match-lambda (with-monad %store-monad
((name (? package? package)) (match tuple
`(,name . ,(derivation->output-path ((name (? package? package))
(package-derivation store package system)))) (mlet %store-monad ((drv (package->derivation package system)))
((name (? package? package) sub-drv) (return `(,name . ,(derivation->output-path drv)))))
`(,name . ,(derivation->output-path ((name (? package? package) sub-drv)
(package-derivation store package system) (mlet %store-monad ((drv (package->derivation package system)))
sub-drv))) (return `(,name . ,(derivation->output-path drv sub-drv)))))
((name (? derivation? drv)) ((name (? derivation? drv))
`(,name . ,(derivation->output-path drv))) (return `(,name . ,(derivation->output-path drv))))
((name (? derivation? drv) sub-drv) ((name (? derivation? drv) sub-drv)
`(,name . ,(derivation->output-path drv sub-drv))) (return `(,name . ,(derivation->output-path drv sub-drv))))
((input (and (? string?) (? store-path?) file)) ((input (and (? string?) (? store-path?) file))
`(,input . ,file)))) (return `(,input . ,file))))))
(expression->derivation-in-linux-vm (mlet %store-monad
store "qemu-image" ((graph (sequence %store-monad
`(let () (map input->name+derivation inputs-to-copy))))
(use-modules (ice-9 rdelim) (expression->derivation-in-linux-vm
(srfi srfi-1) "qemu-image"
(guix build utils) `(let ()
(guix build linux-initrd)) (use-modules (ice-9 rdelim)
(srfi srfi-1)
(guix build utils)
(guix build linux-initrd))
(let ((parted (string-append (assoc-ref %build-inputs "parted") (let ((parted (string-append (assoc-ref %build-inputs "parted")
"/sbin/parted")) "/sbin/parted"))
(mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
"/sbin/mkfs.ext3")) "/sbin/mkfs.ext3"))
(grub (string-append (assoc-ref %build-inputs "grub") (grub (string-append (assoc-ref %build-inputs "grub")
"/sbin/grub-install")) "/sbin/grub-install"))
(umount (string-append (assoc-ref %build-inputs "util-linux") (umount (string-append (assoc-ref %build-inputs "util-linux")
"/bin/umount")) ; XXX: add to Guile "/bin/umount")) ; XXX: add to Guile
(grub.cfg (assoc-ref %build-inputs "grub.cfg"))) (grub.cfg (assoc-ref %build-inputs "grub.cfg")))
(define (read-reference-graph port) (define (read-reference-graph port)
;; Return a list of store paths from the reference graph at PORT. ;; Return a list of store paths from the reference graph at PORT.
;; The data at PORT is the format produced by #:references-graphs. ;; The data at PORT is the format produced by #:references-graphs.
(let loop ((line (read-line port)) (let loop ((line (read-line port))
(result '())) (result '()))
(cond ((eof-object? line) (cond ((eof-object? line)
(delete-duplicates result)) (delete-duplicates result))
((string-prefix? "/" line) ((string-prefix? "/" line)
(loop (read-line port) (loop (read-line port)
(cons line result))) (cons line result)))
(else (else
(loop (read-line port) (loop (read-line port)
result))))) result)))))
(define (things-to-copy) (define (things-to-copy)
;; Return the list of store files to copy to the image. ;; Return the list of store files to copy to the image.
(define (graph-from-file file) (define (graph-from-file file)
(call-with-input-file file (call-with-input-file file
read-reference-graph)) read-reference-graph))
,(match inputs-to-copy ,(match inputs-to-copy
(((graph-files . _) ...) (((graph-files . _) ...)
`(let* ((graph-files ',(map (cut string-append "/xchg/" <>) `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
graph-files)) graph-files))
(paths (append-map graph-from-file graph-files))) (paths (append-map graph-from-file graph-files)))
(delete-duplicates paths))) (delete-duplicates paths)))
(#f ''()))) (#f ''())))
;; GRUB is full of shell scripts. ;; GRUB is full of shell scripts.
(setenv "PATH" (setenv "PATH"
(string-append (dirname grub) ":" (string-append (dirname grub) ":"
(assoc-ref %build-inputs "coreutils") "/bin:" (assoc-ref %build-inputs "coreutils") "/bin:"
(assoc-ref %build-inputs "findutils") "/bin:" (assoc-ref %build-inputs "findutils") "/bin:"
(assoc-ref %build-inputs "sed") "/bin:" (assoc-ref %build-inputs "sed") "/bin:"
(assoc-ref %build-inputs "grep") "/bin:" (assoc-ref %build-inputs "grep") "/bin:"
(assoc-ref %build-inputs "gawk") "/bin")) (assoc-ref %build-inputs "gawk") "/bin"))
(display "creating partition table...\n") (display "creating partition table...\n")
(and (zero? (system* parted "/dev/vda" "mklabel" "msdos" (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
"mkpart" "primary" "ext2" "1MiB" "mkpart" "primary" "ext2" "1MiB"
,(format #f "~aB" ,(format #f "~aB"
(- disk-image-size (- disk-image-size
(* 5 (expt 2 20)))))) (* 5 (expt 2 20))))))
(begin (begin
(display "creating ext3 partition...\n") (display "creating ext3 partition...\n")
(and (zero? (system* mkfs "-F" "/dev/vda1")) (and (zero? (system* mkfs "-F" "/dev/vda1"))
(let ((store (string-append "/fs" ,%store-directory))) (let ((store (string-append "/fs" ,%store-directory)))
(display "mounting partition...\n") (display "mounting partition...\n")
(mkdir "/fs") (mkdir "/fs")
(mount "/dev/vda1" "/fs" "ext3") (mount "/dev/vda1" "/fs" "ext3")
(mkdir-p "/fs/boot/grub") (mkdir-p "/fs/boot/grub")
(symlink grub.cfg "/fs/boot/grub/grub.cfg") (symlink grub.cfg "/fs/boot/grub/grub.cfg")
;; Populate the image's store. ;; Populate the image's store.
(mkdir-p store) (mkdir-p store)
(chmod store #o1775) (chmod store #o1775)
(for-each (lambda (thing) (for-each (lambda (thing)
(copy-recursively thing (copy-recursively thing
(string-append "/fs" (string-append "/fs"
thing))) thing)))
(cons grub.cfg (things-to-copy))) (cons grub.cfg (things-to-copy)))
;; Populate /dev. ;; Populate /dev.
(make-essential-device-nodes #:root "/fs") (make-essential-device-nodes #:root "/fs")
;; Optionally, register the inputs in the image's store. ;; Optionally, register the inputs in the image's store.
(let* ((guix (assoc-ref %build-inputs "guix")) (let* ((guix (assoc-ref %build-inputs "guix"))
(register (string-append guix (register (string-append guix
"/sbin/guix-register"))) "/sbin/guix-register")))
,@(if initialize-store? ,@(if initialize-store?
(match inputs-to-copy (match inputs-to-copy
(((graph-files . _) ...) (((graph-files . _) ...)
(map (lambda (closure) (map (lambda (closure)
`(system* register "--prefix" "/fs" `(system* register "--prefix" "/fs"
,(string-append "/xchg/" ,(string-append "/xchg/"
closure))) closure)))
graph-files))) graph-files)))
'(#f))) '(#f)))
;; Evaluate the POPULATE directives. ;; Evaluate the POPULATE directives.
,@(let loop ((directives populate) ,@(let loop ((directives populate)
(statements '())) (statements '()))
(match directives (match directives
(() (()
(reverse statements)) (reverse statements))
((('directory name) rest ...) ((('directory name) rest ...)
(loop rest (loop rest
(cons `(mkdir-p ,(string-append "/fs" name)) (cons `(mkdir-p ,(string-append "/fs" name))
statements))) statements)))
((('directory name uid gid) rest ...) ((('directory name uid gid) rest ...)
(let ((dir (string-append "/fs" name))) (let ((dir (string-append "/fs" name)))
(loop rest (loop rest
(cons* `(chown ,dir ,uid ,gid) (cons* `(chown ,dir ,uid ,gid)
`(mkdir-p ,dir) `(mkdir-p ,dir)
statements)))) statements))))
(((new '-> old) rest ...) (((new '-> old) rest ...)
(loop rest (loop rest
(cons `(symlink ,old (cons `(symlink ,old
,(string-append "/fs" new)) ,(string-append "/fs" new))
statements))))) statements)))))
(and=> (assoc-ref %build-inputs "populate") (and=> (assoc-ref %build-inputs "populate")
(lambda (populate) (lambda (populate)
(chdir "/fs") (chdir "/fs")
(primitive-load populate) (primitive-load populate)
(chdir "/"))) (chdir "/")))
(display "clearing file timestamps...\n") (display "clearing file timestamps...\n")
(for-each (lambda (file) (for-each (lambda (file)
(let ((s (lstat file))) (let ((s (lstat file)))
;; XXX: Guile uses libc's 'utime' function ;; XXX: Guile uses libc's 'utime' function
;; (not 'futime'), so the timestamp of ;; (not 'futime'), so the timestamp of
;; symlinks cannot be changed, and there ;; symlinks cannot be changed, and there
;; are symlinks here pointing to ;; are symlinks here pointing to
;; /nix/store, which is the host, ;; /nix/store, which is the host,
;; read-only store. ;; read-only store.
(unless (eq? (stat:type s) 'symlink) (unless (eq? (stat:type s) 'symlink)
(utime file 0 0 0 0)))) (utime file 0 0 0 0))))
(find-files "/fs" ".*")) (find-files "/fs" ".*"))
(and (zero? (and (zero?
(system* grub "--no-floppy" (system* grub "--no-floppy"
"--boot-directory" "/fs/boot" "--boot-directory" "/fs/boot"
"/dev/vda")) "/dev/vda"))
(zero? (system* umount "/fs")) (zero? (system* umount "/fs"))
(reboot)))))))) (reboot))))))))
#:system system #:system system
#:inputs `(("parted" ,parted) #:inputs `(("parted" ,parted)
("grub" ,grub) ("grub" ,grub)
("e2fsprogs" ,e2fsprogs) ("e2fsprogs" ,e2fsprogs)
("grub.cfg" ,grub-configuration) ("grub.cfg" ,grub-configuration)
;; For shell scripts. ;; For shell scripts.
("sed" ,(car (assoc-ref %final-inputs "sed"))) ("sed" ,(car (assoc-ref %final-inputs "sed")))
("grep" ,(car (assoc-ref %final-inputs "grep"))) ("grep" ,(car (assoc-ref %final-inputs "grep")))
("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
("findutils" ,(car (assoc-ref %final-inputs "findutils"))) ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
("gawk" ,(car (assoc-ref %final-inputs "gawk"))) ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
("util-linux" ,util-linux) ("util-linux" ,util-linux)
,@(if initialize-store? ,@(if initialize-store?
`(("guix" ,guix)) `(("guix" ,guix))
'()) '())
,@inputs-to-copy) ,@inputs-to-copy)
#:make-disk-image? #t #:make-disk-image? #t
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
#:references-graphs (map input->name+derivation inputs-to-copy) #:references-graphs graph
#:modules '((guix build utils) #:modules '((guix build utils)
(guix build linux-initrd)))) (guix build linux-initrd)))))
;;; ;;;
;;; Stand-alone VM image. ;;; Stand-alone VM image.
;;; ;;;
(define* (union store inputs (define* (union inputs
#:key (guile (%guile-for-build)) (system (%current-system)) #:key (guile (%guile-for-build)) (system (%current-system))
(name "union")) (name "union"))
"Return a derivation that builds the union of INPUTS. INPUTS is a list of "Return a derivation that builds the union of INPUTS. INPUTS is a list of
input tuples." input tuples."
(define builder (define builder
`(begin '(begin
(use-modules (guix build union)) (use-modules (guix build union))
(setvbuf (current-output-port) _IOLBF) (setvbuf (current-output-port) _IOLBF)
@ -423,132 +436,124 @@ input tuples."
output (length inputs)) output (length inputs))
(union-build output inputs)))) (union-build output inputs))))
(build-expression->derivation store name system builder (mlet %store-monad
(map (match-lambda ((inputs (sequence %store-monad
((name (? package? p)) (map (match-lambda
`(,name ,(package-derivation store p ((name (? package? p))
system))) (mlet %store-monad
((name (? package? p) output) ((drv (package->derivation p system)))
`(,name ,(package-derivation store p (return `(,name ,drv))))
system) ((name (? package? p) output)
,output)) (mlet %store-monad
(x x)) ((drv (package->derivation p system)))
inputs) (return `(,name ,drv ,output))))
#:modules '((guix build union)) (x
#:guile-for-build guile)) (return x)))
inputs))))
(derivation-expression name system builder
inputs
#:modules '((guix build union))
#:guile-for-build guile)))
(define (system-qemu-image store) (define (system-qemu-image)
"Return the derivation of a QEMU image of the GNU system." "Return the derivation of a QEMU image of the GNU system."
(define motd (define build-user-gid 30000)
(add-text-to-store store "motd" "
(mlet* %store-monad
((motd (text-file "motd" "
Happy birthday, GNU! http://www.gnu.org/gnu30 Happy birthday, GNU! http://www.gnu.org/gnu30
")) "))
(define %pam-services (%pam-services ->
;; Services known to PAM. ;; Services known to PAM.
(list %pam-other-services (list %pam-other-services
(unix-pam-service "login" (unix-pam-service "login"
#:allow-empty-passwords? #t #:allow-empty-passwords? #t
#:motd motd))) #:motd motd)))
(define %dmd-services (services (listm %store-monad
;; Services run by dmd. (host-name-service "gnu")
(list (host-name-service store "gnu") (mingetty-service "tty1")
(mingetty-service store "tty1") (mingetty-service "tty2")
(mingetty-service store "tty2") (mingetty-service "tty3")
(mingetty-service store "tty3") (mingetty-service "tty4")
(mingetty-service store "tty4") (mingetty-service "tty5")
(mingetty-service store "tty5") (mingetty-service "tty6")
(mingetty-service store "tty6") (syslog-service)
(syslog-service store) (guix-service)
(guix-service store) (nscd-service)
(nscd-service store)
;; QEMU networking settings. ;; QEMU networking settings.
(static-networking-service store "eth0" "10.0.2.10" (static-networking-service "eth0" "10.0.2.10"
#:gateway "10.0.2.2"))) #:gateway "10.0.2.2")))
(define build-user-gid 30000) (build-accounts (guix-build-accounts 10 #:gid build-user-gid))
(define build-accounts (resolv.conf
(guix-build-accounts store 10 #:gid build-user-gid)) ;; Name resolution for default QEMU settings.
(text-file "resolv.conf" "nameserver 10.0.2.3\n"))
(define resolv.conf (etc-services (package-file net-base "etc/services"))
;; Name resolution for default QEMU settings. (etc-protocols (package-file net-base "etc/protocols"))
(add-text-to-store store "resolv.conf" (etc-rpc (package-file net-base "etc/rpc"))
"nameserver 10.0.2.3\n"))
(define etc-services (bash-file (package-file bash "bin/bash"))
(string-append (package-output store net-base) "/etc/services")) (dmd-file (package-file dmd "bin/dmd"))
(define etc-protocols (dmd-conf (dmd-configuration-file services))
(string-append (package-output store net-base) "/etc/protocols")) (accounts -> (cons* (user-account
(define etc-rpc (name "root")
(string-append (package-output store net-base) "/etc/rpc")) (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))
(parameterize ((%guile-for-build (package-derivation store guile-final))) (packages -> `(("coreutils" ,coreutils)
(let* ((bash-drv (package-derivation store bash)) ("bash" ,bash)
(bash-file (string-append (derivation->output-path bash-drv) ("guile" ,guile-2.0)
"/bin/bash")) ("dmd" ,dmd)
(dmd-drv (package-derivation store dmd)) ("gcc" ,gcc-final)
(dmd-file (string-append (derivation->output-path dmd-drv) ("libc" ,glibc-final)
"/bin/dmd")) ("inetutils" ,inetutils)
(dmd-conf (dmd-configuration-file store %dmd-services)) ("findutils" ,findutils)
(accounts (cons* (user-account ("grep" ,grep)
(name "root") ("sed" ,sed)
(password "") ("procps" ,procps)
(uid 0) (gid 0) ("psmisc" ,psmisc)
(comment "System administrator") ("zile" ,zile)
(home-directory "/") ("guix" ,guix)))
(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) ;; TODO: Replace with a real profile with a manifest.
("bash" ,bash) ;; TODO: Generate bashrc from packages' search-paths.
("guile" ,guile-2.0) (profile-drv (union packages
("dmd" ,dmd) #:name "default-profile"))
("gcc" ,gcc-final) (profile -> (derivation->output-path profile-drv))
("libc" ,glibc-final) (bashrc (text-file "bashrc" (string-append "
("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 "
export PS1='\\u@\\h\\$ ' export PS1='\\u@\\h\\$ '
export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
export CPATH=$HOME/.guix-profile/include:" profile "/include export CPATH=$HOME/.guix-profile/include:" profile "/include
@ -557,7 +562,7 @@ alias ls='ls -p --color'
alias ll='ls -l' 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 is an alpha preview of the GNU system. Welcome.
This image features the GNU Guix package manager, which was used to 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. You can log in as 'guest' or 'root' with no password.
")) "))
(populate `((directory "/nix/store" 0 ,build-user-gid) (populate -> `((directory "/nix/store" 0 ,build-user-gid)
(directory "/etc") (directory "/etc")
(directory "/var/log") ; for dmd (directory "/var/log") ; for dmd
(directory "/var/run/nscd") (directory "/var/run/nscd")
("/etc/shadow" -> ,shadow) ("/etc/shadow" -> ,shadow)
("/etc/passwd" -> ,passwd) ("/etc/passwd" -> ,passwd)
("/etc/group" -> ,group) ("/etc/group" -> ,group)
("/etc/login.defs" -> "/dev/null") ("/etc/login.defs" -> "/dev/null")
("/etc/pam.d" -> ,pam.d) ("/etc/pam.d" -> ,pam.d)
("/etc/resolv.conf" -> ,resolv.conf) ("/etc/resolv.conf" -> ,resolv.conf)
("/etc/profile" -> ,bashrc) ("/etc/profile" -> ,bashrc)
("/etc/issue" -> ,issue) ("/etc/issue" -> ,issue)
("/etc/services" -> ,etc-services) ("/etc/services" -> ,etc-services)
("/etc/protocols" -> ,etc-protocols) ("/etc/protocols" -> ,etc-protocols)
("/etc/rpc" -> ,etc-rpc) ("/etc/rpc" -> ,etc-rpc)
(directory "/var/nix/gcroots") (directory "/var/nix/gcroots")
("/var/nix/gcroots/default-profile" -> ,profile) ("/var/nix/gcroots/default-profile" -> ,profile)
(directory "/tmp") (directory "/tmp")
(directory "/var/nix/profiles/per-user/root" 0 0) (directory "/var/nix/profiles/per-user/root" 0 0)
(directory "/var/nix/profiles/per-user/guest" (directory "/var/nix/profiles/per-user/guest"
1000 100) 1000 100)
(directory "/home/guest" 1000 100))) (directory "/home/guest" 1000 100)))
(out (derivation->output-path (boot (text-file "boot" (object->string
(package-derivation store mingetty))) `(execl ,dmd-file "dmd"
(boot (add-text-to-store store "boot" "--config" ,dmd-conf))))
(object->string (entries -> (list (return (menu-entry
`(execl ,dmd-file "dmd" (label (string-append
"--config" ,dmd-conf)))) "GNU system with Linux-Libre "
(entries (list (menu-entry (package-version linux-libre)
(label (string-append " (technology preview)"))
"GNU System with Linux-Libre " (linux linux-libre)
(package-version linux-libre) (linux-arguments `("--root=/dev/vda1"
" (technology preview)")) ,(string-append "--load=" boot)))
(linux linux-libre) (initrd gnu-system-initrd)))))
(linux-arguments `("--root=/dev/vda1" (grub.cfg (grub-configuration-file entries)))
,(string-append "--load=" boot))) (qemu-image #:grub-configuration grub.cfg
(initrd gnu-system-initrd)))) #:populate populate
(grub.cfg (grub-configuration-file store entries))) #:disk-image-size (* 550 (expt 2 20))
(qemu-image store #:initialize-store? #t
#:grub-configuration grub.cfg #:inputs-to-copy `(("boot" ,boot)
#:populate populate ("linux" ,linux-libre)
#:disk-image-size (* 550 (expt 2 20)) ("initrd" ,gnu-system-initrd)
#:initialize-store? #t ("pam.d" ,pam.d-drv)
#:inputs-to-copy `(("boot" ,boot) ("profile" ,profile-drv)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
("pam.d" ,pam.d-drv)
("profile" ,profile-drv)
;; Configuration. ;; Configuration.
("dmd.conf" ,dmd-conf) ("dmd.conf" ,dmd-conf)
("etc-pam.d" ,pam.d-drv) ("etc-pam.d" ,pam.d-drv)
("etc-passwd" ,passwd) ("etc-passwd" ,passwd)
("etc-shadow" ,shadow) ("etc-shadow" ,shadow)
("etc-group" ,group) ("etc-group" ,group)
("etc-resolv.conf" ,resolv.conf) ("etc-resolv.conf" ,resolv.conf)
("etc-bashrc" ,bashrc) ("etc-bashrc" ,bashrc)
("etc-issue" ,issue) ("etc-issue" ,issue)
("etc-motd" ,motd) ("etc-motd" ,motd)
("net-base" ,net-base) ("net-base" ,net-base)
,@(append-map service-inputs ,@(append-map service-inputs
%dmd-services)))))) services)))))
;;; vm.scm ends here ;;; vm.scm ends here