diff options
| -rw-r--r-- | doc/guix.texi | 27 | ||||
| -rw-r--r-- | gnu/packages/cdrom.scm | 44 | ||||
| -rw-r--r-- | gnu/packages/gtk.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/linux-initrd.scm | 6 | ||||
| -rw-r--r-- | gnu/packages/linux.scm | 80 | ||||
| -rw-r--r-- | gnu/packages/system.scm | 56 | ||||
| -rw-r--r-- | gnu/packages/xorg.scm | 20 | ||||
| -rw-r--r-- | gnu/system/dmd.scm | 38 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 94 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 81 | ||||
| -rw-r--r-- | guix/build-system/trivial.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 287 | ||||
| -rw-r--r-- | scripts/guix.in | 2 | ||||
| -rw-r--r-- | tests/guix-package.sh | 20 | ||||
| -rw-r--r-- | tests/packages.scm | 15 |
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) |