aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/guix.texi27
-rw-r--r--gnu/packages/cdrom.scm44
-rw-r--r--gnu/packages/gtk.scm4
-rw-r--r--gnu/packages/linux-initrd.scm6
-rw-r--r--gnu/packages/linux.scm80
-rw-r--r--gnu/packages/system.scm56
-rw-r--r--gnu/packages/xorg.scm20
-rw-r--r--gnu/system/dmd.scm38
-rw-r--r--gnu/system/shadow.scm94
-rw-r--r--gnu/system/vm.scm81
-rw-r--r--guix/build-system/trivial.scm10
-rw-r--r--guix/scripts/package.scm287
-rw-r--r--scripts/guix.in2
-rw-r--r--tests/guix-package.sh20
-rw-r--r--tests/packages.scm15
15 files changed, 640 insertions, 144 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 442cef26da..94658f2b21 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -711,9 +711,28 @@ second one.
@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks,
or months by passing an integer along with the first letter of the
-duration, e.g., @code{--list-generations=20d}.
+duration. For example, @code{--list-generations=20d} lists generations
+that are up to 20 days old.
@end itemize
+@item --delete-generations[=@var{pattern}]
+@itemx -d [@var{pattern}]
+When @var{pattern} is omitted, delete all generations except the current
+one.
+
+This command accepts the same patterns as @option{--list-generations}.
+When @var{pattern} is specified, delete the matching generations. When
+@var{pattern} specifies a duration, generations @emph{older} than the
+specified duration match. For instance, @code{--delete-generations=1m}
+deletes generations that are more than one month old.
+
+If the current generation matches, it is deleted atomically---i.e., by
+switching to the previous available generation. Note that the zeroth
+generation is never deleted.
+
+Note that deleting generations prevents roll-back to them.
+Consequently, this command must be used with care.
+
@end table
@node Packages with Multiple Outputs
@@ -781,6 +800,12 @@ deleted. The set of garbage collector roots includes default user
profiles, and may be augmented with @command{guix build --root}, for
example (@pxref{Invoking guix build}).
+Prior to running @code{guix gc --collect-garbage} to make space, it is
+often useful to remove old generations from user profiles; that way, old
+package builds referenced by those generations can be reclaimed. This
+is achieved by running @code{guix package --delete-generations}
+(@pxref{Invoking guix package}).
+
The @command{guix gc} command has three modes of operation: it can be
used to garbage-collect any dead files (the default), to delete specific
files (the @code{--delete} option), or to print garbage-collector
diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm
index f881e7ab3a..b5b14c718e 100644
--- a/gnu/packages/cdrom.scm
+++ b/gnu/packages/cdrom.scm
@@ -20,15 +20,18 @@
(define-module (gnu packages cdrom)
#:use-module (guix download)
#:use-module (guix packages)
- #:use-module ((guix licenses) #:select (lgpl2.1+ gpl2 gpl3+))
+ #:use-module ((guix licenses) #:select (lgpl2.1+ gpl2 gpl2+ gpl3+))
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages acl)
#:use-module (gnu packages compression)
+ #:use-module ((gnu packages gettext) #:renamer (symbol-prefix-proc 'gnu:))
+ #:use-module (gnu packages gtk)
#:use-module (gnu packages readline)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages help2man)
- #:use-module (gnu packages pkg-config))
+ #:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages which))
(define-public libcddb
(package
@@ -142,3 +145,40 @@ target drive is CDDA capable. In addition to simple reading, cdparanoia adds
extra-robust data verification, synchronization, error handling and scratch
reconstruction capability.")
(license gpl2))) ; libraries under lgpl2.1
+
+(define-public dvdisaster
+ (package
+ (name "dvdisaster")
+ (version "0.72.4")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "http://dvdisaster.net/downloads/dvdisaster-"
+ version ".tar.bz2"))
+ (sha256
+ (base32
+ "0pm039a78h7m9vvjmmjfkl05ii6qdmfhvbypxjbc7j5w82y66is4"))))
+ (build-system gnu-build-system)
+ (inputs
+ `(("gettext" ,gnu:gettext)
+ ("gtk+" ,gtk+)
+ ("pkg-config" ,pkg-config)
+ ("which" ,which)))
+ (arguments
+ `(#:tests? #f)) ; no check target
+ (home-page "http://dvdisaster.net/en/index.html")
+ (synopsis "error correcting codes for optical media images")
+ (description "Optical media (CD,DVD,BD) keep their data only for a
+finite time (typically for many years). After that time, data loss develops
+slowly with read errors growing from the outer media region towards the
+inside.
+
+Dvdisaster stores data on CD/DVD/BD (supported media) in a way that it is
+fully recoverable even after some read errors have developed. This enables
+you to rescue the complete data to a new medium.
+
+Data loss is prevented by using error correcting codes. Error correction
+data is either added to the medium or kept in separate error correction
+files. Dvdisaster works at the image level so that the recovery does not
+depend on the file system of the medium. The maximum error correction
+capacity is user-selectable.")
+ (license gpl2+)))
diff --git a/gnu/packages/gtk.scm b/gnu/packages/gtk.scm
index e72f7c5acc..013d29379b 100644
--- a/gnu/packages/gtk.scm
+++ b/gnu/packages/gtk.scm
@@ -110,14 +110,14 @@ affine transformation (scale, rotation, shear, etc.)")
(define-public harfbuzz
(package
(name "harfbuzz")
- (version "0.9.20")
+ (version "0.9.21")
(source (origin
(method url-fetch)
(uri (string-append "http://www.freedesktop.org/software/harfbuzz/release/harfbuzz-"
version ".tar.bz2"))
(sha256
(base32
- "0rxwvd8j4vcadlhx4a7la33clzggxziblx1k43ccbw5w7yh4yf43"))))
+ "1s6sffgf6ndy12fyln2bdnkn3cb1qfkch0rakdgkgwlq7n46zlx0"))))
(build-system gnu-build-system)
(inputs
`(("cairo" ,cairo)
diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm
index b62843aadd..ed30fa56b1 100644
--- a/gnu/packages/linux-initrd.scm
+++ b/gnu/packages/linux-initrd.scm
@@ -363,8 +363,7 @@ the Linux kernel.")
(make-essential-device-nodes)
;; Prepare the real root file system under /root.
- (unless (file-exists? "/root")
- (mkdir "/root"))
+ (mkdir-p "/root")
(if root
;; Assume ROOT has a usable /dev tree.
(mount root "/root" "ext3")
@@ -374,6 +373,9 @@ the Linux kernel.")
(mount-essential-file-systems #:root "/root")
+ (mkdir-p "/root/tmp")
+ (mount "none" "/root/tmp" "tmpfs")
+
;; XXX: We don't copy our fellow Guile modules to /root (see
;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
;; happen if it throws, to display the exception!), then we're
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 38bff72933..06b0b6da99 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -30,6 +30,8 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages algebra)
+ #:use-module ((gnu packages gettext)
+ #:renamer (symbol-prefix-proc 'g:))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu))
@@ -566,3 +568,81 @@ controls IPv4 and IPv6 configuration and tc stands for traffic control. Both
tools print detailed usage messages and are accompanied by a set of
manpages.")
(license gpl2+)))
+
+(define-public net-tools
+ ;; XXX: This package is basically unmaintained, but it provides a few
+ ;; commands not yet provided by Inetutils, such as 'route', so we have to
+ ;; live with it.
+ (package
+ (name "net-tools")
+ (version "1.60")
+ (home-page "http://www.tazenda.demon.co.uk/phil/net-tools/")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append home-page "/" name "-"
+ version ".tar.bz2"))
+ (sha256
+ (base32
+ "0yvxrzk0mzmspr7sa34hm1anw6sif39gyn85w4c5ywfn8inxvr3s"))))
+ (build-system gnu-build-system)
+ (arguments
+ '(#:phases (alist-replace
+ 'patch
+ (lambda* (#:key inputs #:allow-other-keys)
+ (define (apply-patch file)
+ (zero? (system* "patch" "-p1" "--batch"
+ "--input" file)))
+
+ (let ((patch.gz (assoc-ref inputs "patch")))
+ (format #t "applying Debian patch set '~a'...~%"
+ patch.gz)
+ (system (string-append "gunzip < " patch.gz " > the-patch"))
+ (pk 'here)
+ (and (apply-patch "the-patch")
+ (for-each apply-patch
+ (find-files "debian/patches"
+ "\\.patch")))))
+ (alist-replace
+ 'configure
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ (mkdir-p (string-append out "/bin"))
+ (mkdir-p (string-append out "/sbin"))
+
+ ;; Pretend we have everything...
+ (system "yes | make config")
+
+ ;; ... except we don't have libdnet, so remove that
+ ;; definition.
+ (substitute* '("config.make" "config.h")
+ (("^.*HAVE_AFDECnet.*$") ""))))
+ %standard-phases))
+
+ ;; Binaries that depend on libnet-tools.a don't declare that
+ ;; dependency, making it parallel-unsafe.
+ #:parallel-build? #f
+
+ #:tests? #f ; no test suite
+ #:make-flags (list "CC=gcc"
+ (string-append "BASEDIR="
+ (assoc-ref %outputs "out")))))
+
+ ;; Use the big Debian patch set (the thing does not even compile out of
+ ;; the box.)
+ (inputs `(("patch" ,(origin
+ (method url-fetch)
+ (uri
+ "http://ftp.de.debian.org/debian/pool/main/n/net-tools/net-tools_1.60-24.2.diff.gz")
+ (sha256
+ (base32
+ "0p93lsqx23v5fv4hpbrydmfvw1ha2rgqpn2zqbs2jhxkzhjc030p"))))))
+ (native-inputs `(("gettext" ,g:gettext)))
+
+ (synopsis "Tools for controlling the network subsystem in Linux")
+ (description
+ "This package includes the important tools for controlling the network
+subsystem of the Linux kernel. This includes arp, hostname, ifconfig,
+netstat, rarp and route. Additionally, this package contains utilities
+relating to particular network hardware types (plipconfig, slattach) and
+advanced aspects of IP configuration (iptunnel, ipmaddr).")
+ (license gpl2+)))
diff --git a/gnu/packages/system.scm b/gnu/packages/system.scm
index 9af0365812..3524544746 100644
--- a/gnu/packages/system.scm
+++ b/gnu/packages/system.scm
@@ -23,10 +23,15 @@
#:use-module (guix download)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
+ #:use-module (guix build-system trivial)
#:use-module (gnu packages)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages linux)
#:use-module (gnu packages guile)
+ #:use-module ((gnu packages base)
+ #:select (tar))
+ #:use-module ((gnu packages compression)
+ #:select (gzip))
#:use-module (gnu packages pkg-config))
(define-public dmd
@@ -35,11 +40,8 @@
(version "-0.4")
(source (origin
(method url-fetch)
-
- ;; XXX: Temporary location until dmd gets back home.
- (uri (string-append
- "http://www.fdn.fr/~lcourtes/software/guix/dmd-"
- version ".tar.gz"))
+ (uri (string-append "ftp://alpha.gnu.org/gnu/dmd/dmd-"
+ version ".tar.gz"))
(sha256
(base32
"094ja3xvk9ljghhxmy39if67cfjd1hy6m4svnp399n0wpxvaryvy"))))
@@ -268,3 +270,47 @@ login, passwd, su, groupadd, and useradd.")
asks for a login name and then transfers over to 'login'. It is extended to
allow automatic login and starting any app.")
(license gpl2+)))
+
+(define-public net-base
+ (package
+ (name "net-base")
+ (version "5.1")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append
+ "http://ftp.de.debian.org/debian/pool/main/n/netbase/netbase_"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "17l8xk2x632id5f9x9v5fs9wqc650hldd2lf3dh90r1zisj1ya8d"))))
+ (build-system trivial-build-system)
+ (arguments
+ `(#:modules ((guix build utils))
+ #:builder (begin
+ (use-modules (guix build utils)
+ (srfi srfi-26))
+
+ (let* ((source (assoc-ref %build-inputs "source"))
+ (tar (assoc-ref %build-inputs "tar"))
+ (gzip (assoc-ref %build-inputs "gzip"))
+ (output (assoc-ref %outputs "out"))
+ (etc (string-append output "/etc")))
+ (setenv "PATH" (string-append gzip "/bin"))
+ (system* (string-append tar "/bin/tar") "xvf"
+ source)
+ (chdir ,(string-append "netbase-" version))
+ (mkdir-p etc)
+ (for-each copy-file
+ '("etc-services" "etc-protocols" "etc-rpc")
+ (map (cut string-append etc "/" <>)
+ '("services" "protocols" "rpc")))
+ #t))))
+ (native-inputs `(("tar" ,tar)
+ ("gzip" ,gzip)))
+ (synopsis "IANA protocol, port, and RPC number assignments")
+ (description
+ "This package provides the /etc/services, /etc/protocols, and /etc/rpc
+files, which contain information about the IANA-assigned port, protocol, and
+ONC RPC numbers")
+ (home-page "http://packages.debian.org/sid/netbase")
+ (license gpl2)))
diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm
index 613e2c5f0e..df535c1ced 100644
--- a/gnu/packages/xorg.scm
+++ b/gnu/packages/xorg.scm
@@ -2096,7 +2096,6 @@ tracking.")
(license license:x11)))
-;; FIXME: Tries to install file joystick-properties.h into ...--xorg-server-1.12.2/include/xorg
(define-public xf86-input-joystick
(package
(name "xf86-input-joystick")
@@ -2114,6 +2113,11 @@ tracking.")
(build-system gnu-build-system)
(inputs `(("pkg-config" ,pkg-config)
("xorg-server" ,xorg-server)))
+ (arguments
+ `(#:configure-flags
+ (list (string-append "--with-sdkdir="
+ (assoc-ref %outputs "out")
+ "/include/xorg"))))
(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")
@@ -2186,13 +2190,20 @@ tracking.")
("mtdev" ,mtdev)
("pkg-config" ,pkg-config)
("xorg-server" ,xorg-server)))
+ (arguments
+ `(#:configure-flags
+ (list (string-append "--with-sdkdir="
+ (assoc-ref %outputs "out")
+ "/include/xorg")
+ (string-append "--with-xorg-conf-dir="
+ (assoc-ref %outputs "out")
+ "/share/X11/xorg.conf.d"))))
(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")
(license license:x11)))
-;; FIXME: Installation tries to create ...-xorg-server-1.12.2/share/X11/xorg.conf.d
(define-public xf86-input-vmmouse
(package
(name "xf86-input-vmmouse")
@@ -2210,6 +2221,11 @@ tracking.")
(build-system gnu-build-system)
(inputs `(("pkg-config" ,pkg-config)
("xorg-server" ,xorg-server)))
+ (arguments
+ `(#:configure-flags
+ (list(string-append "--with-xorg-conf-dir="
+ (assoc-ref %outputs "out")
+ "/share/X11/xorg.conf.d"))))
(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/system/dmd.scm b/gnu/system/dmd.scm
index b248d9f0c5..4d3b4b31f0 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -27,6 +27,8 @@
#:select (mingetty inetutils))
#:use-module ((gnu packages package-management)
#:select (guix))
+ #:use-module ((gnu packages linux)
+ #:select (net-tools))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (service?
@@ -144,31 +146,51 @@
(inputs `(("inetutils" ,inetutils)
("syslog.conf" ,syslog.conf))))))
-(define* (guix-service store #:key (guix guix))
+(define* (guix-service store #:key (guix guix) (builder-group "guixbuild"))
"Return a service that runs the build daemon from GUIX."
(let* ((drv (package-derivation store guix))
(daemon (string-append (derivation->output-path drv)
"/bin/guix-daemon")))
(service
(provision '(guix-daemon))
- (start `(make-forkexec-constructor ,daemon))
+ (start `(make-forkexec-constructor ,daemon
+ "--build-users-group"
+ ,builder-group))
(inputs `(("guix" ,guix))))))
(define* (static-networking-service store interface ip
- #:key (inetutils inetutils))
- "Return a service that starts INTERFACE with address IP."
+ #:key
+ gateway
+ (inetutils inetutils)
+ (net-tools net-tools))
+ "Return a service that starts INTERFACE with address IP. If GATEWAY is
+true, it must be a string specifying the default network gateway."
;; TODO: Eventually we should do this using Guile's networking procedures,
;; like 'configure-qemu-networking' does, but the patch that does this is
;; not yet in stock Guile.
(let ((ifconfig (string-append (package-output store inetutils)
- "/bin/ifconfig")))
+ "/bin/ifconfig"))
+ (route (string-append (package-output store net-tools)
+ "/sbin/route")))
(service
(provision '(networking))
- (start `(make-forkexec-constructor ,ifconfig ,interface ,ip "up"))
- (stop `(make-forkexec-constructor ,ifconfig ,interface "down"))
+ (start `(lambda _
+ (and (zero? (system* ,ifconfig ,interface ,ip "up"))
+ ,(if gateway
+ `(begin
+ (sleep 3) ; XXX
+ (zero? (system* ,route "add" "-net" "default"
+ "gw" ,gateway)))
+ #t))))
+ (stop `(lambda _
+ (system* ,ifconfig ,interface "down")
+ (system* ,route "del" "-net" "default")))
(respawn? #f)
- (inputs `(("inetutils" ,inetutils))))))
+ (inputs `(("inetutils" ,inetutils)
+ ,@(if gateway
+ `(("net-tools" ,net-tools))
+ '()))))))
(define (dmd-configuration-file store services)
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 71f8e0d771..4f59b2b325 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -18,8 +18,34 @@
(define-module (gnu system shadow)
#:use-module (guix store)
+ #:use-module (guix records)
+ #:use-module (guix packages)
+ #:use-module ((gnu packages system)
+ #:select (shadow))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (passwd-file))
+ #:use-module (ice-9 format)
+ #:export (user-account
+ user-account?
+ user-account-name
+ user-account-pass
+ user-account-uid
+ user-account-gid
+ user-account-comment
+ user-account-home-directory
+ user-account-shell
+
+ user-group
+ user-group?
+ user-group-name
+ user-group-password
+ user-group-id
+ user-group-members
+
+ passwd-file
+ group-file
+ guix-build-accounts))
;;; Commentary:
;;;
@@ -27,16 +53,53 @@
;;;
;;; Code:
+(define-record-type* <user-account>
+ user-account make-user-account
+ user-account?
+ (name user-account-name)
+ (password user-account-pass (default ""))
+ (uid user-account-uid)
+ (gid user-account-gid)
+ (comment user-account-comment (default ""))
+ (home-directory user-account-home-directory)
+ (shell user-account-shell (default "/bin/sh")))
+
+(define-record-type* <user-group>
+ user-group make-user-group
+ user-group?
+ (name user-group-name)
+ (password user-group-password (default #f))
+ (id user-group-id)
+ (members user-group-members (default '())))
+
+(define (group-file store groups)
+ "Return a /etc/group file for GROUPS, a list of <user-group> objects."
+ (define contents
+ (let loop ((groups groups)
+ (result '()))
+ (match groups
+ ((($ <user-group> name _ gid (users ...)) rest ...)
+ ;; XXX: Ignore the group password.
+ (loop rest
+ (cons (string-append name "::" (number->string gid)
+ ":" (string-join users ","))
+ result)))
+ (()
+ (string-join (reverse result) "\n" 'suffix)))))
+
+ (add-text-to-store store "group" contents))
+
(define* (passwd-file store accounts #:key shadow?)
- "Return a password file for ACCOUNTS, a list of vectors as returned by
-'getpwnam'. If SHADOW? is true, then it is a /etc/shadow file, otherwise it
-is a /etc/passwd file."
+ "Return a password file for ACCOUNTS, a list of <user-account> objects. If
+SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd
+file."
;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t!
(define contents
(let loop ((accounts accounts)
(result '()))
(match accounts
- ((#(name pass uid gid comment home-dir shell) rest ...)
+ ((($ <user-account> name pass uid gid comment home-dir shell)
+ rest ...)
(loop rest
(cons (if shadow?
(string-append name
@@ -54,4 +117,25 @@ is a /etc/passwd file."
(add-text-to-store store (if shadow? "shadow" "passwd")
contents '()))
+(define* (guix-build-accounts store count #:key
+ (first-uid 30001)
+ (gid 30000)
+ (shadow shadow))
+ "Return a list of COUNT user accounts for Guix build users, with UIDs
+starting at FIRST-UID, and under GID."
+ (let* ((gid* gid)
+ (no-login (string-append (package-output store shadow) "/sbin/nologin")))
+ (unfold (cut > <> count)
+ (lambda (n)
+ (user-account
+ (name (format #f "guixbuilder~2,'0d" n))
+ (password "!")
+ (uid (+ first-uid n -1))
+ (gid gid*)
+ (comment (format #f "Guix Build User ~2d" n))
+ (home-directory "/var/empty")
+ (shell no-login)))
+ 1+
+ 1)))
+
;;; shadow.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 0ed805510a..917fa3ecb1 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -30,6 +30,7 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages qemu)
#:use-module (gnu packages parted)
+ #:use-module (gnu packages zile)
#:use-module (gnu packages grub)
#:use-module (gnu packages linux)
#:use-module (gnu packages linux-initrd)
@@ -295,7 +296,7 @@ such as /etc files."
(begin
(display "creating ext3 partition...\n")
(and (zero? (system* mkfs "-F" "/dev/vda1"))
- (begin
+ (let ((store (string-append "/fs" ,%store-directory)))
(display "mounting partition...\n")
(mkdir "/fs")
(mount "/dev/vda1" "/fs" "ext3")
@@ -303,7 +304,8 @@ such as /etc files."
(symlink grub.cfg "/fs/boot/grub/grub.cfg")
;; Populate the image's store.
- (mkdir-p (string-append "/fs" ,%store-directory))
+ (mkdir-p store)
+ (chmod store #o1775)
(for-each (lambda (thing)
(copy-recursively thing
(string-append "/fs"
@@ -337,6 +339,12 @@ such as /etc files."
(loop rest
(cons `(mkdir-p ,(string-append "/fs" name))
statements)))
+ ((('directory name uid gid) rest ...)
+ (let ((dir (string-append "/fs" name)))
+ (loop rest
+ (cons* `(chown ,dir ,uid ,gid)
+ `(mkdir-p ,dir)
+ statements))))
(((new '-> old) rest ...)
(loop rest
(cons `(symlink ,old
@@ -459,13 +467,26 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
(nscd-service store)
;; QEMU networking settings.
- (static-networking-service store "eth0" "10.0.2.10")))
+ (static-networking-service store "eth0" "10.0.2.10"
+ #:gateway "10.0.2.2")))
+
+ (define build-user-gid 30000)
+
+ (define build-accounts
+ (guix-build-accounts store 10 #:gid build-user-gid))
(define resolv.conf
;; Name resolution for default QEMU settings.
(add-text-to-store store "resolv.conf"
"nameserver 10.0.2.3\n"))
+ (define etc-services
+ (string-append (package-output store net-base) "/etc/services"))
+ (define etc-protocols
+ (string-append (package-output store net-base) "/etc/protocols"))
+ (define etc-rpc
+ (string-append (package-output store net-base) "/etc/rpc"))
+
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash))
(bash-file (string-append (derivation->output-path bash-drv)
@@ -474,12 +495,36 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
(dmd-file (string-append (derivation->output-path dmd-drv)
"/bin/dmd"))
(dmd-conf (dmd-configuration-file store %dmd-services))
- (accounts (list (vector "root" "" 0 0 "System administrator"
- "/" bash-file)))
+ (accounts (cons* (user-account
+ (name "root")
+ (password "")
+ (uid 0) (gid 0)
+ (comment "System administrator")
+ (home-directory "/")
+ (shell bash-file))
+ (user-account
+ (name "guest")
+ (password "")
+ (uid 1000) (gid 100)
+ (comment "Guest of GNU")
+ (home-directory "/home/guest")
+ (shell bash-file))
+ build-accounts))
(passwd (passwd-file store accounts))
(shadow (passwd-file store accounts #:shadow? #t))
- (group (add-text-to-store store "group"
- "root:x:0:\n"))
+ (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))
@@ -490,6 +535,9 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
("gcc" ,gcc-final)
("libc" ,glibc-final)
("inetutils" ,inetutils)
+ ("procps" ,procps)
+ ("psmisc" ,psmisc)
+ ("zile" ,zile)
("guix" ,guix-0.4)))
;; TODO: Replace with a real profile with a manifest.
@@ -514,21 +562,31 @@ 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.
+You can log in as 'guest' or 'root' with no password.
"))
- (populate `((directory "/etc")
+ (populate `((directory "/nix/store" 0 ,build-user-gid)
+ (directory "/etc")
(directory "/var/log") ; for dmd
(directory "/var/run/nscd")
("/etc/shadow" -> ,shadow)
("/etc/passwd" -> ,passwd)
+ ("/etc/group" -> ,group)
("/etc/login.defs" -> "/dev/null")
("/etc/pam.d" -> ,pam.d)
("/etc/resolv.conf" -> ,resolv.conf)
("/etc/profile" -> ,bashrc)
("/etc/issue" -> ,issue)
+ ("/etc/services" -> ,etc-services)
+ ("/etc/protocols" -> ,etc-protocols)
+ ("/etc/rpc" -> ,etc-rpc)
(directory "/var/nix/gcroots")
- ("/var/nix/gcroots/default-profile" -> ,profile)))
+ ("/var/nix/gcroots/default-profile" -> ,profile)
+ (directory "/tmp")
+ (directory "/var/nix/profiles/per-user/root" 0 0)
+ (directory "/var/nix/profiles/per-user/guest"
+ 1000 100)
+ (directory "/home/guest" 1000 100)))
(out (derivation->output-path
(package-derivation store mingetty)))
(boot (add-text-to-store store "boot"
@@ -549,7 +607,7 @@ You can log in as 'root' with no password.
(qemu-image store
#:grub-configuration grub.cfg
#:populate populate
- #:disk-image-size (* 500 (expt 2 20))
+ #:disk-image-size (* 550 (expt 2 20))
#:initialize-store? #t
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
@@ -567,6 +625,7 @@ You can log in as 'root' with no password.
("etc-bashrc" ,bashrc)
("etc-issue" ,issue)
("etc-motd" ,motd)
+ ("net-base" ,net-base)
,@(append-map service-inputs
%dmd-services))))))
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 3c5031c4bd..f91997d1e9 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -42,7 +42,10 @@
search-paths)
"Run build expression BUILDER, an expression, for SYSTEM. SOURCE is
ignored."
- (build-expression->derivation store name system builder inputs
+ (build-expression->derivation store name system builder
+ (if source
+ `(("source" ,source) ,@inputs)
+ inputs)
#:outputs outputs
#:modules modules
#:guile-for-build
@@ -54,7 +57,10 @@ ignored."
search-paths native-search-paths)
"Like `trivial-build', but in a cross-compilation context."
(build-expression->derivation store name system builder
- (append native-inputs inputs)
+ (let ((inputs (append native-inputs inputs)))
+ (if source
+ `(("source" ,source) ,@inputs)
+ inputs))
#:outputs outputs
#:modules modules
#:guile-for-build
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 66505f172f..5c7c165cbb 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -214,6 +214,25 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(compose string->number (cut match:substring <> 1)))
0))
+(define (link-to-empty-profile generation)
+ "Link GENERATION, a string, to the empty profile."
+ (let* ((drv (profile-derivation (%store) '()))
+ (prof (derivation->output-path drv "out")))
+ (when (not (build-derivations (%store) (list drv)))
+ (leave (_ "failed to build the empty profile~%")))
+
+ (switch-symlinks generation prof)))
+
+(define (switch-to-previous-generation profile)
+ "Atomically switch PROFILE to the previous generation."
+ (let* ((number (generation-number profile))
+ (previous-number (previous-generation-number profile number))
+ (previous-generation (format #f "~a-~a-link"
+ profile previous-number)))
+ (format #t (_ "switching from generation ~a to ~a~%")
+ number previous-number)
+ (switch-symlinks profile previous-generation)))
+
(define (roll-back profile)
"Roll back to the previous generation of PROFILE."
(let* ((number (generation-number profile))
@@ -221,38 +240,30 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(previous-generation (format #f "~a-~a-link"
profile previous-number))
(manifest (string-append previous-generation "/manifest")))
-
- (define (switch-link)
- ;; Atomically switch PROFILE to the previous generation.
- (format #t (_ "switching from generation ~a to ~a~%")
- number previous-number)
- (switch-symlinks profile previous-generation))
-
- (cond ((not (file-exists? profile)) ; invalid profile
- (leave (_ "profile `~a' does not exist~%")
+ (cond ((not (file-exists? profile)) ; invalid profile
+ (leave (_ "profile '~a' does not exist~%")
profile))
- ((zero? number) ; empty profile
+ ((zero? number) ; empty profile
(format (current-error-port)
(_ "nothing to do: already at the empty profile~%")))
- ((or (zero? previous-number) ; going to emptiness
+ ((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-generation)))
- (let* ((drv (profile-derivation (%store) '()))
- (prof (derivation->output-path drv "out")))
- (when (not (build-derivations (%store) (list drv)))
- (leave (_ "failed to build the empty profile~%")))
-
- (switch-symlinks previous-generation prof)
- (switch-link)))
- (else (switch-link))))) ; anything else
+ (link-to-empty-profile previous-generation)
+ (switch-to-previous-generation profile))
+ (else
+ (switch-to-previous-generation profile))))) ; anything else
(define (generation-time profile number)
"Return the creation time of a generation in the UTC format."
(make-time time-utc 0
(stat:ctime (stat (format #f "~a-~a-link" profile number)))))
-(define* (matching-generations str #:optional (profile %current-profile))
+(define* (matching-generations str #:optional (profile %current-profile)
+ #:key (duration-relation <=))
"Return the list of available generations matching a pattern in STR. See
-'string->generations' and 'string->duration' for the list of valid patterns."
+'string->generations' and 'string->duration' for the list of valid patterns.
+When STR is a duration pattern, return all the generations whose ctime has
+DURATION-RELATION with the current time."
(define (valid-generations lst)
(define (valid-generation? n)
(any (cut = n <>) (generation-numbers profile)))
@@ -301,7 +312,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(subtract-duration (time-at-midnight (current-time))
duration))))
(delete #f (map (lambda (x)
- (and (<= s (cdr x))
+ (and (duration-relation s (cdr x))
(first x)))
generation-ctime-alist))))))
@@ -511,6 +522,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(display (_ "
-l, --list-generations[=PATTERN]
list generations matching PATTERN"))
+ (display (_ "
+ -d, --delete-generations[=PATTERN]
+ delete generations matching PATTERN"))
(newline)
(display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
@@ -574,6 +588,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(lambda (opt name arg result)
(cons `(query list-generations ,(or arg ""))
result)))
+ (option '(#\d "delete-generations") #f #t
+ (lambda (opt name arg result)
+ (alist-cons 'delete-generations (or arg "")
+ result)))
(option '("search-paths") #f #f
(lambda (opt name arg result)
(cons `(query search-paths) result)))
@@ -824,85 +842,150 @@ more information.~%"))
install))))
(_ #f)))
+ (define current-generation-number
+ (generation-number profile))
+
+ (define (display-and-delete number)
+ (let ((generation (format #f "~a-~a-link" profile number)))
+ (unless (zero? number)
+ (format #t (_ "deleting ~a~%") generation)
+ (delete-file generation))))
+
+ (define (delete-generation number)
+ (let* ((previous-number (previous-generation-number profile number))
+ (previous-generation (format #f "~a-~a-link"
+ profile previous-number)))
+ (cond ((zero? number)) ; do not delete generation 0
+ ((and (= number current-generation-number)
+ (not (file-exists? previous-generation)))
+ (link-to-empty-profile previous-generation)
+ (switch-to-previous-generation profile)
+ (display-and-delete number))
+ ((= number current-generation-number)
+ (roll-back profile)
+ (display-and-delete number))
+ (else
+ (display-and-delete number)))))
+
;; First roll back if asked to.
- (if (and (assoc-ref opts 'roll-back?) (not dry-run?))
- (begin
- (roll-back profile)
- (process-actions (alist-delete 'roll-back? opts)))
- (let* ((installed (manifest-packages (profile-manifest profile)))
- (upgrade-regexps (filter-map (match-lambda
- (('upgrade . regexp)
- (make-regexp (or regexp "")))
- (_ #f))
- opts))
- (upgrade (if (null? upgrade-regexps)
- '()
- (let ((newest (find-newest-available-packages)))
- (filter-map (match-lambda
- ((name version output path _)
- (and (any (cut regexp-exec <> name)
- upgrade-regexps)
- (upgradeable? name version path)
- (find-package name
- (or output "out"))))
- (_ #f))
- installed))))
- (install (append
- upgrade
- (filter-map (match-lambda
- (('install . (? package? p))
- (package->tuple p))
- (('install . (? store-path?))
- #f)
- (('install . package)
- (find-package package))
- (_ #f))
- opts)))
- (drv (filter-map (match-lambda
- ((name version sub-drv
- (? package? package)
- (deps ...))
- (check-package-freshness package)
- (package-derivation (%store) package))
- (_ #f))
- install))
- (install* (append
- (filter-map (match-lambda
- (('install . (? package? p))
- #f)
- (('install . (? store-path? path))
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name
- path))))
- `(,name ,version #f ,path ())))
- (_ #f))
- opts)
- (map (lambda (tuple drv)
- (match tuple
- ((name version sub-drv _ (deps ...))
- (let ((output-path
- (derivation->output-path
- drv sub-drv)))
- `(,name ,version ,sub-drv ,output-path
- ,(canonicalize-deps deps))))))
- install drv)))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (remove* (filter-map (cut assoc <> installed) remove))
- (packages (append install*
- (fold (lambda (package result)
- (match package
- ((name _ out _ ...)
- (filter (negate
- (cut same-package? <>
- name out))
- result))))
- (fold alist-delete installed remove)
- install*))))
+ (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?))
+ (begin
+ (roll-back profile)
+ (process-actions (alist-delete 'roll-back? opts))))
+ ((and (assoc-ref opts 'delete-generations)
+ (not dry-run?))
+ (filter-map
+ (match-lambda
+ (('delete-generations . pattern)
+ (cond ((not (file-exists? profile)) ; XXX: race condition
+ (leave (_ "profile '~a' does not exist~%")
+ profile))
+ ((string-null? pattern)
+ (let ((numbers (generation-numbers profile)))
+ (if (equal? numbers '(0))
+ (exit 0)
+ (for-each display-and-delete
+ (delete current-generation-number
+ numbers)))))
+ ;; Do not delete the zeroth generation.
+ ((equal? 0 (string->number pattern))
+ (exit 0))
+
+ ;; If PATTERN is a duration, match generations that are
+ ;; older than the specified duration.
+ ((matching-generations pattern profile
+ #:duration-relation >)
+ =>
+ (lambda (numbers)
+ (if (null-list? numbers)
+ (exit 1)
+ (for-each delete-generation numbers))))
+ (else
+ (leave (_ "invalid syntax: ~a~%")
+ pattern)))
+
+ (process-actions
+ (alist-delete 'delete-generations opts)))
+ (_ #f))
+ opts))
+ (else
+ (let* ((installed (manifest-packages (profile-manifest profile)))
+ (upgrade-regexps (filter-map (match-lambda
+ (('upgrade . regexp)
+ (make-regexp (or regexp "")))
+ (_ #f))
+ opts))
+ (upgrade (if (null? upgrade-regexps)
+ '()
+ (let ((newest (find-newest-available-packages)))
+ (filter-map
+ (match-lambda
+ ((name version output path _)
+ (and (any (cut regexp-exec <> name)
+ upgrade-regexps)
+ (upgradeable? name version path)
+ (find-package name
+ (or output "out"))))
+ (_ #f))
+ installed))))
+ (install (append
+ upgrade
+ (filter-map (match-lambda
+ (('install . (? package? p))
+ (package->tuple p))
+ (('install . (? store-path?))
+ #f)
+ (('install . package)
+ (find-package package))
+ (_ #f))
+ opts)))
+ (drv (filter-map (match-lambda
+ ((name version sub-drv
+ (? package? package)
+ (deps ...))
+ (check-package-freshness package)
+ (package-derivation (%store) package))
+ (_ #f))
+ install))
+ (install*
+ (append
+ (filter-map (match-lambda
+ (('install . (? package? p))
+ #f)
+ (('install . (? store-path? path))
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name
+ path))))
+ `(,name ,version #f ,path ())))
+ (_ #f))
+ opts)
+ (map (lambda (tuple drv)
+ (match tuple
+ ((name version sub-drv _ (deps ...))
+ (let ((output-path
+ (derivation->output-path
+ drv sub-drv)))
+ `(,name ,version ,sub-drv ,output-path
+ ,(canonicalize-deps deps))))))
+ install drv)))
+ (remove (filter-map (match-lambda
+ (('remove . package)
+ package)
+ (_ #f))
+ opts))
+ (remove* (filter-map (cut assoc <> installed) remove))
+ (packages
+ (append install*
+ (fold (lambda (package result)
+ (match package
+ ((name _ out _ ...)
+ (filter (negate
+ (cut same-package? <>
+ name out))
+ result))))
+ (fold alist-delete installed remove)
+ install*))))
(when (equal? profile %current-profile)
(ensure-default-profile))
@@ -946,7 +1029,7 @@ more information.~%"))
count)
count)
(display-search-paths packages
- profile))))))))))
+ profile)))))))))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was
@@ -983,7 +1066,7 @@ more information.~%"))
((string-null? pattern)
(let ((numbers (generation-numbers profile)))
(if (equal? numbers '(0))
- (exit 1)
+ (exit 0)
(for-each list-generation numbers))))
((matching-generations pattern profile)
=>
diff --git a/scripts/guix.in b/scripts/guix.in
index 4015560cd5..c99e866361 100644
--- a/scripts/guix.in
+++ b/scripts/guix.in
@@ -1,4 +1,4 @@
-#!@GUILE@ -s
+#!@GUILE@ --no-auto-compile
-*- scheme -*-
!#
;;; GNU Guix --- Functional package management for GNU
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 5f97aff026..9116f352c9 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -142,6 +142,17 @@ then
# Make sure LIBRARY_PATH gets listed by `--search-paths'.
guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap
guix package --search-paths -p "$profile" | grep LIBRARY_PATH
+
+ # Delete the third generation and check that it was actually deleted.
+ guix package -p "$profile" --delete-generations=3
+ test -z "`guix package -p "$profile" -l 3`"
+
+ # Exit with 1 when a generation does not exist.
+ if guix package -p "$profile" --delete-generations=42;
+ then false; else true; fi
+
+ # Exit with 0 when trying to delete the zeroth generation.
+ guix package -p "$profile" --delete-generations=0
fi
# Make sure the `:' syntax works.
@@ -155,7 +166,14 @@ if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile";
then false; else true; fi
# Check whether `--list-available' returns something sensible.
-guix package -A 'gui.*e' | grep guile
+guix package -p "$profile" -A 'gui.*e' | grep guile
+
+# There's no generation older than 12 months, so the following command should
+# have no effect.
+generation="`readlink_base "$profile"`"
+if guix package -p "$profile" --delete-generations=12m;
+then false; else true; fi
+test "`readlink_base "$profile"`" = "$generation"
#
# Try with the default profile.
diff --git a/tests/packages.scm b/tests/packages.scm
index 706739fb70..e0cf4ee001 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -167,6 +167,21 @@
(equal? (call-with-input-file p get-bytevector-all)
(call-with-input-file i get-bytevector-all))))))
+(test-assert "trivial with source"
+ (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
+ (p (package (inherit (dummy-package "trivial-with-source"))
+ (build-system trivial-build-system)
+ (source i)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (copy-file (assoc-ref %build-inputs "source")
+ %output)))))
+ (d (package-derivation %store p)))
+ (and (build-derivations %store (list d))
+ (let ((p (derivation->output-path d)))
+ (equal? (call-with-input-file p get-bytevector-all)
+ (call-with-input-file i get-bytevector-all))))))
+
(test-assert "trivial with system-dependent input"
(let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
(build-system trivial-build-system)
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-16 06:49:25 +0000