summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/derivations.scm117
-rw-r--r--guix/download.scm19
-rw-r--r--guix/gnu-maintenance.scm276
-rw-r--r--guix/gnupg.scm152
-rw-r--r--guix/packages.scm33
-rw-r--r--guix/scripts/build.scm18
-rw-r--r--guix/scripts/download.scm36
-rw-r--r--guix/scripts/gc.scm7
-rw-r--r--guix/scripts/hash.scm120
-rw-r--r--guix/scripts/package.scm52
-rw-r--r--guix/scripts/refresh.scm182
-rwxr-xr-xguix/scripts/substitute-binary.scm250
-rw-r--r--guix/snix.scm13
-rw-r--r--guix/store.scm5
-rw-r--r--guix/ui.scm181
-rw-r--r--guix/utils.scm56
-rw-r--r--guix/web.scm85
17 files changed, 1308 insertions, 294 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 2243d2ba46..cf329819c4 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -48,6 +48,7 @@
derivation-input?
derivation-input-path
derivation-input-sub-derivations
+ derivation-input-output-paths
fixed-output-derivation?
derivation-hash
@@ -99,6 +100,14 @@ download with a fixed hash (aka. `fetchurl')."
#t)
(_ #f)))
+(define (derivation-input-output-paths input)
+ "Return the list of output paths corresponding to INPUT, a
+<derivation-input>."
+ (match input
+ (($ <derivation-input> path sub-drvs)
+ (map (cut derivation-path->output-path path <>)
+ sub-drvs))))
+
(define (derivation-prerequisites drv)
"Return the list of derivation-inputs required to build DRV, recursively."
(let loop ((drv drv)
@@ -113,47 +122,85 @@ download with a fixed hash (aka. `fetchurl')."
inputs)))))
(define* (derivation-prerequisites-to-build store drv
- #:key (outputs
- (map
- car
- (derivation-outputs drv))))
- "Return the list of derivation-inputs required to build the OUTPUTS of
-DRV and not already available in STORE, recursively."
+ #:key
+ (outputs
+ (map
+ car
+ (derivation-outputs drv)))
+ (use-substitutes? #t))
+ "Return two values: the list of derivation-inputs required to build the
+OUTPUTS of DRV and not already available in STORE, recursively, and the list
+of required store paths that can be substituted. When USE-SUBSTITUTES? is #f,
+that second value is the empty list."
+ (define (derivation-output-paths drv sub-drvs)
+ (match drv
+ (($ <derivation> outputs)
+ (map (lambda (sub-drv)
+ (derivation-output-path (assoc-ref outputs sub-drv)))
+ sub-drvs))))
+
(define built?
(cut valid-path? store <>))
+ (define substitutable?
+ ;; Return true if the given path is substitutable. Call
+ ;; `substitutable-paths' upfront, to benefit from parallelism in the
+ ;; substituter.
+ (if use-substitutes?
+ (let ((s (substitutable-paths store
+ (append
+ (derivation-output-paths drv outputs)
+ (append-map
+ derivation-input-output-paths
+ (derivation-prerequisites drv))))))
+ (cut member <> s))
+ (const #f)))
+
(define input-built?
- (match-lambda
- (($ <derivation-input> path sub-drvs)
- (let ((out (map (cut derivation-path->output-path path <>)
- sub-drvs)))
- (any built? out)))))
+ (compose (cut any built? <>) derivation-input-output-paths))
+
+ (define input-substitutable?
+ ;; Return true if and only if all of SUB-DRVS are subsitutable. If at
+ ;; least one is missing, then everything must be rebuilt.
+ (compose (cut every substitutable? <>) derivation-input-output-paths))
(define (derivation-built? drv sub-drvs)
- (match drv
- (($ <derivation> outputs)
- (let ((paths (map (lambda (sub-drv)
- (derivation-output-path
- (assoc-ref outputs sub-drv)))
- sub-drvs)))
- (every built? paths)))))
-
- (let loop ((drv drv)
- (sub-drvs outputs)
- (result '()))
- (if (derivation-built? drv sub-drvs)
- result
- (let ((inputs (remove (lambda (i)
- (or (member i result) ; XXX: quadratic
- (input-built? i)))
- (derivation-inputs drv))))
- (fold loop
- (append inputs result)
- (map (lambda (i)
- (call-with-input-file (derivation-input-path i)
- read-derivation))
- inputs)
- (map derivation-input-sub-derivations inputs))))))
+ (every built? (derivation-output-paths drv sub-drvs)))
+
+ (define (derivation-substitutable? drv sub-drvs)
+ (every substitutable? (derivation-output-paths drv sub-drvs)))
+
+ (let loop ((drv drv)
+ (sub-drvs outputs)
+ (build '())
+ (substitute '()))
+ (cond ((derivation-built? drv sub-drvs)
+ (values build substitute))
+ ((derivation-substitutable? drv sub-drvs)
+ (values build
+ (append (derivation-output-paths drv sub-drvs)
+ substitute)))
+ (else
+ (let ((inputs (remove (lambda (i)
+ (or (member i build) ; XXX: quadratic
+ (input-built? i)
+ (input-substitutable? i)))
+ (derivation-inputs drv))))
+ (fold2 loop
+ (append inputs build)
+ (append (append-map (lambda (input)
+ (if (and (not (input-built? input))
+ (input-substitutable? input))
+ (derivation-input-output-paths
+ input)
+ '()))
+ (derivation-inputs drv))
+ substitute)
+ (map (lambda (i)
+ (call-with-input-file (derivation-input-path i)
+ read-derivation))
+ inputs)
+ (map derivation-input-sub-derivations inputs)))))))
(define (%read-derivation drv-port)
;; Actually read derivation from DRV-PORT.
diff --git a/guix/download.scm b/guix/download.scm
index 689920c3e0..99353be8b0 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -21,13 +21,15 @@
#:use-module (ice-9 match)
#:use-module (guix derivations)
#:use-module (guix packages)
- #:use-module ((guix store) #:select (derivation-path?))
+ #:use-module ((guix store) #:select (derivation-path? add-to-store))
+ #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (%mirrors
- url-fetch))
+ url-fetch
+ download-to-store))
;;; Commentary:
;;;
@@ -230,4 +232,17 @@ must be a list of symbol/URL-list pairs."
#:guile-for-build guile-for-build
#:env-vars env-vars)))
+(define* (download-to-store store url #:optional (name (basename url))
+ #:key (log (current-error-port)))
+ "Download from URL to STORE, either under NAME or URL's basename if
+omitted. Write progress reports to LOG."
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (let ((result
+ (parameterize ((current-output-port log))
+ (build:url-fetch url temp #:mirrors %mirrors))))
+ (close port)
+ (and result
+ (add-to-store store name #f "sha256" temp))))))
+
;;; download.scm ends here
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89e7f25589..be739e34a3 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -28,9 +28,17 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (system foreign)
+ #:use-module (guix web)
#:use-module (guix ftp-client)
+ #:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix packages)
+ #:use-module ((guix download) #:select (download-to-store))
+ #:use-module (guix gnupg)
+ #:use-module (rnrs io ports)
+ #:use-module (guix base32)
+ #:use-module ((guix build utils)
+ #:select (substitute))
#:export (gnu-package-name
gnu-package-mundane-name
gnu-package-copyright-holder
@@ -49,7 +57,10 @@
releases
latest-release
- gnu-package-name->name+version))
+ gnu-package-name->name+version
+ package-update-path
+ package-update
+ update-package-source))
;;; Commentary:
;;;
@@ -63,46 +74,11 @@
;;; List of GNU packages.
;;;
-(define (http-fetch uri)
- "Return an input port containing the textual data at URI, a string."
- (let*-values (((resp data)
- (let ((uri (string->uri uri)))
- ;; Try hard to use the API du jour to get an input port.
- (if (version>? "2.0.7" (version))
- (if (defined? 'http-get*)
- (http-get* uri)
- (http-get uri)) ; old Guile, returns a string
- (http-get uri #:streaming? #t)))) ; 2.0.8 or later
- ((code)
- (response-code resp)))
- (case code
- ((200)
- (cond ((not data)
- (begin
- ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer
- ;; encoding, which is required 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.
- (format (current-error-port)
- "warning: using Guile ~a, ~a ~s encoding~%"
- (version)
- "which does not support HTTP"
- (response-transfer-encoding resp))
- (error "download failed; use a newer Guile"
- uri resp)))
- ((string? data) ; old `http-get' returns a string
- (open-input-string data))
- (else ; input port
- data)))
- (else
- (error "download failed" uri code
- (response-reason-phrase resp))))))
-
(define %package-list-url
- (string-append "http://cvs.savannah.gnu.org/"
- "viewvc/*checkout*/gnumaint/"
- "gnupackages.txt?root=womb"))
+ (string->uri
+ (string-append "http://cvs.savannah.gnu.org/"
+ "viewvc/*checkout*/gnumaint/"
+ "gnupackages.txt?root=womb")))
(define-record-type* <gnu-package-descriptor>
gnu-package-descriptor
@@ -188,7 +164,7 @@
"savannah" "fsd" "language" "logo"
"doc-category" "doc-summary" "doc-urls"
"download-url")))
- (group-package-fields (http-fetch %package-list-url)
+ (group-package-fields (http-fetch %package-list-url #:text? #t)
'(())))))
(define (find-packages regexp)
@@ -201,16 +177,17 @@
(define gnu-package?
(memoize
- (lambda (package)
- "Return true if PACKAGE is a GNU package. This procedure may access the
+ (let ((official-gnu-packages (memoize official-gnu-packages)))
+ (lambda (package)
+ "Return true if PACKAGE is a GNU package. This procedure may access the
network to check in GNU's database."
- ;; TODO: Find a way to determine that a package is non-GNU without going
- ;; through the network.
- (let ((url (and=> (package-source package) origin-uri))
- (name (package-name package)))
- (or (and (string? url) (string-prefix? "mirror://gnu" url))
- (and (member name (map gnu-package-name (official-gnu-packages)))
- #t))))))
+ ;; TODO: Find a way to determine that a package is non-GNU without going
+ ;; through the network.
+ (let ((url (and=> (package-source package) origin-uri))
+ (name (package-name package)))
+ (or (and (string? url) (string-prefix? "mirror://gnu" url))
+ (and (member name (map gnu-package-name (official-gnu-packages)))
+ #t)))))))
;;;
@@ -234,6 +211,7 @@ stored."
("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
("icecat" "ftp.gnu.org" "/gnu/gnuzilla")
("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
+ ("glib" "ftp.gnome.org" "/pub/gnome/sources/glib")
("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz")))
(match (assoc project quirks)
@@ -242,30 +220,33 @@ stored."
(_
(values "ftp.gnu.org" (string-append "/gnu/" project)))))
+(define (sans-extension tarball)
+ "Return TARBALL without its .tar.* extension."
+ (let ((end (string-contains tarball ".tar")))
+ (substring tarball 0 end)))
+
+(define %tarball-rx
+ (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\."))
+
+(define %alpha-tarball-rx
+ (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
+
+(define (release-file project file)
+ "Return #f if FILE is not a release tarball of PROJECT, otherwise return
+PACKAGE-VERSION."
+ (and (not (string-suffix? ".sig" file))
+ (and=> (regexp-exec %tarball-rx file)
+ (lambda (match)
+ ;; Filter out unrelated files, like `guile-www-1.1.1'.
+ (equal? project (match:substring match 1))))
+ (not (regexp-exec %alpha-tarball-rx file))
+ (let ((s (sans-extension file)))
+ (and (regexp-exec %package-name-rx s) s))))
+
(define (releases project)
"Return the list of releases of PROJECT as a list of release name/directory
pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
- (define release-rx
- (make-regexp (string-append "^" project
- "-([0-9]|[^-])*(-src)?\\.tar\\.")))
-
- (define alpha-rx
- (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
-
- (define (sans-extension tarball)
- (let ((end (string-contains tarball ".tar")))
- (substring tarball 0 end)))
-
- (define (release-file file)
- ;; Return #f if FILE is not a release tarball, otherwise return
- ;; PACKAGE-VERSION.
- (and (not (string-suffix? ".sig" file))
- (regexp-exec release-rx file)
- (not (regexp-exec alpha-rx file))
- (let ((s (sans-extension file)))
- (and (regexp-exec %package-name-rx s) s))))
-
(let-values (((server directory) (ftp-server/directory project)))
(define conn (ftp-open server))
@@ -291,7 +272,7 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
;; guile-www; in mit-scheme, filter out binaries.
(filter-map (match-lambda
((file 'file . _)
- (and=> (release-file file)
+ (and=> (release-file project file)
(cut cons <> directory)))
(_ #f))
files)
@@ -299,14 +280,39 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
(define (latest-release project)
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
- (let ((releases (releases project)))
- (and (not (null? releases))
- (fold (lambda (release latest)
- (if (version>? (car release) (car latest))
- release
- latest))
- '("" . "")
- releases))))
+ (define (latest a b)
+ (if (version>? a b) a b))
+
+ (define contains-digit?
+ (cut string-any char-set:digit <>))
+
+ (let-values (((server directory) (ftp-server/directory project)))
+ (define conn (ftp-open server))
+
+ (let loop ((directory directory))
+ (let* ((entries (ftp-list conn directory))
+ (subdirs (filter-map (match-lambda
+ ((dir 'directory . _) dir)
+ (_ #f))
+ entries)))
+ (match subdirs
+ (()
+ ;; No sub-directories, so assume that tarballs are here.
+ (let ((files (filter-map (match-lambda
+ ((file 'file . _)
+ (release-file project file))
+ (_ #f))
+ entries)))
+ (and=> (reduce latest #f files)
+ (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)))
+ (and target
+ (loop (string-append directory "/" target))))))))))
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
@@ -320,4 +326,116 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
(values name+version #f)
(values (match:substring match 1) (match:substring match 2)))))
+
+;;;
+;;; Auto-update.
+;;;
+
+(define (package-update-path package)
+ "Return an update path for PACKAGE, or #f if no update is needed."
+ (and (gnu-package? package)
+ (match (latest-release (package-name package))
+ ((name+version . directory)
+ (let-values (((_ new-version)
+ (package-name->name+version name+version)))
+ (and (version>? name+version (package-full-name package))
+ `(,new-version . ,directory))))
+ (_ #f))))
+
+(define* (download-tarball store project directory version
+ #:optional (archive-type "gz"))
+ "Download PROJECT's tarball over FTP and check its OpenPGP signature. On
+success, return the tarball file name."
+ (let* ((server (ftp-server/directory project))
+ (base (string-append project "-" version ".tar." archive-type))
+ (url (string-append "ftp://" server "/" directory "/" base))
+ (sig-url (string-append url ".sig"))
+ (tarball (download-to-store store url))
+ (sig (download-to-store store sig-url)))
+ (let ((ret (gnupg-verify* sig tarball)))
+ (if ret
+ tarball
+ (begin
+ (warning (_ "signature verification failed for `~a'~%")
+ base)
+ (warning (_ "(could be because the public key is not in your keyring)~%"))
+ #f)))))
+
+(define (package-update store package)
+ "Return the new version and the file name of the new version tarball for
+PACKAGE, or #f and #f when PACKAGE is up-to-date."
+ (match (package-update-path package)
+ ((version . directory)
+ (let-values (((name)
+ (package-name package))
+ ((archive-type)
+ (let ((source (package-source package)))
+ (or (and (origin? source)
+ (file-extension (origin-uri source)))
+ "gz"))))
+ (let ((tarball (download-tarball store name directory version
+ archive-type)))
+ (values version tarball))))
+ (_
+ (values #f #f))))
+
+(define (update-package-source package version hash)
+ "Modify the source file that defines PACKAGE to refer to VERSION,
+whose tarball has SHA256 HASH (a bytevector). Return the new version string
+if an update was made, and #f otherwise."
+ (define (new-line line matches replacement)
+ ;; Iterate over MATCHES and return the modified line based on LINE.
+ ;; Replace each match with REPLACEMENT.
+ (let loop ((m* matches) ; matches
+ (o 0) ; offset in L
+ (r '())) ; result
+ (match m*
+ (()
+ (let ((r (cons (substring line o) r)))
+ (string-concatenate-reverse r)))
+ ((m . rest)
+ (loop rest
+ (match:end m)
+ (cons* replacement
+ (substring line o (match:start m))
+ r))))))
+
+ (define (update-source file old-version version
+ old-hash hash)
+ ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
+ ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
+
+ ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
+ ;; different unrelated places, we may modify it more than needed, for
+ ;; instance. We should try to make changes only within the sexp that
+ ;; corresponds to the definition of PACKAGE.
+ (let ((old-hash (bytevector->nix-base32-string old-hash))
+ (hash (bytevector->nix-base32-string hash)))
+ (substitute file
+ `((,(regexp-quote old-version)
+ . ,(cut new-line <> <> version))
+ (,(regexp-quote old-hash)
+ . ,(cut new-line <> <> hash))))
+ version))
+
+ (let ((name (package-name package))
+ (loc (package-field-location package 'version)))
+ (if loc
+ (let ((old-version (package-version package))
+ (old-hash (origin-sha256 (package-source package)))
+ (file (and=> (location-file loc)
+ (cut search-path %load-path <>))))
+ (if file
+ (update-source file
+ old-version version
+ old-hash hash)
+ (begin
+ (warning (_ "~a: could not locate source file")
+ (location-file loc))
+ #f)))
+ (begin
+ (format (current-error-port)
+ (_ "~a: ~a: no `version' field in source; skipping~%")
+ name (package-location package))))))
+
;;; gnu-maintenance.scm ends here
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
new file mode 100644
index 0000000000..ee67bea91b
--- /dev/null
+++ b/guix/gnupg.scm
@@ -0,0 +1,152 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix gnupg)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
+ #:export (gnupg-verify
+ gnupg-verify*
+ gnupg-status-good-signature?
+ gnupg-status-missing-key?))
+
+;;; Commentary:
+;;;
+;;; GnuPG interface.
+;;;
+;;; Code:
+
+(define %gpg-command "gpg2")
+(define %openpgp-key-server "keys.gnupg.net")
+
+(define (gnupg-verify sig file)
+ "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed."
+
+ (define (status-line->sexp line)
+ ;; See file `doc/DETAILS' in GnuPG.
+ (define sigid-rx
+ (make-regexp
+ "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
+ (define goodsig-rx
+ (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
+ (define validsig-rx
+ (make-regexp
+ "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
+ (define expkeysig-rx ; good signature, but expired key
+ (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
+ (define errsig-rx
+ (make-regexp
+ "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
+
+ (cond ((regexp-exec sigid-rx line)
+ =>
+ (lambda (match)
+ `(signature-id ,(match:substring match 1) ; sig id
+ ,(match:substring match 2) ; date
+ ,(string->number ; timestamp
+ (match:substring match 3)))))
+ ((regexp-exec goodsig-rx line)
+ =>
+ (lambda (match)
+ `(good-signature ,(match:substring match 1) ; key id
+ ,(match:substring match 2)))) ; user name
+ ((regexp-exec validsig-rx line)
+ =>
+ (lambda (match)
+ `(valid-signature ,(match:substring match 1) ; fingerprint
+ ,(match:substring match 2) ; sig creation date
+ ,(string->number ; timestamp
+ (match:substring match 3)))))
+ ((regexp-exec expkeysig-rx line)
+ =>
+ (lambda (match)
+ `(expired-key-signature ,(match:substring match 1) ; fingerprint
+ ,(match:substring match 2)))) ; user name
+ ((regexp-exec errsig-rx line)
+ =>
+ (lambda (match)
+ `(signature-error ,(match:substring match 1) ; key id or fingerprint
+ ,(match:substring match 2) ; pubkey algo
+ ,(match:substring match 3) ; hash algo
+ ,(match:substring match 4) ; sig class
+ ,(string->number ; timestamp
+ (match:substring match 5))
+ ,(let ((rc
+ (string->number ; return code
+ (match:substring match 6))))
+ (case rc
+ ((9) 'missing-key)
+ ((4) 'unknown-algorithm)
+ (else rc))))))
+ (else
+ `(unparsed-line ,line))))
+
+ (define (parse-status input)
+ (let loop ((line (read-line input))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (loop (read-line input)
+ (cons (status-line->sexp line) result)))))
+
+ (let* ((pipe (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
+ "--verify" sig file))
+ (status (parse-status pipe)))
+ ;; Ignore PIPE's exit status since STATUS above should contain all the
+ ;; info we need.
+ (close-pipe pipe)
+ status))
+
+(define (gnupg-status-good-signature? status)
+ "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
+a key-id/user pair; return #f otherwise."
+ (any (lambda (sexp)
+ (match sexp
+ (((or 'good-signature 'expired-key-signature) key-id user)
+ (cons key-id user))
+ (_ #f)))
+ status))
+
+(define (gnupg-status-missing-key? status)
+ "If STATUS denotes a missing-key error, then return the key-id of the
+missing key."
+ (any (lambda (sexp)
+ (match sexp
+ (('signature-error key-id _ ...)
+ key-id)
+ (_ #f)))
+ status))
+
+(define (gnupg-receive-keys key-id server)
+ (system* %gpg-command "--keyserver" server "--recv-keys" key-id))
+
+(define* (gnupg-verify* sig file #:optional (server %openpgp-key-server))
+ "Like `gnupg-verify', but try downloading the public key if it's missing.
+Return #t if the signature was good, #f otherwise."
+ (let ((status (gnupg-verify sig file)))
+ (or (gnupg-status-good-signature? status)
+ (let ((missing (gnupg-status-missing-key? status)))
+ (and missing
+ (begin
+ ;; Download the missing key and try again.
+ (gnupg-receive-keys missing server)
+ (gnupg-status-good-signature? (gnupg-verify sig file))))))))
+
+;;; gnupg.scm ends here
diff --git a/guix/packages.scm b/guix/packages.scm
index 3a6a07bbcc..7a1b100b8d 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -64,6 +64,7 @@
package-maintainers
package-properties
package-location
+ package-field-location
package-transitive-inputs
package-transitive-propagated-inputs
@@ -182,6 +183,38 @@ corresponds to the arguments expected by `set-path-environment-variable'."
package)
16)))))
+(define (package-field-location package field)
+ "Return the source code location of the definition of FIELD for PACKAGE, or
+#f if it could not be determined."
+ (define (goto port line column)
+ (unless (and (= (port-column port) (- column 1))
+ (= (port-line port) (- line 1)))
+ (unless (eof-object? (read-char port))
+ (goto port line column))))
+
+ (match (package-location package)
+ (($ <location> file line column)
+ (catch 'system
+ (lambda ()
+ (call-with-input-file (search-path %load-path file)
+ (lambda (port)
+ (goto port line column)
+ (match (read port)
+ (('package inits ...)
+ (let ((field (assoc field inits)))
+ (match field
+ ((_ value)
+ (and=> (or (source-properties value)
+ (source-properties field))
+ source-properties->location))
+ (_
+ #f))))
+ (_
+ #f)))))
+ (lambda _
+ #f)))
+ (_ #f)))
+
;; Error conditions.
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 339ad0d06f..0bf154dd41 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -43,12 +43,11 @@
When SOURCE? is true, return the derivations of the package sources."
(let ((p (read/eval-package-expression str)))
(if source?
- (let ((source (package-source p))
- (loc (package-location p)))
+ (let ((source (package-source p)))
(if source
(package-source-derivation (%store) source)
- (leave (_ "~a: error: package `~a' has no source~%")
- (location->string loc) (package-name p))))
+ (leave (_ "package `~a' has no source~%")
+ (package-name p))))
(package-derivation (%store) p system))))
@@ -169,7 +168,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(add-indirect-root (%store) root))
((paths ...)
(fold (lambda (path count)
- (let ((root (string-append root "-" (number->string count))))
+ (let ((root (string-append root
+ "-"
+ (number->string count))))
(symlink path root)
(add-indirect-root (%store) root))
(+ 1 count))
@@ -177,8 +178,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
paths))))
(lambda args
(leave (_ "failed to create GC root `~a': ~a~%")
- root (strerror (system-error-errno args)))
- (exit 1)))))
+ root (strerror (system-error-errno args)))))))
(define newest-available-packages
(memoize find-newest-available-packages))
@@ -237,7 +237,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(_ #f))
opts)))
- (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?))
+ (show-what-to-build (%store) drv
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:dry-run? (assoc-ref opts 'dry-run?))
;; TODO: Add more options.
(set-build-options (%store)
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 7c00312c74..220211e6b8 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -21,30 +21,15 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix base32)
- #:use-module ((guix download) #:select (%mirrors))
- #:use-module (guix build download)
+ #:use-module (guix download)
#:use-module (web uri)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:export (guix-download))
-(define (fetch-and-store store fetch name)
- "Call FETCH for URI, and pass it the name of a file to write to; eventually,
-copy data from that port to STORE, under NAME. Return the resulting
-store path."
- (call-with-temporary-output-file
- (lambda (temp port)
- (let ((result
- (parameterize ((current-output-port (current-error-port)))
- (fetch temp))))
- (close port)
- (and result
- (add-to-store store name #f "sha256" temp))))))
;;;
;;; Command-line options.
@@ -55,11 +40,14 @@ store path."
`((format . ,bytevector->nix-base32-string)))
(define (show-help)
- (display (_ "Usage: guix download [OPTION]... URL
+ (display (_ "Usage: guix download [OPTION] URL
Download the file at URL, add it to the store, and print its store path
-and the hash of its contents.\n"))
+and the hash of its contents.
+
+Supported formats: 'nix-base32' (default), 'base32', and 'base16'
+('hex' and 'hexadecimal' can be used as well).\n"))
(format #t (_ "
- -f, --format=FMT write the hash in the given format (default: `nix-base32')"))
+ -f, --format=FMT write the hash in the given format"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -114,20 +102,18 @@ and the hash of its contents.\n"))
(store (open-connection))
(arg (assq-ref opts 'argument))
(uri (or (string->uri arg)
- (leave (_ "guix-download: ~a: failed to parse URI~%")
+ (leave (_ "~a: failed to parse URI~%")
arg)))
(path (case (uri-scheme uri)
((file)
(add-to-store store (basename (uri-path uri))
#f "sha256" (uri-path uri)))
(else
- (fetch-and-store store
- (cut url-fetch arg <>
- #:mirrors %mirrors)
- (basename (uri-path uri))))))
+ (download-to-store store (uri->string uri)
+ (basename (uri-path uri))))))
(hash (call-with-input-file
(or path
- (leave (_ "guix-download: ~a: download failed~%")
+ (leave (_ "~a: download failed~%")
arg))
(compose sha256 get-bytevector-all)))
(fmt (assq-ref opts 'format)))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 3d918923f8..7625bc46e6 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -87,9 +87,8 @@ interpreted."
("TB" (expt 10 12))
("" 1)
(_
- (leave (_ "error: unknown unit: ~a~%") unit)
- (exit 1))))
- (leave (_ "error: invalid number: ~a") numstr))))
+ (leave (_ "unknown unit: ~a~%") unit))))
+ (leave (_ "invalid number: ~a~%") numstr))))
(define %options
;; Specification of the command-line options.
@@ -110,7 +109,7 @@ interpreted."
(let ((amount (size->number arg)))
(if arg
(alist-cons 'min-freed amount result)
- (leave (_ "error: invalid amount of storage: ~a~%")
+ (leave (_ "invalid amount of storage: ~a~%")
arg))))
(#f result)))))
(option '(#\d "delete") #f #f
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
new file mode 100644
index 0000000000..ad05a4e66f
--- /dev/null
+++ b/guix/scripts/hash.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts hash)
+ #:use-module (guix base32)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs files)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:export (guix-hash))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ `((format . ,bytevector->nix-base32-string)))
+
+(define (show-help)
+ (display (_ "Usage: guix hash [OPTION] FILE
+Return the cryptographic hash of FILE.
+
+Supported formats: 'nix-base32' (default), 'base32', and 'base16'
+('hex' and 'hexadecimal' can be used as well).\n"))
+ (format #t (_ "
+ -f, --format=FMT write the hash in the given format"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (list (option '(#\f "format") #t #f
+ (lambda (opt name arg result)
+ (define fmt-proc
+ (match arg
+ ("nix-base32"
+ bytevector->nix-base32-string)
+ ("base32"
+ bytevector->base32-string)
+ ((or "base16" "hex" "hexadecimal")
+ bytevector->base16-string)
+ (x
+ (leave (_ "unsupported hash format: ~a~%")
+ arg))))
+
+ (alist-cons 'format fmt-proc
+ (alist-delete 'format result))))
+
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix hash")))))
+
+
+
+;;;
+;;; Entry point.
+;;;
+
+(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))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts)))
+ (fmt (assq-ref opts 'format)))
+
+ (match args
+ ((file)
+ (catch 'system-error
+ (lambda ()
+ (format #t "~a~%"
+ (call-with-input-file file
+ (compose fmt sha256 get-bytevector-all))))
+ (lambda args
+ (leave (_ "~a~%")
+ (strerror (system-error-errno args))))))
+ (_
+ (leave (_ "wrong number of arguments~%"))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index ac99d16497..c5656efc14 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -208,7 +208,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(switch-symlinks profile previous-profile))
(cond ((not (file-exists? profile)) ; invalid profile
- (leave (_ "error: profile `~a' does not exist~%")
+ (leave (_ "profile `~a' does not exist~%")
profile))
((zero? number) ; empty profile
(format (current-error-port)
@@ -266,19 +266,42 @@ matching packages."
(assoc-ref (derivation-outputs drv) sub-drv))))
`(,name ,out))))))
+(define %sigint-prompt
+ ;; The prompt to jump to upon SIGINT.
+ (make-prompt-tag "interruptible"))
+
+(define (call-with-sigint-handler thunk handler)
+ "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal
+number in the context of the continuation of the call to this function, and
+return its return value."
+ (call-with-prompt %sigint-prompt
+ (lambda ()
+ (sigaction SIGINT
+ (lambda (signum)
+ (sigaction SIGINT SIG_DFL)
+ (abort-to-prompt %sigint-prompt signum)))
+ (thunk))
+ (lambda (k signum)
+ (handler signum))))
+
(define-syntax-rule (waiting exp fmt rest ...)
"Display the given message while EXP is being evaluated."
(let* ((message (format #f fmt rest ...))
(blank (make-string (string-length message) #\space)))
(display message (current-error-port))
(force-output (current-error-port))
- (let ((result exp))
- ;; Clear the line.
- (display #\cr (current-error-port))
- (display blank (current-error-port))
- (display #\cr (current-error-port))
- (force-output (current-error-port))
- exp)))
+ (call-with-sigint-handler
+ (lambda ()
+ (let ((result exp))
+ ;; Clear the line.
+ (display #\cr (current-error-port))
+ (display blank (current-error-port))
+ (display #\cr (current-error-port))
+ (force-output (current-error-port))
+ exp))
+ (lambda (signum)
+ (format (current-error-port) " interrupted by signal ~a~%" SIGINT)
+ #f))))
(define (check-package-freshness package)
"Check whether PACKAGE has a newer version available upstream, and report
@@ -328,7 +351,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(display (_ "
-r, --remove=PACKAGE remove PACKAGE"))
(display (_ "
- -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
+ -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
(display (_ "
--roll-back roll back to the previous generation"))
(newline)
@@ -379,7 +402,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(option '(#\r "remove") #t #f
(lambda (opt name arg result)
(alist-cons 'remove arg result)))
- (option '(#\u "upgrade") #t #f
+ (option '(#\u "upgrade") #f #t
(lambda (opt name arg result)
(alist-cons 'upgrade arg result)))
(option '("roll-back") #f #f
@@ -454,8 +477,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(define (ensure-output p sub-drv)
(if (member sub-drv (package-outputs p))
p
- (leave (_ "~a: error: package `~a' lacks output `~a'~%")
- (location->string (package-location p))
+ (leave (_ "package `~a' lacks output `~a'~%")
(package-full-name p)
sub-drv)))
@@ -602,7 +624,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(let* ((installed (manifest-packages (profile-manifest profile)))
(upgrade-regexps (filter-map (match-lambda
(('upgrade . regexp)
- (make-regexp regexp))
+ (make-regexp (or regexp "")))
(_ #f))
opts))
(upgrade (if (null? upgrade-regexps)
@@ -674,7 +696,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(ensure-default-profile))
(show-what-to-remove/install remove* install* dry-run?)
- (show-what-to-build (%store) drv dry-run?)
+ (show-what-to-build (%store) drv
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?)
(or dry-run?
(and (build-derivations (%store) drv)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
new file mode 100644
index 0000000000..da318b07ad
--- /dev/null
+++ b/guix/scripts/refresh.scm
@@ -0,0 +1,182 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts refresh)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix gnu-maintenance)
+ #:use-module (gnu packages)
+ #:use-module ((gnu packages base) #:select (%final-inputs))
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (rnrs io ports)
+ #:export (guix-refresh))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ '())
+
+(define %options
+ ;; Specification of the command-line options.
+ (list (option '(#\n "dry-run") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'dry-run? #t result)))
+ (option '(#\s "select") #t #f
+ (lambda (opt name arg result)
+ (match arg
+ ((or "core" "non-core")
+ (alist-cons 'select (string->symbol arg)
+ result))
+ (x
+ (leave (_ "~a: invalid selection; expected `core' or `non-core'")
+ arg)))))
+
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix refresh")))))
+
+(define (show-help)
+ (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
+Update package definitions to match the latest upstream version.
+
+When PACKAGE... is given, update only the specified packages. Otherwise
+update all the packages of the distribution, or the subset thereof
+specified with `--select'.\n"))
+ (display (_ "
+ -n, --dry-run do not build the derivations"))
+ (display (_ "
+ -s, --select=SUBSET select all the packages in SUBSET, one of
+ `core' or `non-core'"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(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))
+
+ (define core-package?
+ (let* ((input->package (match-lambda
+ ((name (? package? package) _ ...) package)
+ (_ #f)))
+ (final-inputs (map input->package %final-inputs))
+ (core (append final-inputs
+ (append-map (compose (cut filter-map input->package <>)
+ package-transitive-inputs)
+ final-inputs)))
+ (names (delete-duplicates (map package-name core))))
+ (lambda (package)
+ "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
+update would trigger a complete rebuild."
+ ;; Compare by name because packages in base.scm basically inherit
+ ;; other packages. So, even if those packages are not core packages
+ ;; themselves, updating them would also update those who inherit from
+ ;; them.
+ ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
+ (member (package-name package) names))))
+
+ (let* ((opts (parse-options))
+ (dry-run? (assoc-ref opts 'dry-run?))
+ (packages (match (concatenate
+ (filter-map (match-lambda
+ (('argument . value)
+ (let ((p (find-packages-by-name value)))
+ (unless p
+ (leave (_ "~a: no package by that name")
+ value))
+ p))
+ (_ #f))
+ opts))
+ (() ; default to all packages
+ (let ((select? (match (assoc-ref opts 'select)
+ ('core core-package?)
+ ('non-core (negate core-package?))
+ (_ (const #t)))))
+ ;; TODO: Keep only the newest of each package.
+ (fold-packages (lambda (package result)
+ (if (select? package)
+ (cons package result)
+ result))
+ '())))
+ (some ; user-specified packages
+ some))))
+ (with-error-handling
+ (if dry-run?
+ (for-each (lambda (package)
+ (match (false-if-exception (package-update-path package))
+ ((new-version . directory)
+ (let ((loc (or (package-field-location package 'version)
+ (package-location package))))
+ (format (current-error-port)
+ (_ "~a: ~a would be upgraded from ~a to ~a~%")
+ (location->string loc)
+ (package-name package) (package-version package)
+ new-version)))
+ (_ #f)))
+ packages)
+ (let ((store (open-connection)))
+ (for-each (lambda (package)
+ (let-values (((version tarball)
+ (catch #t
+ (lambda ()
+ (package-update store package))
+ (lambda _
+ (values #f #f))))
+ ((loc)
+ (or (package-field-location package
+ 'version)
+ (package-location package))))
+ (when version
+ (format (current-error-port)
+ (_ "~a: ~a: updating from version ~a to version ~a...~%")
+ (location->string loc) (package-name package)
+ (package-version package) version)
+ (let ((hash (call-with-input-file tarball
+ (compose sha256 get-bytevector-all))))
+ (update-package-source package version hash)))))
+ packages))))))
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 2b447ce7f2..87561db4b3 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -22,18 +22,20 @@
#:use-module (guix utils)
#:use-module (guix config)
#:use-module (guix nar)
+ #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (web uri)
- #:use-module (web client)
- #:use-module (web response)
+ #:use-module (guix web)
#:export (guix-substitute-binary))
;;; Comment:
@@ -47,6 +49,40 @@
;;;
;;; Code:
+(define %narinfo-cache-directory
+ ;; A local cache of narinfos, to avoid going to the network.
+ (or (and=> (getenv "XDG_CACHE_HOME")
+ (cut string-append <> "/guix/substitute-binary"))
+ (string-append %state-directory "/substitute-binary/cache")))
+
+(define %narinfo-ttl
+ ;; Number of seconds during which cached narinfo lookups are considered
+ ;; valid.
+ (* 24 3600))
+
+(define %narinfo-negative-ttl
+ ;; Likewise, but for negative lookups---i.e., cached lookup failures.
+ (* 3 3600))
+
+(define %narinfo-expired-cache-entry-removal-delay
+ ;; How often we want to remove files corresponding to expired cache entries.
+ (* 7 24 3600))
+
+(define (with-atomic-file-output file proc)
+ "Call PROC with an output port for the file that is going to replace FILE.
+Upon success, FILE is atomically replaced by what has been written to the
+output port, and PROC's result is returned."
+ (let* ((template (string-append file ".XXXXXX"))
+ (out (mkstemp! template)))
+ (with-throw-handler #t
+ (lambda ()
+ (let ((result (proc out)))
+ (close out)
+ (rename-file template file)
+ result))
+ (lambda (key . args)
+ (false-if-exception (delete-file template))))))
+
(define (fields->alist port)
"Read recutils-style record from PORT and return them as a list of key/value
pairs."
@@ -72,6 +108,17 @@ pairs."
(let ((args (map (cut assoc-ref alist <>) keys)))
(apply make args)))
+(define (object->fields object fields port)
+ "Write OBJECT (typically a record) as a series of recutils-style fields to
+PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
+ (let loop ((fields fields))
+ (match fields
+ (()
+ object)
+ (((field . get) rest ...)
+ (format port "~a: ~a~%" field (get object))
+ (loop rest)))))
+
(define (fetch uri)
"Return a binary input port to URI and the number of bytes it's expected to
provide."
@@ -80,28 +127,7 @@ provide."
(let ((port (open-input-file (uri-path uri))))
(values port (stat:size (stat port)))))
((http)
- (let*-values (((resp port)
- ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
- ;; in 2.0.8 (!). Assume it is available here.
- (if (version>? "2.0.7" (version))
- (http-get* uri #:decode-body? #f)
- (http-get uri #:streaming? #t)))
- ((code)
- (response-code resp))
- ((size)
- (response-content-length resp)))
- (case code
- ((200) ; OK
- (values port size))
- ((301 ; moved permanently
- 302) ; found (redirection)
- (let ((uri (response-location resp)))
- (format #t "following redirection to `~a'...~%"
- (uri->string uri))
- (fetch uri)))
- (else
- (error "download failed" (uri->string uri)
- code (response-reason-phrase resp))))))))
+ (http-fetch uri #:text? #f))))
(define-record-type <cache>
(%make-cache url store-directory wants-mass-query?)
@@ -161,22 +187,166 @@ failure."
(_ deriver))
system)))
+(define* (read-narinfo port #:optional url)
+ "Read a narinfo from PORT in its standard external form. If URL is true, it
+must be a string used to build full URIs from relative URIs found while
+reading PORT."
+ (alist->record (fields->alist port)
+ (narinfo-maker url)
+ '("StorePath" "URL" "Compression"
+ "FileHash" "FileSize" "NarHash" "NarSize"
+ "References" "Deriver" "System")))
+
+(define (write-narinfo narinfo port)
+ "Write NARINFO to PORT."
+ (define (empty-string-if-false x)
+ (or x ""))
+
+ (define (number-or-empty-string x)
+ (if (number? x)
+ (number->string x)
+ ""))
+
+ (object->fields narinfo
+ `(("StorePath" . ,narinfo-path)
+ ("URL" . ,(compose uri->string narinfo-uri))
+ ("Compression" . ,narinfo-compression)
+ ("FileHash" . ,(compose empty-string-if-false
+ narinfo-file-hash))
+ ("FileSize" . ,(compose number-or-empty-string
+ narinfo-file-size))
+ ("NarHash" . ,(compose empty-string-if-false
+ narinfo-hash))
+ ("NarSize" . ,(compose number-or-empty-string
+ narinfo-size))
+ ("References" . ,(compose string-join narinfo-references))
+ ("Deriver" . ,(compose empty-string-if-false
+ narinfo-deriver))
+ ("System" . ,narinfo-system))
+ port))
+
+(define (narinfo->string narinfo)
+ "Return the external representation of NARINFO."
+ (call-with-output-string (cut write-narinfo narinfo <>)))
+
+(define (string->narinfo str)
+ "Return the narinfo represented by STR."
+ (call-with-input-string str (cut read-narinfo <>)))
+
(define (fetch-narinfo cache path)
"Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
(define (download url)
;; Download the `nix-cache-info' from URL, and return its contents as an
;; list of key/value pairs.
- (and=> (false-if-exception (fetch (string->uri url)))
- fields->alist))
+ (false-if-exception (fetch (string->uri url))))
- (and=> (download (string-append (cache-url cache) "/"
- (store-path-hash-part path)
- ".narinfo"))
- (lambda (properties)
- (alist->record properties (narinfo-maker (cache-url cache))
- '("StorePath" "URL" "Compression"
- "FileHash" "FileSize" "NarHash" "NarSize"
- "References" "Deriver" "System")))))
+ (and (string=? (cache-store-directory cache) (%store-prefix))
+ (and=> (download (string-append (cache-url cache) "/"
+ (store-path-hash-part path)
+ ".narinfo"))
+ (cute read-narinfo <> (cache-url cache)))))
+
+(define (obsolete? date now ttl)
+ "Return #t if DATE is obsolete compared to NOW + TTL seconds."
+ (time>? (subtract-duration now (make-time time-duration 0 ttl))
+ (make-time time-monotonic 0 date)))
+
+(define (lookup-narinfo cache path)
+ "Check locally if we have valid info about PATH, otherwise go to CACHE and
+check what it has."
+ (define now
+ (current-time time-monotonic))
+
+ (define cache-file
+ (string-append %narinfo-cache-directory "/"
+ (store-path-hash-part path)))
+
+ (define (cache-entry narinfo)
+ `(narinfo (version 0)
+ (date ,(time-second now))
+ (value ,(and=> narinfo narinfo->string))))
+
+ (let*-values (((valid? cached)
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file cache-file
+ (lambda (p)
+ (match (read p)
+ (('narinfo ('version 0) ('date date)
+ ('value #f))
+ ;; A cached negative lookup.
+ (if (obsolete? date now %narinfo-negative-ttl)
+ (values #f #f)
+ (values #t #f)))
+ (('narinfo ('version 0) ('date date)
+ ('value value))
+ ;; A cached positive lookup
+ (if (obsolete? date now %narinfo-ttl)
+ (values #f #f)
+ (values #t (string->narinfo value))))))))
+ (lambda _
+ (values #f #f)))))
+ (if valid?
+ cached ; including negative caches
+ (let ((narinfo (and=> (force cache)
+ (cut fetch-narinfo <> path))))
+ (with-atomic-file-output cache-file
+ (lambda (out)
+ (write (cache-entry narinfo) out)))
+ narinfo))))
+
+(define (remove-expired-cached-narinfos)
+ "Remove expired narinfo entries from the cache. The sole purpose of this
+function is to make sure `%narinfo-cache-directory' doesn't grow
+indefinitely."
+ (define now
+ (current-time time-monotonic))
+
+ (define (expired? file)
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file file
+ (lambda (port)
+ (match (read port)
+ (('narinfo ('version 0) ('date date)
+ ('value #f))
+ (obsolete? date now %narinfo-negative-ttl))
+ (('narinfo ('version 0) ('date date)
+ ('value _))
+ (obsolete? date now %narinfo-ttl))
+ (_ #t)))))
+ (lambda args
+ ;; FILE may have been deleted.
+ #t)))
+
+ (for-each (lambda (file)
+ (let ((file (string-append %narinfo-cache-directory
+ "/" file)))
+ (when (expired? file)
+ ;; Wrap in `false-if-exception' because FILE might have been
+ ;; deleted in the meantime (TOCTTOU).
+ (false-if-exception (delete-file file)))))
+ (scandir %narinfo-cache-directory
+ (lambda (file)
+ (= (string-length file) 32)))))
+
+(define (maybe-remove-expired-cached-narinfo)
+ "Remove expired narinfo entries from the cache if deemed necessary."
+ (define now
+ (current-time time-monotonic))
+
+ (define expiry-file
+ (string-append %narinfo-cache-directory "/last-expiry-cleanup"))
+
+ (define last-expiry-date
+ (or (false-if-exception
+ (call-with-input-file expiry-file read))
+ 0))
+
+ (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
+ (remove-expired-cached-narinfos)
+ (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
@@ -214,9 +384,11 @@ through COMMAND. INPUT must be a file input port."
(define (guix-substitute-binary . args)
"Implement the build daemon's substituter protocol."
+ (mkdir-p %narinfo-cache-directory)
+ (maybe-remove-expired-cached-narinfo)
(match args
(("--query")
- (let ((cache (open-cache %cache-url)))
+ (let ((cache (delay (open-cache %cache-url))))
(let loop ((command (read-line)))
(or (eof-object? command)
(begin
@@ -225,7 +397,7 @@ through COMMAND. INPUT must be a file input port."
;; Return the subset of PATHS available in CACHE.
(let ((substitutable
(if cache
- (par-map (cut fetch-narinfo cache <>)
+ (par-map (cut lookup-narinfo cache <>)
paths)
'())))
(for-each (lambda (narinfo)
@@ -237,7 +409,7 @@ through COMMAND. INPUT must be a file input port."
;; Reply info about PATHS if it's in CACHE.
(let ((substitutable
(if cache
- (par-map (cut fetch-narinfo cache <>)
+ (par-map (cut lookup-narinfo cache <>)
paths)
'())))
(for-each (lambda (narinfo)
@@ -262,8 +434,8 @@ through COMMAND. INPUT must be a file input port."
(loop (read-line)))))))
(("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
- (let* ((cache (open-cache %cache-url))
- (narinfo (fetch-narinfo cache store-path))
+ (let* ((cache (delay (open-cache %cache-url)))
+ (narinfo (lookup-narinfo cache store-path))
(uri (narinfo-uri narinfo)))
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
diff --git a/guix/snix.scm b/guix/snix.scm
index 0c19fecb28..04b5e7db2a 100644
--- a/guix/snix.scm
+++ b/guix/snix.scm
@@ -34,6 +34,7 @@
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module (guix config)
+ #:use-module (guix gnu-maintenance)
#:export (open-nixpkgs
xml->snix
nixpkgs->guix-package))
@@ -435,8 +436,16 @@ location of DERIVATION."
(home-page ,(and=> (find-attribute-by-name "homepage" meta)
attribute-value))
- (synopsis ,(and=> (find-attribute-by-name "description" meta)
- attribute-value))
+ (synopsis
+ ;; For GNU packages, prefer the official synopsis.
+ ,(or (false-if-exception
+ (and=> (find (lambda (gnu-package)
+ (equal? (gnu-package-name gnu-package)
+ name))
+ (official-gnu-packages))
+ gnu-package-doc-summary))
+ (and=> (find-attribute-by-name "description" meta)
+ attribute-value)))
(description
,(and=> (find-attribute-by-name "longDescription" meta)
attribute-value))
diff --git a/guix/store.scm b/guix/store.scm
index b1b60babf0..b82588b2a0 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -336,7 +336,10 @@ encoding conversion errors."
#f))
((= k %stderr-error)
(let ((error (read-latin1-string p))
- (status (if (>= (nix-server-minor-version server) 8)
+ ;; Currently the daemon fails to send a status code for early
+ ;; errors like DB schema version mismatches, so check for EOF.
+ (status (if (and (>= (nix-server-minor-version server) 8)
+ (not (eof-object? (lookahead-u8 p))))
(read-int p)
1)))
(raise (condition (&nix-protocol-error
diff --git a/guix/ui.scm b/guix/ui.scm
index dfb6418a10..ff0966e85c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,7 +41,6 @@
with-error-handling
read/eval-package-expression
location->string
- call-with-temporary-output-file
switch-symlinks
config-directory
fill-paragraph
@@ -64,15 +64,50 @@
(define _ (cut gettext <> %gettext-domain))
(define N_ (cut ngettext <> <> <> %gettext-domain))
+(define-syntax-rule (define-diagnostic name prefix)
+ "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
+messages."
+ (define-syntax name
+ (lambda (x)
+ (define (augmented-format-string fmt)
+ (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
+
+ (syntax-case x (N_ _) ; these are literals, yeah...
+ ((name (_ fmt) args (... ...))
+ (string? (syntax->datum #'fmt))
+ (with-syntax ((fmt* (augmented-format-string #'fmt))
+ (prefix (datum->syntax x prefix)))
+ #'(format (guix-warning-port) (gettext fmt*)
+ (program-name) (program-name) prefix
+ args (... ...))))
+ ((name (N_ singular plural n) args (... ...))
+ (and (string? (syntax->datum #'singular))
+ (string? (syntax->datum #'plural)))
+ (with-syntax ((s (augmented-format-string #'singular))
+ (p (augmented-format-string #'plural))
+ (prefix (datum->syntax x prefix)))
+ #'(format (guix-warning-port)
+ (ngettext s p n %gettext-domain)
+ (program-name) (program-name) prefix
+ args (... ...))))))))
+
+(define-diagnostic warning "warning: ") ; emit a warning
+
+(define-diagnostic report-error "error: ")
+(define-syntax-rule (leave args ...)
+ "Emit an error message and exit."
+ (begin
+ (report-error args ...)
+ (exit 1)))
+
(define (install-locale)
"Install the current locale settings."
(catch 'system-error
(lambda _
(setlocale LC_ALL ""))
(lambda args
- (format (current-error-port)
- (_ "warning: failed to install locale: ~a~%")
- (strerror (system-error-errno args))))))
+ (warning (_ "failed to install locale: ~a~%")
+ (strerror (system-error-errno args))))))
(define (initialize-guix)
"Perform the usual initialization for stand-alone Guix commands."
@@ -81,12 +116,6 @@
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF))
-(define-syntax-rule (leave fmt args ...)
- "Format FMT and ARGS to the error port and exit."
- (begin
- (format (current-error-port) fmt args ...)
- (exit 1)))
-
(define* (show-version-and-exit #:optional (command (car (command-line))))
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
@@ -111,16 +140,16 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
(file (location-file location))
(line (location-line location))
(column (location-column location)))
- (leave (_ "~a:~a:~a: error: package `~a' has an invalid input: ~s~%")
+ (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
file line column
(package-full-name package) input)))
((nix-connection-error? c)
- (leave (_ "error: failed to connect to `~a': ~a~%")
+ (leave (_ "failed to connect to `~a': ~a~%")
(nix-connection-error-file c)
(strerror (nix-connection-error-code c))))
((nix-protocol-error? c)
;; FIXME: Server-provided error messages aren't i18n'd.
- (leave (_ "error: build failed: ~a~%")
+ (leave (_ "build failed: ~a~%")
(nix-protocol-error-message c))))
(thunk)))
@@ -144,33 +173,66 @@ error."
(leave (_ "expression `~s' does not evaluate to a package~%")
exp)))))
-(define* (show-what-to-build store drv #:optional dry-run?)
+(define* (show-what-to-build store drv
+ #:key dry-run? (use-substitutes? #t))
"Show what will or would (depending on DRY-RUN?) be built in realizing the
derivations listed in DRV. Return #t if there's something to build, #f
-otherwise."
- (let* ((req (append-map (lambda (drv-path)
- (let ((d (call-with-input-file drv-path
- read-derivation)))
- (derivation-prerequisites-to-build
- store d)))
- drv))
- (req* (delete-duplicates
- (append (remove (compose (cute valid-path? store <>)
- derivation-path->output-path)
- drv)
- (map derivation-input-path req)))))
+otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are
+available for download."
+ (let*-values (((build download)
+ (fold2 (lambda (drv-path build download)
+ (let ((drv (call-with-input-file drv-path
+ read-derivation)))
+ (let-values (((b d)
+ (derivation-prerequisites-to-build
+ store drv
+ #:use-substitutes?
+ use-substitutes?)))
+ (values (append b build)
+ (append d download)))))
+ '() '()
+ drv))
+ ((build) ; add the DRV themselves
+ (delete-duplicates
+ (append (remove (compose (lambda (out)
+ (or (valid-path? store out)
+ (and use-substitutes?
+ (has-substitutes? store
+ out))))
+ derivation-path->output-path)
+ drv)
+ (map derivation-input-path build))))
+ ((download) ; add the references of DOWNLOAD
+ (delete-duplicates
+ (append download
+ (remove (cut valid-path? store <>)
+ (append-map
+ substitutable-references
+ (substitutable-path-info store download)))))))
(if dry-run?
- (format (current-error-port)
- (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
- "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
- (length req*))
- (null? req*) req*)
- (format (current-error-port)
- (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
- "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
- (length req*))
- (null? req*) req*))
- (pair? req*)))
+ (begin
+ (format (current-error-port)
+ (N_ "~:[the following derivation 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~%~}~;~]"
+ (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~%~}~;~]"
+ (length build))
+ (null? build) build)
+ (format (current-error-port)
+ (N_ "~:[the following file will be downloaded:~%~{ ~a~%~}~;~]"
+ "~:[the following files will be downloaded:~%~{ ~a~%~}~;~]"
+ (length download))
+ (null? download) download)))
+ (pair? build)))
(define-syntax with-error-handling
(syntax-rules ()
@@ -187,21 +249,6 @@ otherwise."
(($ <location> file line column)
(format #f "~a:~a:~a" file line column))))
-(define (call-with-temporary-output-file proc)
- "Call PROC with a name of a temporary file and open output port to that
-file; close the file and delete it when leaving the dynamic extent of this
-call."
- (let* ((template (string-copy "guix-file.XXXXXX"))
- (out (mkstemp! template)))
- (dynamic-wind
- (lambda ()
- #t)
- (lambda ()
- (proc template out))
- (lambda ()
- (false-if-exception (close out))
- (false-if-exception (delete-file template))))))
-
(define (switch-symlinks link target)
"Atomically switch LINK, a symbolic link, to point to TARGET. Works
both when LINK already exists and when it does not."
@@ -342,36 +389,6 @@ WIDTH columns."
(define guix-warning-port
(make-parameter (current-warning-port)))
-(define-syntax warning
- (lambda (s)
- "Emit a warming. The macro assumes that `_' is bound to `gettext'."
- ;; All this just to preserve `-Wformat' warnings. Too much?
-
- (define (augmented-format-string fmt)
- (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt)))
-
- (define prefix
- #'(_ "warning: "))
-
- (syntax-case s (N_ _) ; these are literals, yeah...
- ((warning (_ fmt) args ...)
- (string? (syntax->datum #'fmt))
- (with-syntax ((fmt* (augmented-format-string #'fmt))
- (prefix prefix))
- #'(format (guix-warning-port) (gettext fmt*)
- (program-name) (program-name) prefix
- args ...)))
- ((warning (N_ singular plural n) args ...)
- (and (string? (syntax->datum #'singular))
- (string? (syntax->datum #'plural)))
- (with-syntax ((s (augmented-format-string #'singular))
- (p (augmented-format-string #'plural))
- (b prefix))
- #'(format (guix-warning-port)
- (ngettext s p n %gettext-domain)
- (program-name) (program-name) b
- args ...))))))
-
(define (guix-main arg0 . args)
(initialize-guix)
(let ()
diff --git a/guix/utils.scm b/guix/utils.scm
index d7c37e37d1..3cbed2fd0f 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -59,7 +59,10 @@
%current-system
version-compare
version>?
- package-name->name+version))
+ package-name->name+version
+ file-extension
+ call-with-temporary-output-file
+ fold2))
;;;
@@ -463,6 +466,52 @@ introduce the version part."
((head tail ...)
(loop tail (cons head prefix))))))
+(define (file-extension file)
+ "Return the extension of FILE or #f if there is none."
+ (let ((dot (string-rindex file #\.)))
+ (and dot (substring file (+ 1 dot) (string-length file)))))
+
+(define (call-with-temporary-output-file proc)
+ "Call PROC with a name of a temporary file and open output port to that
+file; close the file and delete it when leaving the dynamic extent of this
+call."
+ (let* ((template (string-copy "guix-file.XXXXXX"))
+ (out (mkstemp! template)))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (proc template out))
+ (lambda ()
+ (false-if-exception (close out))
+ (false-if-exception (delete-file template))))))
+
+(define fold2
+ (case-lambda
+ ((proc seed1 seed2 lst)
+ "Like `fold', but with a single list and two seeds."
+ (let loop ((result1 seed1)
+ (result2 seed2)
+ (lst lst))
+ (if (null? lst)
+ (values result1 result2)
+ (call-with-values
+ (lambda () (proc (car lst) result1 result2))
+ (lambda (result1 result2)
+ (loop result1 result2 (cdr lst)))))))
+ ((proc seed1 seed2 lst1 lst2)
+ "Like `fold', but with a two lists and two seeds."
+ (let loop ((result1 seed1)
+ (result2 seed2)
+ (lst1 lst1)
+ (lst2 lst2))
+ (if (or (null? lst1) (null? lst2))
+ (values result1 result2)
+ (call-with-values
+ (lambda () (proc (car lst1) (car lst2) result1 result2))
+ (lambda (result1 result2)
+ (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
+
;;;
;;; Source location.
@@ -490,5 +539,6 @@ etc."
(let ((file (assq-ref loc 'filename))
(line (assq-ref loc 'line))
(col (assq-ref loc 'column)))
- ;; In accordance with the GCS, start line and column numbers at 1.
- (location file (and line (+ line 1)) (and col (+ col 1)))))
+ ;; In accordance with the GCS, start line and column numbers at 1. Note
+ ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
+ (location file (and line (+ line 1)) col)))
diff --git a/guix/web.scm b/guix/web.scm
new file mode 100644
index 0000000000..9d0ee40624
--- /dev/null
+++ b/guix/web.scm
@@ -0,0 +1,85 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix web)
+ #:use-module (web uri)
+ #:use-module (web client)
+ #:use-module (web response)
+ #:use-module (srfi srfi-11)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:export (http-fetch))
+
+;;; Commentary:
+;;;
+;;; Web client portable among Guile versions.
+;;;
+;;; Code:
+
+(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
+textual. Follow any HTTP redirection."
+ (let loop ((uri uri))
+ (let*-values (((resp data)
+ ;; Try hard to use the API du jour to get an input port.
+ ;; On Guile 2.0.5 and before, we can only get a string or
+ ;; bytevector, and not an input port. Work around that.
+ (if (version>? "2.0.7" (version))
+ (if (defined? 'http-get*)
+ (http-get* uri #:decode-body? text?) ; 2.0.7
+ (http-get uri #:decode-body? text?)) ; 2.0.5-
+ (http-get uri #:streaming? #t))) ; 2.0.9+
+ ((code)
+ (response-code resp)))
+ (case code
+ ((200)
+ (let ((len (response-content-length resp)))
+ (cond ((not data)
+ (begin
+ ;; XXX: 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~%")
+ (version)
+ "which does not support HTTP"
+ (response-transfer-encoding resp))
+ (leave (_ "download failed; use a newer Guile~%")
+ uri resp)))
+ ((string? data) ; `http-get' from 2.0.5-
+ (values (open-input-string data) len))
+ ((bytevector? data) ; likewise
+ (values (open-bytevector-input-port data) len))
+ (else ; input port
+ (values data len)))))
+ ((301 ; moved permanently
+ 302) ; found (redirection)
+ (let ((uri (response-location resp)))
+ (format #t "following redirection to `~a'...~%"
+ (uri->string uri))
+ (loop uri)))
+ (else
+ (error "download failed" uri code
+ (response-reason-phrase resp)))))))
+
+;;; web.scm ends here