diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/derivations.scm | 117 | ||||
| -rw-r--r-- | guix/download.scm | 19 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 276 | ||||
| -rw-r--r-- | guix/gnupg.scm | 152 | ||||
| -rw-r--r-- | guix/packages.scm | 33 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 36 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 120 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 182 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 250 | ||||
| -rw-r--r-- | guix/snix.scm | 13 | ||||
| -rw-r--r-- | guix/store.scm | 5 | ||||
| -rw-r--r-- | guix/ui.scm | 181 | ||||
| -rw-r--r-- | guix/utils.scm | 56 | ||||
| -rw-r--r-- | guix/web.scm | 85 |
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 |