diff options
| -rw-r--r-- | Makefile.am | 18 | ||||
| -rw-r--r-- | NEWS | 82 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | gnu/packages/bison.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/gdb.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/gnupg.scm | 8 | ||||
| -rw-r--r-- | gnu/packages/gprolog.scm | 4 | ||||
| -rw-r--r-- | guix/ftp-client.scm | 35 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 15 | ||||
| -rw-r--r-- | guix/packages.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 12 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 22 | ||||
| -rw-r--r-- | guix/ui.scm | 22 | ||||
| -rw-r--r-- | guix/utils.scm | 48 | ||||
| -rw-r--r-- | guix/web.scm | 117 | ||||
| -rw-r--r-- | tests/utils.scm | 27 |
23 files changed, 403 insertions, 131 deletions
diff --git a/Makefile.am b/Makefile.am index 847d85052b..43f8c3fb82 100644 --- a/Makefile.am +++ b/Makefile.am @@ -297,7 +297,7 @@ gnu/packages/bootstrap/i686-linux/guile-2.0.7.tar.xz: nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm -TESTS = \ +SCM_TESTS = \ tests/base32.scm \ tests/builders.scm \ tests/derivations.scm \ @@ -308,12 +308,16 @@ TESTS = \ tests/snix.scm \ tests/store.scm \ tests/nar.scm \ - tests/union.scm \ + tests/union.scm + +SH_TESTS = \ tests/guix-build.sh \ tests/guix-download.sh \ tests/guix-gc.sh \ tests/guix-package.sh +TESTS = $(SCM_TESTS) $(SH_TESTS) + TEST_EXTENSIONS = .scm .sh AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" @@ -340,12 +344,18 @@ EXTRA_DIST = \ release.nix \ $(TESTS) -CLEANFILES = $(GOBJECTS) *.log +CLEANFILES = \ + $(GOBJECTS) \ + $(SCM_TESTS:%.scm=%.log) + +AM_V_GUILEC = $(AM_V_GUILEC_$(V)) +AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) +AM_V_GUILEC_0 = @echo " GUILEC" $@; # XXX: Use the C locale for when Guile lacks # <http://git.sv.gnu.org/cgit/guile.git/commit/?h=stable-2.0&id=e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f>. .scm.go: - $(MKDIR_P) `dirname "$@"` + $(AM_V_GUILEC)$(MKDIR_P) `dirname "$@"` ; \ LC_ALL=C \ $(top_builddir)/pre-inst-env \ $(GUILD) compile -L "$(top_builddir)" -L "$(top_srcdir)" \ @@ -1,5 +1,83 @@ --*- org -*- +Guix NEWS – history of user-visible changes. -*- org -*- + +Copyright © 2013 Ludovic Courtès <ludo@gnu.org> + + Copying and distribution of this file, with or without modification, + are permitted in any medium without royalty provided the copyright + notice and this notice are preserved. + +Please send Guix bug reports to bug-guix@gnu.org. + * Changes in 0.2 (since 0.1) -** (guix download) now supports HTTPS, using GnuTLS +** Package management + +*** Guix commands are now sub-commands of the “guix” program + +Instead of typing “guix-package”, one now has to type “guix package”, and so +on. This has allowed us to homogenize the user interface and initial program +setup, and to allow commands to be upgradable through “guix pull”. + +*** New “guix pull” command + +The command pulls the latest version of Guix–both the package management +modules and the distribution. See the manual for details. + +*** New binary substituter + +The “substituter” mechanism allows pre-built binaries to be transparently +downloaded instead of performing a build locally. Currently binaries are +available for x86_64 Linux-based GNU systems from http://hydra.gnu.org. See +the manual for details. + +*** New “guix refresh” command + +The command is used by Guix maintainers. It automatically updates the +distribution to the latest upstream releases of GNU software. + +*** New “guix hash” command + +Convenience command to compute the hash of a file. See the manual for +details. + +*** (guix download) now supports HTTPS, using GnuTLS + +It allows package source tarballs to be retrieved over HTTPS. + +** Programming interfaces + +*** New ‘native-search-path’ and ‘search-path’ package fields + +Packages can define in their ‘native-search-path’ field environment variables +that define search paths and need to be set for proper functioning of the +package. For instance, GCC has ‘CPATH’ and ‘LIBRARY_PATH’ in its +‘native-search-path’, Perl has ‘PERL5LIB’, Python has ‘PYTHONPATH’, etc. +These environment variables are automatically set when building a package that +uses one of these. + +*** Package inputs can be a function of the target system type + +The ‘inputs’ field of a package can now be conditional on the value of +(%current-system). This is useful for packages that take system-dependent +tarballs as inputs, such as GNU/MIT Scheme. + +*** New build systems + +The ‘perl-build-system’, ‘python-build-system’, and ‘cmake-build-system’ have +been added. They implement the standard build systems for Perl, Python, and +CMake packages. + +** GNU distribution + +Many updates and additions have been made to the distribution. Here are the +highlights. + +*** Major updates + +GCC 4.7.3 (the default) and GCC 4.8.0, Binutils 2.23.2, Guile 2.0.9, +Coreutils 8.20, GDB 7.6, Texinfo 5.1. + +*** Noteworthy new packages + +TeXLive 2012, Xorg, GNU Parted, QEMU and QEMU-KVM, Avahi, Python, Lua, Samba. diff --git a/configure.ac b/configure.ac index dd1f843afb..e98251b21b 100644 --- a/configure.ac +++ b/configure.ac @@ -40,7 +40,7 @@ AC_ARG_ENABLE([daemon], guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|/usr/local|g"`" AC_SUBST([guix_localstatedir]) -PKG_CHECK_MODULES([GUILE], [guile-2.0]) +PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.5]) AC_PATH_PROG([GUILE], [guile]) AC_PATH_PROG([GUILD], [guild]) if test "x$GUILD" = "x"; then diff --git a/gnu/packages/bison.scm b/gnu/packages/bison.scm index 11483b1434..58ff3b9b5c 100644 --- a/gnu/packages/bison.scm +++ b/gnu/packages/bison.scm @@ -27,7 +27,7 @@ (define-public bison (package (name "bison") - (version "2.6.1") + (version "2.7.1") (source (origin (method url-fetch) @@ -35,7 +35,7 @@ version ".tar.xz")) (sha256 (base32 - "0y9svfkbw8jc8yv280hqzilpvlwg60gayck83jj98djmzaxr1w86")))) + "1yx7isx67sdmyijvihgyra1f59fwdz7sqriginvavfj5yb5ss2dl")))) (build-system gnu-build-system) (inputs `(("perl" ,perl))) (propagated-inputs `(("m4" ,m4))) diff --git a/gnu/packages/gdb.scm b/gnu/packages/gdb.scm index 95f542c707..4cf6b90cc3 100644 --- a/gnu/packages/gdb.scm +++ b/gnu/packages/gdb.scm @@ -32,14 +32,14 @@ (define-public gdb (package (name "gdb") - (version "7.5.1") + (version "7.6") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/gdb/gdb-" version ".tar.bz2")) (sha256 (base32 - "084xs90545an51biyy4qd53hsw6p1k6arviq2wlz1a4z526q02q7")))) + "06yzggy97qka6fs1vdz4q0d2fgrpm3iaj7dzvf1ww377bvryh454")))) (build-system gnu-build-system) (arguments '(#:phases (alist-cons-after diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index 2a610af2ed..9f41b76bea 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -34,7 +34,7 @@ (define-public libgpg-error (package (name "libgpg-error") - (version "1.10") + (version "1.11") (source (origin (method url-fetch) @@ -42,7 +42,7 @@ version ".tar.bz2")) (sha256 (base32 - "0cal3jdnzdailr13qcy74grfbplbghkgr3qwk6qjjp4bass2j1jj")))) + "1h0ql8j65ns2rmhj9wnc9035026crzkg226xg8614fq71947ccxf")))) (build-system gnu-build-system) (home-page "http://gnupg.org") (synopsis @@ -81,7 +81,7 @@ functions, random numbers and a lot of supporting functions.") (define-public libassuan (package (name "libassuan") - (version "2.0.3") + (version "2.1.0") (source (origin (method url-fetch) @@ -89,7 +89,7 @@ functions, random numbers and a lot of supporting functions.") version ".tar.bz2")) (sha256 (base32 - "06xckkvxxlx7cj77803m8x58gxksap4k8yhspc5cqsy7fhinimds")))) + "0ry2078pafpx2prnhngqsj9bvqxaywakp2paqayfh9i71hxbvid4")))) (build-system gnu-build-system) (propagated-inputs `(("libgpg-error" ,libgpg-error) ("pth" ,pth))) diff --git a/gnu/packages/gprolog.scm b/gnu/packages/gprolog.scm index 7f7cbe0178..f82a1a13f4 100644 --- a/gnu/packages/gprolog.scm +++ b/gnu/packages/gprolog.scm @@ -26,7 +26,7 @@ (define-public gprolog (package (name "gprolog") - (version "1.4.3") + (version "1.4.4") (source (origin (method url-fetch) @@ -34,7 +34,7 @@ ".tar.gz")) (sha256 (base32 - "16yl6q9ydx9d8lphg9xkk53l1m0fq0kpvrhry8njsxhhncazm4j2")))) + "13miyas47bmijmadm68cbvb21n4s156gjafz7kfx9brk9djfkh0q")))) (build-system gnu-build-system) (arguments `(#:phases (alist-cons-before diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index e3bacc3720..ba3201fdab 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -130,9 +130,22 @@ or a TCP port number), and return it." (define (ftp-close conn) (close (ftp-connection-socket conn))) +(define %char-set:not-slash + (char-set-complement (char-set #\/))) + (define (ftp-chdir conn dir) - (%ftp-command (string-append "CWD " dir) 250 - (ftp-connection-socket conn))) + "Change to directory DIR." + + ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing + ;; CWD in two steps works, so just do this. + (let ((components (string-tokenize dir %char-set:not-slash))) + (fold (lambda (dir result) + (%ftp-command (string-append "CWD " dir) 250 + (ftp-connection-socket conn))) + #f + (if (string-prefix? "/" dir) + (cons "/" components) + components)))) (define (ftp-size conn file) "Return the size in bytes of FILE." @@ -238,15 +251,15 @@ must be closed before CONN can be used for other purposes." (rec (read! bv start count) (match (get-bytevector-n! s bv start count) - ((? eof-object?) 0) - (0 - ;; Nothing available yet, so try - ;; again. This is important because - ;; the return value of `read!' makes - ;; it impossible to distinguish - ;; between "not yet" and "EOF". - (read! bv start count)) - (read read))) + ((? eof-object?) 0) + (0 + ;; Nothing available yet, so try + ;; again. This is important because + ;; the return value of `read!' makes + ;; it impossible to distinguish + ;; between "not yet" and "EOF". + (read! bv start count)) + (read read))) #f #f ; no get/set position terminate))) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index be739e34a3..96b0a57a5c 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -291,8 +291,12 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (let loop ((directory directory)) (let* ((entries (ftp-list conn directory)) + + ;; Filter out sub-directories that do not contain digits---e.g., + ;; /gnuzilla/lang and /gnupg/patches. (subdirs (filter-map (match-lambda - ((dir 'directory . _) dir) + (((? contains-digit? dir) 'directory . _) + dir) (_ #f)) entries))) (match subdirs @@ -307,10 +311,8 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (cut cons <> directory)))) ((subdirs ...) ;; Assume that SUBDIRS correspond to versions, and jump into the - ;; one with the highest version number. Filter out sub-directories - ;; that do not contain digits---e.g., /gnuzilla/lang. - (let* ((subdirs (filter contains-digit? subdirs)) - (target (reduce latest #f subdirs))) + ;; one with the highest version number. + (let ((target (reduce latest #f subdirs))) (and target (loop (string-append directory "/" target)))))))))) @@ -436,6 +438,7 @@ if an update was made, and #f otherwise." (begin (format (current-error-port) (_ "~a: ~a: no `version' field in source; skipping~%") - name (package-location package)))))) + (location->string (package-location package)) + name))))) ;;; gnu-maintenance.scm ends here diff --git a/guix/packages.scm b/guix/packages.scm index 7a1b100b8d..1cbbd2ec47 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -204,9 +204,12 @@ corresponds to the arguments expected by `set-path-environment-variable'." (let ((field (assoc field inits))) (match field ((_ value) - (and=> (or (source-properties value) - (source-properties field)) - source-properties->location)) + ;; Put the `or' here, and not in the first argument of + ;; `and=>', to work around a compiler bug in 2.0.5. + (or (and=> (source-properties value) + source-properties->location) + (and=> (source-properties field) + source-properties->location))) (_ #f)))) (_ diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 0bf154dd41..4464d84dfc 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -149,12 +149,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (define (guix-build . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (define (register-root paths root) ;; Register ROOT as an indirect GC root for all of PATHS. diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 220211e6b8..da5fa5be9e 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -90,12 +90,12 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (define (guix-download . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (with-error-handling (let* ((opts (parse-options)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 7625bc46e6..cecb68ec36 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -141,12 +141,12 @@ interpreted." (define (guix-gc . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (define (symlink-target file) (let ((s (false-if-exception (lstat file)))) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index ad05a4e66f..deded63136 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -90,13 +90,13 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (define (guix-hash . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "unrecognized option: ~a~%") - name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "unrecognized option: ~a~%") + name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (let* ((opts (parse-options)) (args (filter-map (match-lambda diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0b95afced1..6f75017d6e 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -95,12 +95,12 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (define (guix-import . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (let* ((opts (parse-options)) (args (filter-map (match-lambda diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 560b673618..5eddb7defe 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -498,12 +498,12 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define (guix-package . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: extraneous argument~%") arg)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneous argument~%") arg)) + %default-options)) (define (guile-missing?) ;; Return #t if %GUILE-FOR-BUILD is not available yet. diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c5facd84d5..f4135efc99 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -22,7 +22,7 @@ #:use-module (guix config) #:use-module (guix packages) #:use-module (guix derivations) - #:use-module (guix build download) + #:use-module (guix download) #:use-module (gnu packages base) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) @@ -38,20 +38,6 @@ "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" ) -(define (download-and-store store) - "Download the latest Guix tarball, add it to STORE, and return its store -path." - ;; FIXME: Authenticate the downloaded file! - ;; FIXME: Optimize data transfers using rsync, Git, bsdiff, or GNUnet's DHT. - (call-with-temporary-output-file - (lambda (temp port) - (let ((result - (parameterize ((current-output-port (current-error-port))) - (url-fetch %snapshot-url temp)))) - (close port) - (and result - (add-to-store store "guix-latest.tar.gz" #f "sha256" temp)))))) - (define (unpack store tarball) "Return a derivation that unpacks TARBALL into STORE and compiles Scheme files." @@ -187,17 +173,18 @@ Download and deploy the latest version of Guix.\n")) (define (guix-pull . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: unexpected argument~%") arg)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: unexpected argument~%") arg)) + %default-options)) (with-error-handling (let ((opts (parse-options)) (store (open-connection))) - (let ((tarball (download-and-store store))) + (let ((tarball (download-to-store store %snapshot-url + "guix-latest.tar.gz"))) (unless tarball (leave (_ "failed to download up-to-date source, exiting\n"))) (parameterize ((%guile-for-build diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index da318b07ad..6584282f93 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -93,12 +93,12 @@ specified with `--select'.\n")) (define (guix-refresh . args) (define (parse-options) ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (define core-package? (let* ((input->package (match-lambda diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 87561db4b3..995078e630 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -348,26 +348,10 @@ indefinitely." (call-with-output-file expiry-file (cute write (time-second now) <>)))) -(define (filtered-port command input) - "Return an input port (and PID) where data drained from INPUT is filtered -through COMMAND. INPUT must be a file input port." - (let ((i+o (pipe))) - (match (primitive-fork) - (0 - (close-port (car i+o)) - (close-port (current-input-port)) - (dup2 (fileno input) 0) - (close-port (current-output-port)) - (dup2 (fileno (cdr i+o)) 1) - (apply execl (car command) command)) - (child - (close-port (cdr i+o)) - (values (car i+o) child))))) - (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION." (match compression - ("none" (values input #f)) + ("none" (values input '())) ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) ("xz" (filtered-port `(,%xz "-dc") input)) ("gzip" (filtered-port `(,%gzip "-dc") input)) @@ -442,7 +426,7 @@ through COMMAND. INPUT must be a file input port." (let*-values (((raw download-size) (fetch uri)) - ((input pid) + ((input pids) (decompressed-port (narinfo-compression narinfo) raw))) ;; Note that Hydra currently generates Nars on the fly and doesn't @@ -455,7 +439,7 @@ through COMMAND. INPUT must be a file input port." ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) - (or (not pid) (zero? (cdr (waitpid pid))))))) + (every (compose zero? cdr waitpid) pids)))) (("--version") (show-version-and-exit "guix substitute-binary")))) diff --git a/guix/ui.scm b/guix/ui.scm index ff0966e85c..7a37ad2cee 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -29,6 +29,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (_ @@ -46,6 +47,7 @@ fill-paragraph string->recutils package->recutils + args-fold* run-guix-command program-name guix-warning-port @@ -213,23 +215,23 @@ available for download." (begin (format (current-error-port) (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" (length build)) (null? build) build) (format (current-error-port) (N_ "~:[the following file would be downloaded:~%~{ ~a~%~}~;~]" - "~:[the following files would be downloaded:~%~{ ~a~%~}~;~]" + "~:[the following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) download)) (begin (format (current-error-port) (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" (length build)) (null? build) build) (format (current-error-port) (N_ "~:[the following file will be downloaded:~%~{ ~a~%~}~;~]" - "~:[the following files will be downloaded:~%~{ ~a~%~}~;~]" + "~:[the following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) download))) (pair? build))) @@ -370,6 +372,18 @@ WIDTH columns." (and=> (package-description p) description->recutils)) (newline port)) +(define (args-fold* options unrecognized-option-proc operand-proc . seeds) + "A wrapper on top of `args-fold' that does proper user-facing error +reporting." + (catch 'misc-error + (lambda () + (apply args-fold options unrecognized-option-proc + operand-proc seeds)) + (lambda (key proc msg args . rest) + ;; XXX: MSG is not i18n'd. + (leave (_ "invalid argument: ~a~%") + (apply format #f msg args))))) + (define (show-guix-usage) ;; TODO: Dynamically generate a summary of available commands. (format (current-error-port) diff --git a/guix/utils.scm b/guix/utils.scm index 0b09affffd..7c8e914c01 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -25,6 +25,7 @@ #:use-module (srfi srfi-60) #:use-module (rnrs bytevectors) #:use-module ((rnrs io ports) #:select (put-bytevector)) + #:use-module ((guix build utils) #:select (dump-port)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -63,7 +64,8 @@ string-tokenize* file-extension call-with-temporary-output-file - fold2)) + fold2 + filtered-port)) ;;; @@ -156,6 +158,50 @@ evaluate to a simple datum." ;;; +;;; Filtering & pipes. +;;; + +(define (filtered-port command input) + "Return an input port where data drained from INPUT is filtered through +COMMAND (a list). In addition, return a list of PIDs that the caller must +wait." + (let loop ((input input) + (pids '())) + (if (file-port? input) + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (close-port in) + (close-port (current-input-port)) + (dup2 (fileno input) 0) + (close-port (current-output-port)) + (dup2 (fileno out) 1) + (apply execl (car command) command)) + (child + (close-port out) + (values in (cons child pids)))))) + + ;; INPUT is not a file port, so fork just for the sake of tunneling it + ;; through a file port. + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port in) + (dump-port input out)) + (lambda () + (false-if-exception (close out)) + (primitive-exit 0)))) + (child + (close-port out) + (loop in (cons child pids))))))))) + + +;;; ;;; Nixpkgs. ;;; diff --git a/guix/web.scm b/guix/web.scm index 9d0ee40624..2236bfd621 100644 --- a/guix/web.scm +++ b/guix/web.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012 Free Software Foundation, Inc. ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix web) + #:use-module (guix utils) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -33,6 +35,112 @@ ;;; ;;; Code: +(define-syntax when-guile<=2.0.5 + (lambda (s) + (syntax-case s () + ((_ body ...) + ;; Always emit BODY, regardless of VERSION, because sometimes this code + ;; might be compiled with a recent Guile and run with 2.0.5---e.g., + ;; when using "guix pull". + #'(begin body ...))))) + +(when-guile<=2.0.5 + ;; Backport of Guile commit 312e79f8 ("Add HTTP Chunked Encoding support to + ;; web modules."). + + (use-modules (ice-9 rdelim)) + + ;; Chunked Responses + (define (read-chunk-header port) + (let* ((str (read-line port)) + (extension-start (string-index str (lambda (c) (or (char=? c #\;) + (char=? c #\return))))) + (size (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))) + size)) + + (define (read-chunk port) + (let ((size (read-chunk-header port))) + (read-chunk-body port size))) + + (define (read-chunk-body port size) + (let ((bv (get-bytevector-n port size))) + (get-u8 port) ; CR + (get-u8 port) ; LF + bv)) + + (define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +data from PORT into a non-encoded format. Returns eof when it has +read the final chunk from PORT. This does not necessarily mean +that there is no more data on PORT. When the returned port is +closed it will also close PORT, unless the KEEP-ALIVE? is true." + (define (next-chunk) + (read-chunk port)) + (define finished? #f) + (define (close) + (unless keep-alive? + (close-port port))) + (define buffer #vu8()) + (define buffer-size 0) + (define buffer-pointer 0) + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((<= to-read (- buffer-size buffer-pointer)) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + to-read) + (set! buffer-pointer (+ buffer-pointer to-read)) + (loop 0 (+ num-read to-read))) + (else + (let ((n (- buffer-size buffer-pointer))) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + n) + (set! buffer (next-chunk)) + (set! buffer-pointer 0) + (set! buffer-size (bytevector-length buffer)) + (set! finished? (= buffer-size 0)) + (loop (- to-read n) + (+ num-read n)))))) + (loop to-read 0)) + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + + (define (read-response-body* r) + "Reads the response body from @var{r}, as a bytevector. Returns + @code{#f} if there was no response body." + (define bad-response + (@@ (web response) bad-response)) + + (if (member '(chunked) (response-transfer-encoding r)) + (let ((chunk-port (make-chunked-input-port (response-port r) + #:keep-alive? #t))) + (get-bytevector-all chunk-port)) + (let ((nbytes (response-content-length r))) + ;; Backport of Guile commit 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 + ;; ("fix response-body-port for responses without content-length"). + (if nbytes + (let ((bv (get-bytevector-n (response-port r) nbytes))) + (if (= (bytevector-length bv) nbytes) + bv + (bad-response "EOF while reading response body: ~a bytes of ~a" + (bytevector-length bv) nbytes))) + (get-bytevector-all (response-port r)))))) + + ;; Install this patch only on Guile 2.0.5. + (when (version>? "2.0.6" (version)) + (module-set! (resolve-module '(web response)) + 'read-response-body read-response-body*))) + +;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile +;; up to 2.0.7. +(module-define! (resolve-module '(web client)) + 'shutdown (const #f)) + (define* (http-fetch uri #:key (text? #f)) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be @@ -54,15 +162,14 @@ textual. Follow any HTTP redirection." (let ((len (response-content-length resp))) (cond ((not data) (begin - ;; XXX: Guile 2.0.5 and earlier did not support chunked + ;; Guile 2.0.5 and earlier did not support chunked ;; transfer encoding, which is required for instance when ;; fetching %PACKAGE-LIST-URL (see ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). - ;; Since users may still be using these versions, warn them - ;; and bail out. - (warning (_ "using Guile ~a, ~a ~s encoding~%") + ;; Normally the `when-guile<=2.0.5' block above fixes + ;; that, but who knows what could happen. + (warning (_ "using Guile ~a, which does not support ~s encoding~%") (version) - "which does not support HTTP" (response-transfer-encoding resp)) (leave (_ "download failed; use a newer Guile~%") uri resp))) diff --git a/tests/utils.scm b/tests/utils.scm index 97547a6d62..f14412e61e 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -17,12 +17,14 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (test-utils) + #:use-module ((guix config) #:select (%gzip)) #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) #:use-module (ice-9 match)) (test-begin "utils") @@ -99,6 +101,31 @@ '(0 1 2 3))) list)) +(test-assert "filtered-port, file" + (let ((file (search-path %load-path "guix.scm"))) + (call-with-input-file file + (lambda (input) + (let*-values (((compressed pids1) + (filtered-port `(,%gzip "-c" "--fast") input)) + ((decompressed pids2) + (filtered-port `(,%gzip "-d") compressed))) + (and (every (compose zero? cdr waitpid) + (append pids1 pids2)) + (equal? (get-bytevector-all decompressed) + (call-with-input-file file get-bytevector-all)))))))) + +(test-assert "filtered-port, non-file" + (let ((data (call-with-input-file (search-path %load-path "guix.scm") + get-bytevector-all))) + (let*-values (((compressed pids1) + (filtered-port `(,%gzip "-c" "--fast") + (open-bytevector-input-port data))) + ((decompressed pids2) + (filtered-port `(,%gzip "-d") compressed))) + (and (pk (every (compose zero? cdr waitpid) + (append pids1 pids2))) + (equal? (get-bytevector-all decompressed) data))))) + (test-assert "define-record-type*" (begin (define-record-type* <foo> foo make-foo |