me/guix
Archived
1
0
Fork 0
Code Activity

gnu: vm: Rewrite helper functions as monadic functions.

Browse source 
* 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.
This commit is contained in:
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

68
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,19 +70,19 @@
(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
(return (service
(provision '(host-name)) (provision '(host-name))
(start `(lambda _ (start `(lambda _
(sethostname ,name))) (sethostname ,name)))
(respawn? #f))) (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))))
@ -90,13 +91,12 @@
(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"))
@ -108,14 +108,13 @@
#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.
(add-text-to-store store "syslog.conf" " (define contents "
# 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")))
(return
(service (service
(provision '(syslogd)) (provision '(syslogd))
(start `(make-forkexec-constructor ,syslogd (start `(make-forkexec-constructor ,syslogd
"--rcfile" ,syslog.conf)) "--rcfile" ,syslog.conf))
(inputs `(("inetutils" ,inetutils) (inputs `(("inetutils" ,inetutils)
("syslog.conf" ,syslog.conf)))))) ("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")))
(service
(provision '(guix-daemon)) (provision '(guix-daemon))
(start `(make-forkexec-constructor ,daemon (start `(make-forkexec-constructor ,daemon
"--build-users-group" "--build-users-group"
,builder-group)) ,builder-group))
(inputs `(("guix" ,guix)))))) (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,10 +167,9 @@ 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 _
@ -190,10 +187,10 @@ true, it must be a string specifying the default network gateway."
(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

47
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
(define (bzImage)
(anym %store-monad
(match-lambda
(($ <menu-entry> _ linux) (($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system)) (package-file linux "bzImage"
(out (derivation->output-path drv))) #:system system)))
(string-append out "/bzImage")))) entries))
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

20
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,18 +115,17 @@ 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))
@ -136,6 +136,6 @@ starting at FIRST-UID, and under GID."
(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

239
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
(with-monad %store-monad
(map (match-lambda (map (match-lambda
((input (? package? package)) ((input (? package? package))
`(,input . ,(package-output store package "out" system))) (mlet %store-monad ((out (package-file package #:system system)))
(return `(,input . ,out))))
((input (? package? package) sub-drv) ((input (? package? package) sub-drv)
`(,input . ,(package-output store package sub-drv system))) (mlet %store-monad ((out (package-file package
#:output sub-drv
#:system system)))
(return `(,input . ,out))))
((input (? derivation? drv)) ((input (? derivation? drv))
`(,input . ,(derivation->output-path drv))) (return `(,input . ,(derivation->output-path drv))))
((input (? derivation? drv) sub-drv) ((input (? derivation? drv) sub-drv)
`(,input . ,(derivation->output-path drv sub-drv))) (return `(,input . ,(derivation->output-path drv sub-drv))))
((input (and (? string?) (? store-path?) file)) ((input (and (? string?) (? store-path?) file))
`(,input . ,file))) (return `(,input . ,file))))
inputs)) inputs)))
(define exp*
;; EXP, but with INPUTS available.
`(let ((%build-inputs ',input-alist))
,exp))
(define builder (define builder
;; Code that launches the VM that evaluates EXP. ;; Code that launches the VM that evaluates EXP.
@ -167,26 +168,35 @@ 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*) (define (lower-inputs inputs)
'())) ;; Turn any package in INPUTS into a derivation.
(->drv (cut package-derivation store <> system)) (with-monad %store-monad
(coreutils (car (assoc-ref %final-inputs "coreutils")))) (sequence %store-monad
(build-expression->derivation store name system builder (map (match-lambda
`(("qemu" ,(->drv qemu)) ((name (? package? package) sub-drv ...)
("linux" ,(->drv linux)) (mlet %store-monad ((drv (package->derivation package)))
("initrd" ,(->drv initrd)) (return `(,name ,drv ,@sub-drv))))
("coreutils" ,(->drv coreutils))
("builder" ,user-builder)
,@(map (match-lambda
((name (? package? package)
sub-drv ...)
`(,name ,(->drv package)
,@sub-drv))
((name (? string? file)) ((name (? string? file))
`(,name ,file)) (return `(,name ,file)))
(tuple tuple)) (tuple
inputs)) (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 #:env-vars env-vars
#:modules (delete-duplicates #:modules (delete-duplicates
`((guix build utils) `((guix build utils)
@ -194,7 +204,7 @@ made available under the /xchg CIFS share."
#:guile-for-build guile-for-build #:guile-for-build guile-for-build
#:references-graphs references-graphs))) #:references-graphs references-graphs)))
(define* (qemu-image store #:key (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,24 +225,27 @@ 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
(match tuple
((name (? package? package)) ((name (? package? package))
`(,name . ,(derivation->output-path (mlet %store-monad ((drv (package->derivation package system)))
(package-derivation store package system)))) (return `(,name . ,(derivation->output-path drv)))))
((name (? package? package) sub-drv) ((name (? package? package) sub-drv)
`(,name . ,(derivation->output-path (mlet %store-monad ((drv (package->derivation package system)))
(package-derivation store package system) (return `(,name . ,(derivation->output-path drv sub-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))))))
(mlet %store-monad
((graph (sequence %store-monad
(map input->name+derivation inputs-to-copy))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
store "qemu-image" "qemu-image"
`(let () `(let ()
(use-modules (ice-9 rdelim) (use-modules (ice-9 rdelim)
(srfi srfi-1) (srfi srfi-1)
@ -396,22 +409,22 @@ such as /etc files."
,@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,78 +436,72 @@ 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
((inputs (sequence %store-monad
(map (match-lambda (map (match-lambda
((name (? package? p)) ((name (? package? p))
`(,name ,(package-derivation store p (mlet %store-monad
system))) ((drv (package->derivation p system)))
(return `(,name ,drv))))
((name (? package? p) output) ((name (? package? p) output)
`(,name ,(package-derivation store p (mlet %store-monad
system) ((drv (package->derivation p system)))
,output)) (return `(,name ,drv ,output))))
(x x)) (x
inputs) (return x)))
inputs))))
(derivation-expression name system builder
inputs
#:modules '((guix build union)) #:modules '((guix build union))
#:guile-for-build guile)) #: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))
(define resolv.conf
;; Name resolution for default QEMU settings. ;; Name resolution for default QEMU settings.
(add-text-to-store store "resolv.conf" (text-file "resolv.conf" "nameserver 10.0.2.3\n"))
"nameserver 10.0.2.3\n"))
(define etc-services (etc-services (package-file net-base "etc/services"))
(string-append (package-output store net-base) "/etc/services")) (etc-protocols (package-file net-base "etc/protocols"))
(define etc-protocols (etc-rpc (package-file net-base "etc/rpc"))
(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))) (bash-file (package-file bash "bin/bash"))
(let* ((bash-drv (package-derivation store bash)) (dmd-file (package-file dmd "bin/dmd"))
(bash-file (string-append (derivation->output-path bash-drv) (dmd-conf (dmd-configuration-file services))
"/bin/bash")) (accounts -> (cons* (user-account
(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") (name "root")
(password "") (password "")
(uid 0) (gid 0) (uid 0) (gid 0)
@ -509,10 +516,9 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
(home-directory "/home/guest") (home-directory "/home/guest")
(shell bash-file)) (shell bash-file))
build-accounts)) build-accounts))
(passwd (passwd-file store accounts)) (passwd (passwd-file accounts))
(shadow (passwd-file store accounts #:shadow? #t)) (shadow (passwd-file accounts #:shadow? #t))
(group (group-file store (group (group-file (list (user-group
(list (user-group
(name "root") (name "root")
(id 0)) (id 0))
(user-group (user-group
@ -524,10 +530,10 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
(id build-user-gid) (id build-user-gid)
(members (map user-account-name (members (map user-account-name
build-accounts)))))) build-accounts))))))
(pam.d-drv (pam-services->directory store %pam-services)) (pam.d-drv (pam-services->directory %pam-services))
(pam.d (derivation->output-path pam.d-drv)) (pam.d -> (derivation->output-path pam.d-drv))
(packages `(("coreutils" ,coreutils) (packages -> `(("coreutils" ,coreutils)
("bash" ,bash) ("bash" ,bash)
("guile" ,guile-2.0) ("guile" ,guile-2.0)
("dmd" ,dmd) ("dmd" ,dmd)
@ -544,11 +550,10 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
;; TODO: Replace with a real profile with a manifest. ;; TODO: Replace with a real profile with a manifest.
;; TODO: Generate bashrc from packages' search-paths. ;; TODO: Generate bashrc from packages' search-paths.
(profile-drv (union store packages (profile-drv (union packages
#:name "default-profile")) #:name "default-profile"))
(profile (derivation->output-path profile-drv)) (profile -> (derivation->output-path profile-drv))
(bashrc (add-text-to-store store "bashrc" (bashrc (text-file "bashrc" (string-append "
(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,7 +572,7 @@ 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")
@ -589,24 +594,20 @@ You can log in as 'guest' or 'root' with no password.
(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)))
(boot (add-text-to-store store "boot"
(object->string
`(execl ,dmd-file "dmd" `(execl ,dmd-file "dmd"
"--config" ,dmd-conf)))) "--config" ,dmd-conf))))
(entries (list (menu-entry (entries -> (list (return (menu-entry
(label (string-append (label (string-append
"GNU System with Linux-Libre " "GNU system with Linux-Libre "
(package-version linux-libre) (package-version linux-libre)
" (technology preview)")) " (technology preview)"))
(linux linux-libre) (linux linux-libre)
(linux-arguments `("--root=/dev/vda1" (linux-arguments `("--root=/dev/vda1"
,(string-append "--load=" boot))) ,(string-append "--load=" boot)))
(initrd gnu-system-initrd)))) (initrd gnu-system-initrd)))))
(grub.cfg (grub-configuration-file store entries))) (grub.cfg (grub-configuration-file entries)))
(qemu-image store (qemu-image #:grub-configuration grub.cfg
#:grub-configuration grub.cfg
#:populate populate #:populate populate
#:disk-image-size (* 550 (expt 2 20)) #:disk-image-size (* 550 (expt 2 20))
#:initialize-store? #t #:initialize-store? #t
@ -628,6 +629,6 @@ You can log in as 'guest' or 'root' with no password.
("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