aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-09-26 00:20:11 +0200
committerLudovic Courtès <ludo@gnu.org>2013-09-26 00:20:11 +0200
commit7facbf2b58f80afffedbb9230ec7ab9b61232dfe (patch)
tree7ab3870f77f596e548ccd0e50f5ea16d1c32f434 /gnu
parent1fa49a2c4636c0f35972c16f6bd2d28a4424b821 (diff)
parent834b5c80763eba42018606a674bcc53bfeca10eb (diff)
downloadguix-7facbf2b58f80afffedbb9230ec7ab9b61232dfe.tar.gz
guix-7facbf2b58f80afffedbb9230ec7ab9b61232dfe.zip
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu')
-rw-r--r--gnu/packages/fontutils.scm10
-rw-r--r--gnu/packages/gnupg.scm16
-rw-r--r--gnu/packages/mail.scm5
-rw-r--r--gnu/packages/maths.scm4
-rw-r--r--gnu/packages/package-management.scm22
-rw-r--r--gnu/packages/scheme.scm20
-rw-r--r--gnu/packages/xorg.scm46
-rw-r--r--gnu/packages/zile.scm34
-rw-r--r--gnu/system/dmd.scm67
-rw-r--r--gnu/system/linux.scm13
-rw-r--r--gnu/system/vm.scm202
11 files changed, 363 insertions, 76 deletions
diff --git a/gnu/packages/fontutils.scm b/gnu/packages/fontutils.scm
index 8b5e9c582a..ac0dbdf9d5 100644
--- a/gnu/packages/fontutils.scm
+++ b/gnu/packages/fontutils.scm
@@ -19,6 +19,7 @@
(define-module (gnu packages fontutils)
#:use-module (gnu packages)
#:use-module (gnu packages compression)
+ #:use-module (gnu packages ghostscript)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages xml)
#:use-module ((guix licenses) #:renamer (symbol-prefix-proc 'license:))
@@ -75,11 +76,16 @@ anti-aliased glyph bitmap generation with 256 gray levels.")
(build-system gnu-build-system)
(inputs `(("expat" ,expat)
("freetype" ,freetype)
+ ("gs-fonts" ,gs-fonts)
("pkg-config" ,pkg-config)))
(arguments
`(#:configure-flags
- ;; point to user profile instead of /usr/share/fonts in /etc/fonts.conf
- `("--with-default-fonts=~/.guix-profile/share/fonts")))
+ ;; point to user profile instead of /usr/share/fonts in /etc/fonts.conf
+ (list "--with-default-fonts=~/.guix-profile/share/fonts"
+ ;; register gs-fonts
+ (string-append "--with-add-fonts="
+ (assoc-ref %build-inputs "gs-fonts")
+ "/share/fonts"))))
(synopsis "Fontconfig, a library for configuring and customising font access.")
(description
"Fontconfig can discover new fonts when installed automatically;
diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index 7c0f50900a..c098db3315 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -57,14 +57,14 @@ Daemon and possibly more in the future.")
(define-public libgcrypt
(package
(name "libgcrypt")
- (version "1.5.2")
+ (version "1.5.3")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnupg/libgcrypt/libgcrypt-"
version ".tar.bz2"))
(sha256
(base32
- "0gwnzqd64cpwdmk93nll54nidsr74jpimxzj4p4z7502ylwl66p4"))))
+ "1lar8y3lh61zl5flljpz540d78g99h4d5idfwrfw8lm3gm737xdw"))))
(build-system gnu-build-system)
(propagated-inputs
`(("libgpg-error" ,libgpg-error)))
@@ -106,7 +106,7 @@ provided.")
(define-public libksba
(package
(name "libksba")
- (version "1.2.0")
+ (version "1.3.0")
(source
(origin
(method url-fetch)
@@ -115,7 +115,7 @@ provided.")
version ".tar.bz2"))
(sha256
(base32
- "0jwk7hm3x3g4hd7l12z3d79dy7359x7lc88dq6z7q0ixn1jwxbq9"))))
+ "0w8rfb6yhcwkwzvjafrashcygy4hd9xwwmvlnkfd1m2h0paywqas"))))
(build-system gnu-build-system)
(propagated-inputs
`(("libgpg-error" ,libgpg-error)))
@@ -131,7 +131,7 @@ specifications are building blocks of S/MIME and TLS.")
(define-public gnupg
(package
(name "gnupg")
- (version "2.0.20")
+ (version "2.0.21")
(source
(origin
(method url-fetch)
@@ -139,12 +139,10 @@ specifications are building blocks of S/MIME and TLS.")
".tar.bz2"))
(sha256
(base32
- "16mp0j5inrcqcb3fxbn0b3aamascy3n923wiy0y8marc0rzrp53f"))))
+ "1xgf1q1phdawk6y66haaqcvfnlsqk12jmjin1m2d5x6fqw18kpq0"))))
(build-system gnu-build-system)
(inputs
- `(;; TODO: Add missing optional dep libusb.
-;; ("libusb" ,libusb)
- ("bzip2" ,guix:bzip2)
+ `(("bzip2" ,guix:bzip2)
("curl" ,curl)
("libassuan" ,libassuan)
("libgcrypt" ,libgcrypt)
diff --git a/gnu/packages/mail.scm b/gnu/packages/mail.scm
index b8ddcd71e1..a6236e7698 100644
--- a/gnu/packages/mail.scm
+++ b/gnu/packages/mail.scm
@@ -19,6 +19,7 @@
(define-module (gnu packages mail)
#:use-module (gnu packages)
#:use-module (gnu packages autotools)
+ #:use-module (gnu packages cyrus-sasl)
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages gdbm)
#:use-module (gnu packages gnutls)
@@ -154,7 +155,8 @@ aliasing facilities to work just as they would on normal mail.")
"1864cwz240gh0zy56fb47qqzwyf6ghg01037rb4p2kqgimpg6h91"))))
(build-system gnu-build-system)
(inputs
- `(("ncurses" ,ncurses)
+ `(("cyrus-sasl" ,cyrus-sasl)
+ ("ncurses" ,ncurses)
("openssl" ,openssl)
("perl" ,perl)))
(arguments
@@ -162,6 +164,7 @@ aliasing facilities to work just as they would on normal mail.")
"--enable-imap"
"--enable-pop"
"--with-ssl"
+ "--with-sasl"
;; so that mutt does not check whether the path
;; exists, which it does not in the chroot
"--with-mailpath=/var/mail")))
diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm
index 75354122b5..c72d6074ab 100644
--- a/gnu/packages/maths.scm
+++ b/gnu/packages/maths.scm
@@ -108,7 +108,7 @@ extensive test suite.")
(define-public pspp
(package
(name "pspp")
- (version "0.8.0a")
+ (version "0.8.1")
(source
(origin
(method url-fetch)
@@ -116,7 +116,7 @@ extensive test suite.")
version ".tar.gz"))
(sha256
(base32
- "1pgkb3z8b4wk4gymnafclhkrqq7n05wq83mra3v53jdl6bnllmyq"))))
+ "0qhxsdbwxd3cn1shc13wxvx2lg32lp4z6sz24kv3jz7p5xfi8j7x"))))
(build-system gnu-build-system)
(inputs
`(("gettext" ,gnu:gettext)
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index e4eb082230..ccd15cef6f 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -22,7 +22,7 @@
#:use-module (guix build-system gnu)
#:use-module ((guix licenses) #:select (gpl3+))
#:use-module (gnu packages guile)
- #:use-module ((gnu packages compression) #:select (bzip2))
+ #:use-module ((gnu packages compression) #:select (bzip2 gzip))
#:use-module (gnu packages gnupg)
#:use-module (gnu packages sqlite)
#:use-module (gnu packages pkg-config))
@@ -41,6 +41,7 @@
(build-system gnu-build-system)
(arguments
`(#:configure-flags (list
+ "--localstatedir=/var"
(string-append "--with-libgcrypt-prefix="
(assoc-ref %build-inputs
"libgcrypt")))
@@ -70,6 +71,8 @@
"/20130105/guile-2.0.7.tar.xz"))
(sha256 hash)))))
`(("bzip2" ,bzip2)
+ ("gzip" ,gzip)
+
("sqlite" ,sqlite)
("libgcrypt" ,libgcrypt)
("guile" ,guile-2.0)
@@ -100,3 +103,20 @@ A user-land free software distribution for GNU/Linux comes as part of Guix.
Guix is based on the Nix package manager.")
(license gpl3+)))
+
+(define-public guix-0.4
+ ;; XXX: Hack to allow the use of a 0.4ish tarball. This assumes that you
+ ;; have run 'make dist' in your build tree. Remove when 0.4 is out.
+ (let* ((builddir (dirname
+ (canonicalize-path
+ (dirname (search-path %load-path
+ "guix/config.scm")))))
+ (tarball (string-append builddir "/guix-0.4.tar.gz")))
+ (package (inherit guix)
+ (version "0.4rc")
+ (source (if (file-exists? tarball)
+ tarball
+ (begin
+ (format (current-error-port)
+ "warning: 'guix-0.4.tar.gz' not found~%")
+ (package-source guix)))))))
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 43853fa08c..b7df902136 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -32,6 +32,7 @@
#:use-module (gnu packages avahi)
#:use-module (gnu packages libphidget)
#:use-module (gnu packages glib)
+ #:use-module (gnu packages gtk)
#:use-module (gnu packages libffi)
#:use-module (gnu packages libjpeg)
#:use-module ((gnu packages gtk) #:select (cairo pango))
@@ -358,12 +359,15 @@ implementation techniques and as an expository tool.")
'(#:phases
(let* ((gui-libs
(lambda (inputs)
- ;; FIXME: Add GTK+ and GDK for DrRacket.
- (let ((glib (string-append (assoc-ref inputs "glib") "/lib"))
- (cairo (string-append (assoc-ref inputs "cairo") "/lib"))
- (pango (string-append (assoc-ref inputs "pango") "/lib"))
- (libjpeg (string-append (assoc-ref inputs "libjpeg") "/lib")))
- (list glib cairo pango libjpeg)))))
+ (define (lib input)
+ (string-append (assoc-ref inputs input) "/lib"))
+
+ (list (lib "glib")
+ (lib "cairo")
+ (lib "pango")
+ (lib "libjpeg")
+ (lib "gtk")
+ (lib "gdk-pixbuf")))))
(alist-cons-before
'configure 'pre-configure
(lambda* (#:key inputs #:allow-other-keys)
@@ -397,7 +401,9 @@ implementation techniques and as an expository tool.")
("glib" ,glib) ; for DrRacket
("cairo" ,cairo)
("pango" ,pango)
- ("libjpeg" ,libjpeg-8)))
+ ("libjpeg" ,libjpeg-8)
+ ("gdk-pixbuf" ,gdk-pixbuf)
+ ("gtk" ,gtk+)))
(home-page "http://racket-lang.org")
(synopsis "Implementation of Scheme and related languages")
(description
diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm
index 0659c8d10c..613e2c5f0e 100644
--- a/gnu/packages/xorg.scm
+++ b/gnu/packages/xorg.scm
@@ -29,11 +29,11 @@
#:use-module ((gnu packages gettext)
#:renamer (symbol-prefix-proc 'gnu:))
#:use-module (gnu packages glib)
+ #:use-module (gnu packages gnupg)
#:use-module (gnu packages gperf)
#:use-module (gnu packages libpng)
#:use-module (gnu packages linux)
#:use-module (gnu packages m4)
- #:use-module (gnu packages openssl)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
@@ -3114,9 +3114,9 @@ tracking.")
(license license:x11)))
-(define-public xkbcomp
+(define xkbcomp-intermediate ; used as input for xkeyboard-config
(package
- (name "xkbcomp")
+ (name "xkbcomp-intermediate")
(version "1.2.4")
(source
(origin
@@ -3139,6 +3139,18 @@ tracking.")
(description "X.org provides an implementation of the X Window System")
(license license:x11)))
+(define-public xkbcomp ; using xkeyboard-config as input
+ (package (inherit xkbcomp-intermediate)
+ (name "xkbcomp")
+ (inputs
+ `(,@(package-inputs xkbcomp-intermediate)
+ ("xkeyboard-config" ,xkeyboard-config)))
+ (arguments
+ `(#:configure-flags
+ (list (string-append "--with-xkb-config-root="
+ (assoc-ref %build-inputs "xkeyboard-config")
+ "/share/X11/xkb"))))))
+
(define-public xkbevd
(package
@@ -3212,7 +3224,7 @@ tracking.")
("intltool" ,intltool)
("libx11" ,libx11)
("pkg-config" ,pkg-config)
- ("xkbcomp" ,xkbcomp)))
+ ("xkbcomp-intermediate" ,xkbcomp-intermediate)))
(home-page "http://www.x.org/wiki/")
(synopsis "xorg implementation of the X Window System")
(description "X.org provides an implementation of the X Window System")
@@ -4262,6 +4274,7 @@ emulation to complete hardware acceleration for modern GPUs.")
("dbus" ,dbus)
("dmxproto" ,dmxproto)
("libdmx" ,libdmx)
+ ("libgcrypt" ,libgcrypt)
("libxau" ,libxau)
("libxaw" ,libxaw)
("libxdmcp" ,libxdmcp)
@@ -4273,7 +4286,6 @@ emulation to complete hardware acceleration for modern GPUs.")
("libxt" ,libxt)
("libxv" ,libxv)
("mesa" ,mesa)
- ("openssl" ,openssl)
("pkg-config" ,pkg-config)
("python" ,python-wrapper)
("recordproto" ,recordproto)
@@ -4284,10 +4296,30 @@ emulation to complete hardware acceleration for modern GPUs.")
("xf86dgaproto" ,xf86dgaproto)
("xf86driproto" ,xf86driproto)
("xf86vidmodeproto" ,xf86vidmodeproto)
-;; ("xkbutils" ,xkbutils)
-;; ("xkeyboard-config" ,xkeyboard-config)
+ ("xkbcomp" ,xkbcomp)
+ ("xkeyboard-config" ,xkeyboard-config)
("xtrans" ,xtrans)
("zlib" ,zlib)))
+ (arguments
+ `(#:configure-flags
+ (list (string-append "--with-xkb-path="
+ (assoc-ref %build-inputs "xkeyboard-config")
+ "/share/X11/xkb")
+ (string-append "--with-xkb-output="
+ "/tmp") ; FIXME: This is a bit doubtful; where should
+ ; the compiled keyboard maps go?
+ (string-append "--with-xkb-bin-directory="
+ (assoc-ref %build-inputs "xkbcomp")
+ "/bin"))
+ #:phases
+ (alist-replace
+ 'configure
+ (lambda* (#:key outputs #:allow-other-keys #:rest args)
+ (let ((configure (assoc-ref %standard-phases 'configure)))
+ (substitute* (find-files "." "\\.c$")
+ (("/bin/sh") (which "sh")))
+ (apply configure args)))
+ %standard-phases)))
(home-page "http://www.x.org/wiki/")
(synopsis "xorg implementation of the X Window System")
(description "X.org provides an implementation of the X Window System")
diff --git a/gnu/packages/zile.scm b/gnu/packages/zile.scm
index 6e540ccfab..4907031c89 100644
--- a/gnu/packages/zile.scm
+++ b/gnu/packages/zile.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,25 +24,37 @@
#:use-module (gnu packages bdw-gc)
#:use-module (gnu packages perl)
#:use-module (gnu packages help2man)
- #:use-module (gnu packages ncurses))
+ #:use-module (gnu packages ncurses)
+ #:use-module (gnu packages bash))
(define-public zile
(package
(name "zile")
(version "2.4.9")
- (source
- (origin
- (method url-fetch)
- (uri (string-append "mirror://gnu/zile/zile-"
- version ".tar.gz"))
- (sha256
- (base32
- "0j801c28ypm924rw3lqyb6khxyslg6ycrv16wmmwcam0mk3mj6f7"))))
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnu/zile/zile-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "0j801c28ypm924rw3lqyb6khxyslg6ycrv16wmmwcam0mk3mj6f7"))))
(build-system gnu-build-system)
+ (arguments
+ '(#:phases (alist-cons-before
+ 'configure 'patch-/bin/sh
+ (lambda* (#:key inputs #:allow-other-keys)
+ (let ((bash (assoc-ref inputs "bash")))
+ ;; Refer to the actual shell.
+ (substitute* '("lib/spawni.c" "src/funcs.c")
+ (("/bin/sh")
+ (string-append bash "/bin/sh")))))
+ %standard-phases)))
(inputs
`(("boehm-gc" ,libgc)
("ncurses" ,ncurses)
- ("perl" ,perl)
+ ("bash" ,bash)))
+ (native-inputs
+ `(("perl" ,perl)
("help2man" ,help2man)))
(home-page "http://www.gnu.org/software/zile/")
(synopsis "Zile is lossy Emacs, a lightweight Emacs clone")
diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 1e8767e357..b248d9f0c5 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -21,8 +21,12 @@
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
+ #:use-module ((gnu packages base)
+ #:select (glibc-final))
#:use-module ((gnu packages system)
#:select (mingetty inetutils))
+ #:use-module ((gnu packages package-management)
+ #:select (guix))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (service?
@@ -34,8 +38,13 @@
service-stop
service-inputs
+ host-name-service
syslog-service
mingetty-service
+ nscd-service
+ guix-service
+ static-networking-service
+
dmd-configuration-file))
;;; Commentary:
@@ -58,6 +67,14 @@
(inputs service-inputs ; list of inputs
(default '())))
+(define (host-name-service store 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)
"Return a service to run mingetty on TTY."
(let* ((mingetty-drv (package-derivation store mingetty))
@@ -65,9 +82,32 @@
"/sbin/mingetty")))
(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))
+
(start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
(inputs `(("mingetty" ,mingetty))))))
+(define* (nscd-service store
+ #: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)
"Return a service that runs 'syslogd' with reasonable default settings."
@@ -104,6 +144,33 @@
(inputs `(("inetutils" ,inetutils)
("syslog.conf" ,syslog.conf))))))
+(define* (guix-service store #:key (guix guix))
+ "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))
+ (inputs `(("guix" ,guix))))))
+
+(define* (static-networking-service store interface ip
+ #:key (inetutils inetutils))
+ "Return a service that starts INTERFACE with address IP."
+
+ ;; 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")))
+ (service
+ (provision '(networking))
+ (start `(make-forkexec-constructor ,ifconfig ,interface ,ip "up"))
+ (stop `(make-forkexec-constructor ,ifconfig ,interface "down"))
+ (respawn? #f)
+ (inputs `(("inetutils" ,inetutils))))))
+
+
(define (dmd-configuration-file store services)
"Return the dmd configuration file for SERVICES."
(define config
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index b2daa13e06..6aebe159ba 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -125,9 +125,10 @@
(let ((unix (pam-entry
(control "required")
(module "pam_unix.so"))))
- (lambda* (name #:key allow-empty-passwords?)
+ (lambda* (name #:key allow-empty-passwords? motd)
"Return a standard Unix-style PAM service for NAME. When
-ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
+ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords. When MOTD is true, it
+should be the name of a file used as the message-of-the-day."
;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
(let ((name* name))
(pam-service
@@ -140,6 +141,12 @@ ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
(arguments '("nullok")))
unix)))
(password (list unix))
- (session (list unix)))))))
+ (session (if motd
+ (list unix
+ (pam-entry
+ (control "optional")
+ (module "pam_motd.so")
+ (arguments (list (string-append "motd=" motd)))))
+ (list unix))))))))
;;; linux.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index df55f7c94e..0ed805510a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,8 @@
#:use-module (guix packages)
#:use-module ((gnu packages base) #:select (%final-inputs
guile-final
+ gcc-final
+ glibc-final
coreutils))
#:use-module (gnu packages guile)
#:use-module (gnu packages bash)
@@ -31,6 +33,7 @@
#:use-module (gnu packages grub)
#:use-module (gnu packages linux)
#:use-module (gnu packages linux-initrd)
+ #:use-module (gnu packages package-management)
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
#:use-module (gnu packages system)
@@ -91,6 +94,10 @@ made available under the /xchg CIFS share."
`(,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))
@@ -177,7 +184,8 @@ made available under the /xchg CIFS share."
`(,name ,(->drv package)
,@sub-drv))
((name (? string? file))
- `(,name ,file)))
+ `(,name ,file))
+ (tuple tuple))
inputs))
#:env-vars env-vars
#:modules (delete-duplicates
@@ -191,6 +199,7 @@ made available under the /xchg CIFS share."
(system (%current-system))
(disk-image-size (* 100 (expt 2 20)))
grub-configuration
+ (initialize-store? #f)
(populate #f)
(inputs '())
(inputs-to-copy '()))
@@ -199,11 +208,13 @@ disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
configuration file.
INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built.
+into the image being built. When INITIALIZE-STORE? is true, initialize the
+store database in the image so that Guix can be used in the image.
-When POPULATE is true, it must be the store file name of a Guile script to run
-in the disk image partition once it has been populated with INPUTS-TO-COPY.
-It can be used to provide additional files, such as /etc files."
+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))
@@ -213,6 +224,10 @@ It can be used to provide additional files, such as /etc files."
`(,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))))
@@ -298,6 +313,36 @@ It can be used to provide additional files, such as /etc files."
;; 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)))
+ (((new '-> old) rest ...)
+ (loop rest
+ (cons `(symlink ,old
+ ,(string-append "/fs" new))
+ statements)))))
+
(and=> (assoc-ref %build-inputs "populate")
(lambda (populate)
(chdir "/fs")
@@ -337,8 +382,8 @@ It can be used to provide additional files, such as /etc files."
("gawk" ,(car (assoc-ref %final-inputs "gawk")))
("util-linux" ,util-linux)
- ,@(if populate
- `(("populate" ,populate))
+ ,@(if initialize-store?
+ `(("guix" ,guix-0.4))
'())
,@inputs-to-copy)
@@ -353,19 +398,73 @@ It can be used to provide additional files, such as /etc files."
;;; Stand-alone VM image.
;;;
+(define* (union store 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
+ (use-modules (guix build union))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let ((output (assoc-ref %outputs "out"))
+ (inputs (map cdr %build-inputs)))
+ (format #t "building union `~a' with ~a packages...~%"
+ 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)
"Return the derivation of a QEMU image of the GNU system."
+ (define motd
+ (add-text-to-store store "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)))
+ (unix-pam-service "login"
+ #:allow-empty-passwords? #t
+ #:motd motd)))
(define %dmd-services
;; Services run by dmd.
- (list (mingetty-service store "tty1")
+ (list (host-name-service store "gnu")
+ (mingetty-service store "tty1")
(mingetty-service store "tty2")
(mingetty-service store "tty3")
- (syslog-service store)))
+ (mingetty-service store "tty4")
+ (mingetty-service store "tty5")
+ (mingetty-service store "tty6")
+ (syslog-service store)
+ (guix-service store #:guix guix-0.4)
+ (nscd-service store)
+
+ ;; QEMU networking settings.
+ (static-networking-service store "eth0" "10.0.2.10")))
+
+ (define resolv.conf
+ ;; Name resolution for default QEMU settings.
+ (add-text-to-store store "resolv.conf"
+ "nameserver 10.0.2.3\n"))
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash))
@@ -383,20 +482,53 @@ It can be used to provide additional files, such as /etc files."
"root:x:0:\n"))
(pam.d-drv (pam-services->directory store %pam-services))
(pam.d (derivation->output-path pam.d-drv))
- (populate
- (add-text-to-store store "populate-qemu-image"
- (object->string
- `(begin
- (mkdir-p "etc")
- (mkdir-p "var/log") ; for dmd
- (symlink ,shadow "etc/shadow")
- (symlink ,passwd "etc/passwd")
- (symlink ,group "etc/group")
- (symlink "/dev/null"
- "etc/login.defs")
- (symlink ,pam.d "etc/pam.d")
- (mkdir-p "var/run")))
- (list passwd)))
+
+ (packages `(("coreutils" ,coreutils)
+ ("bash" ,bash)
+ ("guile" ,guile-2.0)
+ ("dmd" ,dmd)
+ ("gcc" ,gcc-final)
+ ("libc" ,glibc-final)
+ ("inetutils" ,inetutils)
+ ("guix" ,guix-0.4)))
+
+ ;; 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 PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
+export CPATH=$HOME/.guix-profile/include:" profile "/include
+export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
+alias ls='ls -p --color'
+alias ll='ls -l'
+")))
+
+ (issue (add-text-to-store store "issue" "
+This is an alpha preview of the GNU system. Welcome.
+
+This image features the GNU Guix package manager, which was used to
+build it (http://www.gnu.org/software/guix/). The init system is
+GNU dmd (http://www.gnu.org/software/dmd/).
+
+You can log in as 'root' with no password.
+"))
+
+ (populate `((directory "/etc")
+ (directory "/var/log") ; for dmd
+ (directory "/var/run/nscd")
+ ("/etc/shadow" -> ,shadow)
+ ("/etc/passwd" -> ,passwd)
+ ("/etc/login.defs" -> "/dev/null")
+ ("/etc/pam.d" -> ,pam.d)
+ ("/etc/resolv.conf" -> ,resolv.conf)
+ ("/etc/profile" -> ,bashrc)
+ ("/etc/issue" -> ,issue)
+ (directory "/var/nix/gcroots")
+ ("/var/nix/gcroots/default-profile" -> ,profile)))
(out (derivation->output-path
(package-derivation store mingetty)))
(boot (add-text-to-store store "boot"
@@ -405,32 +537,36 @@ It can be used to provide additional files, such as /etc files."
"--config" ,dmd-conf))
(list out)))
(entries (list (menu-entry
- (label "Boot-to-Guile! (GNU System technology preview)")
+ (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)))
- (build-derivations store (list pam.d-drv))
(qemu-image store
#:grub-configuration grub.cfg
#:populate populate
- #:disk-image-size (* 400 (expt 2 20))
+ #:disk-image-size (* 500 (expt 2 20))
+ #:initialize-store? #t
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
- ("coreutils" ,coreutils)
- ("bash" ,bash)
- ("guile" ,guile-2.0)
- ("mingetty" ,mingetty)
- ("dmd" ,dmd)
+ ("pam.d" ,pam.d-drv)
+ ("profile" ,profile-drv)
;; Configuration.
("dmd.conf" ,dmd-conf)
- ("etc-pam.d" ,pam.d)
+ ("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)
,@(append-map service-inputs
%dmd-services))))))