diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/cmake.scm | 123 | ||||
-rw-r--r-- | guix/build/cmake-build-system.scm | 63 | ||||
-rw-r--r-- | guix/derivations.scm | 129 | ||||
-rw-r--r-- | guix/download.scm | 6 | ||||
-rw-r--r-- | guix/gnu-maintenance.scm | 225 | ||||
-rw-r--r-- | guix/licenses.scm | 12 | ||||
-rw-r--r-- | guix/packages.scm | 2 | ||||
-rw-r--r-- | guix/scripts/download.scm | 47 | ||||
-rw-r--r-- | guix/scripts/package.scm | 87 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 6 | ||||
-rw-r--r-- | guix/snix.scm | 11 | ||||
-rw-r--r-- | guix/store.scm | 50 | ||||
-rw-r--r-- | guix/ui.scm | 4 |
13 files changed, 633 insertions, 132 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm new file mode 100644 index 0000000000..2a9db80cf8 --- /dev/null +++ b/guix/build-system/cmake.scm @@ -0,0 +1,123 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> +;;; +;;; 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 build-system cmake) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (cmake-build + cmake-build-system)) + +;; Commentary: +;; +;; Standard build procedure for packages using CMake. This is implemented as an +;; extension of `gnu-build-system'. +;; +;; Code: + +(define* (cmake-build store name source inputs + #:key (guile #f) + (outputs '("out")) (configure-flags ''()) + (make-flags ''()) + (patches ''()) (patch-flags ''("--batch" "-p1")) + (cmake (@ (gnu packages cmake) cmake)) + (out-of-source? #f) + (path-exclusions ''()) + (tests? #t) + (test-target "test") + (parallel-build? #t) (parallel-tests? #f) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build cmake-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules '((guix build cmake-build-system) + (guix build gnu-build-system) + (guix build utils))) + (modules '((guix build cmake-build-system) + (guix build gnu-build-system) + (guix build utils)))) + "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE +provides a 'CMakeLists.txt' file as its build system." + (define builder + `(begin + (use-modules ,@modules) + (cmake-build #:source ,(if (and source (derivation-path? source)) + (derivation-path->output-path source) + source) + #:system ,system + #:outputs %outputs + #:inputs %build-inputs + #:patches ,patches + #:patch-flags ,patch-flags + #:phases ,phases + #:configure-flags ,configure-flags + #:make-flags ,make-flags + #:out-of-source? ,out-of-source? + #:path-exclusions ,path-exclusions + #:tests? ,tests? + #:test-target ,test-target + #:parallel-build? ,parallel-build? + #:parallel-tests? ,parallel-tests? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system)) + ((and (? string?) (? derivation-path?)) + guile) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages base))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system))))) + + (let ((cmake (package-derivation store cmake system))) + (build-expression->derivation store name system + builder + `(,@(if source + `(("source" ,source)) + '()) + ("cmake" ,cmake) + ,@inputs + + ;; Keep the standard inputs of + ;; `gnu-build-system'. + ,@(standard-inputs system)) + + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build))) + +(define cmake-build-system + (build-system (name 'cmake) + (description "The standard CMake build system") + (build cmake-build))) + +;;; cmake.scm ends here diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm new file mode 100644 index 0000000000..877d8110d7 --- /dev/null +++ b/guix/build/cmake-build-system.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> +;;; +;;; 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 build cmake-build-system) + #:use-module ((guix build gnu-build-system) + #:renamer (symbol-prefix-proc 'gnu:)) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:export (%standard-phases + cmake-build)) + +;; Commentary: +;; +;; Builder-side code of the standard cmake build procedure. +;; +;; Code: + +(define* (configure #:key outputs (configure-flags '()) + #:allow-other-keys) + "Configure the given package." + (let ((out (assoc-ref outputs "out"))) + (if (file-exists? "CMakeLists.txt") + (let ((args `(,(string-append "-DCMAKE_INSTALL_PREFIX=" out) + ,@configure-flags))) + (format #t "running 'cmake' with arguments ~s~%" args) + (zero? (apply system* "cmake" args))) + (error "no CMakeLists.txt found")))) + +(define* (check #:key (tests? #t) (parallel-tests? #t) (test-target "test") + #:allow-other-keys) + (let ((gnu-check (assoc-ref gnu:%standard-phases 'check))) + (gnu-check #:tests? tests? #:test-target test-target + #:parallel-tests? parallel-tests?))) + +(define %standard-phases + ;; Everything is as with the GNU Build System except for the `configure' + ;; and 'check' phases. + (alist-replace 'configure configure + (alist-replace 'check check + gnu:%standard-phases))) + +(define* (cmake-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; cmake-build-system.scm ends here diff --git a/guix/derivations.scm b/guix/derivations.scm index 18a637ae5a..2243d2ba46 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -235,6 +235,32 @@ DRV and not already available in STORE, recursively." (hash-set! cache file drv) drv)))))) +(define-inlinable (write-sequence lst write-item port) + ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a + ;; comma. + (match lst + (() + #t) + ((prefix (... ...) last) + (for-each (lambda (item) + (write-item item port) + (display "," port)) + prefix) + (write-item last port)))) + +(define-inlinable (write-list lst write-item port) + ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each + ;; element. + (display "[" port) + (write-sequence lst write-item port) + (display "]" port)) + +(define-inlinable (write-tuple lst write-item port) + ;; Same, but write LST as a tuple. + (display "(" port) + (write-sequence lst write-item port) + (display ")" port)) + (define (write-derivation drv port) "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of Eelco Dolstra's PhD dissertation for an overview of a previous version of @@ -243,11 +269,8 @@ that form." ;; Make sure we're using the faster implementation. (define format simple-format) - (define (list->string lst) - (string-append "[" (string-join lst ",") "]")) - - (define (write-list lst) - (display (list->string lst) port)) + (define (write-string-list lst) + (write-list lst write port)) (define (coalesce-duplicate-inputs inputs) ;; Return a list of inputs, such that when INPUTS contains the same DRV @@ -272,6 +295,34 @@ that form." '() inputs)) + (define (write-output output port) + (match output + ((name . ($ <derivation-output> path hash-algo hash)) + (write-tuple (list name path + (or (and=> hash-algo symbol->string) "") + (or (and=> hash bytevector->base16-string) + "")) + write + port)))) + + (define (write-input input port) + (match input + (($ <derivation-input> path sub-drvs) + (display "(" port) + (write path port) + (display "," port) + (write-string-list (sort sub-drvs string<?)) + (display ")" port)))) + + (define (write-env-var env-var port) + (match env-var + ((name . value) + (display "(" port) + (write name port) + (display "," port) + (write value port) + (display ")" port)))) + ;; Note: lists are sorted alphabetically, to conform with the behavior of ;; C++ `std::map' in Nix itself. @@ -279,37 +330,28 @@ that form." (($ <derivation> outputs inputs sources system builder args env-vars) (display "Derive(" port) - (write-list (map (match-lambda - ((name . ($ <derivation-output> path hash-algo hash)) - (format #f "(~s,~s,~s,~s)" - name path - (or (and=> hash-algo symbol->string) "") - (or (and=> hash bytevector->base16-string) - "")))) - (sort outputs - (lambda (o1 o2) - (string<? (car o1) (car o2)))))) + (write-list (sort outputs + (lambda (o1 o2) + (string<? (car o1) (car o2)))) + write-output + port) (display "," port) - (write-list (map (match-lambda - (($ <derivation-input> path sub-drvs) - (format #f "(~s,~a)" path - (list->string (map object->string - (sort sub-drvs string<?)))))) - (sort (coalesce-duplicate-inputs inputs) - (lambda (i1 i2) - (string<? (derivation-input-path i1) - (derivation-input-path i2)))))) + (write-list (sort (coalesce-duplicate-inputs inputs) + (lambda (i1 i2) + (string<? (derivation-input-path i1) + (derivation-input-path i2)))) + write-input + port) (display "," port) - (write-list (map object->string (sort sources string<?))) + (write-string-list (sort sources string<?)) (format port ",~s,~s," system builder) - (write-list (map object->string args)) + (write-string-list args) (display "," port) - (write-list (map (match-lambda - ((name . value) - (format #f "(~s,~s)" name value))) - (sort env-vars - (lambda (e1 e2) - (string<? (car e1) (car e2)))))) + (write-list (sort env-vars + (lambda (e1 e2) + (string<? (car e1) (car e2)))) + write-env-var + port) (display ")" port)))) (define derivation-path->output-path @@ -699,14 +741,21 @@ omitted or is #f, the value of the `%guile-for-build' fluid is used instead." (unsetenv "LD_LIBRARY_PATH"))) (builder (add-text-to-store store (string-append name "-guile-builder") - (string-append - (object->string prologue) - (object->string - `(exit - ,(match exp - ((_ ...) - (remove module-form? exp)) - (_ `(,exp)))))) + + ;; Explicitly use UTF-8 for determinism, + ;; and also because UTF-8 output is faster. + (with-fluids ((%default-port-encoding + "UTF-8")) + (call-with-output-string + (lambda (port) + (write prologue port) + (write + `(exit + ,(match exp + ((_ ...) + (remove module-form? exp)) + (_ `(,exp)))) + port)))) ;; The references don't really matter ;; since the builder is always used in diff --git a/guix/download.scm b/guix/download.scm index b6bf6a0822..ea00798b4b 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -43,7 +43,6 @@ "http://ftpmirror.gnu.org/" "ftp://ftp.cs.tu-berlin.de/pub/gnu/" - "ftp://ftp.chg.ru/pub/gnu/" "ftp://ftp.funet.fi/pub/mirrors/ftp.gnu.org/gnu/" ;; This one is the master repository, and thus it's always @@ -67,6 +66,11 @@ "ftp://trumpetti.atm.tut.fi/gcrypt/" "ftp://mirror.cict.fr/gnupg/" "ftp://ftp.strasbourg.linuxfr.org/pub/gnupg/") + (gnome + "http://ftp.belnet.be/ftp.gnome.org/" + "http://ftp.linux.org.uk/mirrors/ftp.gnome.org/" + "http://ftp.gnome.org/pub/GNOME/" + "http://mirror.yandex.ru/mirrors/ftp.gnome.org/") (savannah "http://download.savannah.gnu.org/releases/" "ftp://ftp.twaren.net/Unix/NonGNU/" diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 6475c386d3..979678d076 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (web client) #:use-module (web response) #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -29,7 +30,23 @@ #:use-module (system foreign) #:use-module (guix ftp-client) #:use-module (guix utils) - #:export (official-gnu-packages + #:use-module (guix packages) + #:export (gnu-package-name + gnu-package-mundane-name + gnu-package-copyright-holder + gnu-package-savannah + gnu-package-fsd + gnu-package-language + gnu-package-logo + gnu-package-doc-category + gnu-package-doc-summary + gnu-package-doc-urls + gnu-package-download-url + + official-gnu-packages + find-packages + gnu-package? + releases latest-release gnu-package-name->name+version)) @@ -47,16 +64,32 @@ ;;; (define (http-fetch uri) - "Return a string containing the textual data at URI, a string." + "Return an input port containing the textual data at URI, a string." (let*-values (((resp data) (http-get (string->uri uri))) ((code) (response-code resp))) (case code ((200) - data) + (cond ((string<=? (version) "2.0.5") + (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<=? (version) "2.0.7") + (open-input-string data)) + (else data))) (else - (error "download failed:" uri code + (error "download failed" uri code (response-reason-phrase resp)))))) (define %package-list-url @@ -64,16 +97,114 @@ "viewvc/*checkout*/gnumaint/" "gnupackages.txt?root=womb")) +(define-record-type* <gnu-package-descriptor> + gnu-package-descriptor + make-gnu-package-descriptor + + gnu-package-descriptor? + + (name gnu-package-name) + (mundane-name gnu-package-mundane-name) + (copyright-holder gnu-package-copyright-holder) + (savannah gnu-package-savannah) + (fsd gnu-package-fsd) + (language gnu-package-language) + (logo gnu-package-logo) + (doc-category gnu-package-doc-category) + (doc-summary gnu-package-doc-summary) + (doc-urls gnu-package-doc-urls) + (download-url gnu-package-download-url)) + (define (official-gnu-packages) - "Return a list of GNU packages." - (define %package-line-rx - (make-regexp "^package: (.+)$")) - - (let ((lst (string-split (http-fetch %package-list-url) #\nl))) - (filter-map (lambda (line) - (and=> (regexp-exec %package-line-rx line) - (cut match:substring <> 1))) - lst))) + "Return a list of records, which are GNU packages." + (define (group-package-fields port state) + ;; Return a list of alists. Each alist contains fields of a GNU + ;; package. + (let ((line (read-line port)) + (field-rx (make-regexp "^([[:graph:]]+): (.*)$")) + (doc-urls-rx (make-regexp "^doc-url: (.*)$")) + (end-rx (make-regexp "^# End. .+Do not remove this line.+"))) + + (define (match-field str) + ;; Packages are separated by empty strings. If STR is an + ;; empty string, create a new list to store fields of a + ;; different package. Otherwise, match and create a key-value + ;; pair. + (match str + ("" + (group-package-fields port (cons '() state))) + (str + (cond ((regexp-exec doc-urls-rx str) + => + (lambda (match) + (if (equal? (assoc-ref (first state) "doc-urls") #f) + (group-package-fields + port (cons (cons (cons "doc-urls" + (list + (match:substring match 1))) + (first state)) + (drop state 1))) + (group-package-fields + port (cons (cons (cons "doc-urls" + (cons (match:substring match 1) + (assoc-ref (first state) + "doc-urls"))) + (assoc-remove! (first state) + "doc-urls")) + (drop state 1)))))) + ((regexp-exec field-rx str) + => + (lambda (match) + (group-package-fields + port (cons (cons (cons (match:substring match 1) + (match:substring match 2)) + (first state)) + (drop state 1))))) + (else (group-package-fields port state)))))) + + (if (or (eof-object? line) + (regexp-exec end-rx line)) ; don't include dummy fields + (remove null-list? state) + (match-field line)))) + + (define (alist->record alist make keys) + ;; Apply MAKE, which should be a syntactic constructor, to the + ;; values associated with KEYS in ALIST. + (let ((args (map (cut assoc-ref alist <>) keys))) + (apply make args))) + + (reverse + (map (lambda (alist) + (alist->record alist + make-gnu-package-descriptor + (list "package" "mundane-name" "copyright-holder" + "savannah" "fsd" "language" "logo" + "doc-category" "doc-summary" "doc-urls" + "download-url"))) + (group-package-fields (http-fetch %package-list-url) + '(()))))) + +(define (find-packages regexp) + "Find GNU packages which satisfy REGEXP." + (let ((name-rx (make-regexp regexp))) + (filter (lambda (package) + (false-if-exception + (regexp-exec name-rx (gnu-package-name package)))) + (official-gnu-packages)))) + +(define gnu-package? + (memoize + (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)))))) + ;;; ;;; Latest release. @@ -119,43 +250,45 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (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)) (let loop ((directories (list directory)) (result '())) - (if (null? directories) - (begin - (ftp-close conn) - result) - (let* ((directory (car directories)) - (files (ftp-list conn directory)) - (subdirs (filter-map (lambda (file) - (match file - ((name 'directory . _) name) - (_ #f))) - files))) - (loop (append (map (cut string-append directory "/" <>) - subdirs) - (cdr directories)) - (append - ;; Filter out signatures, deltas, and files which - ;; are potentially not releases of PROJECT--e.g., - ;; in /gnu/guile, filter out guile-oops and - ;; guile-www; in mit-scheme, filter out binaries. - (filter-map (lambda (file) - (match file - ((file 'file . _) - (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) - (cons s directory))))) - (_ #f))) - files) - result))))))) + (match directories + (() + (ftp-close conn) + result) + ((directory rest ...) + (let* ((files (ftp-list conn directory)) + (subdirs (filter-map (match-lambda + ((name 'directory . _) name) + (_ #f)) + files))) + (loop (append (map (cut string-append directory "/" <>) + subdirs) + rest) + (append + ;; Filter out signatures, deltas, and files which + ;; are potentially not releases of PROJECT--e.g., + ;; in /gnu/guile, filter out guile-oops and + ;; guile-www; in mit-scheme, filter out binaries. + (filter-map (match-lambda + ((file 'file . _) + (and=> (release-file file) + (cut cons <> directory))) + (_ #f)) + files) + result)))))))) (define (latest-release project) "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." diff --git a/guix/licenses.scm b/guix/licenses.scm index 4e4aee2036..9c4e17737a 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -39,7 +39,7 @@ psfl public-domain qpl vim - x11 + x11 x11-style zlib fsf-free)) @@ -236,6 +236,16 @@ which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:X11" "https://www.gnu.org/licenses/license-list#X11License")) +(define* (x11-style uri #:optional (comment "")) + "Return an X11-style license, whose full text can be found at URI, +which may be a file:// URI pointing the package's tree." + (license "X11-style" + uri + (string-append + "This is an X11-style, non-copyleft free software license. " + "Check the URI for details. " + comment))) + (define zlib (license "Zlib" "http://www.gzip.org/zlib/zlib_license.html" diff --git a/guix/packages.scm b/guix/packages.scm index 51984baa3b..81f09d638e 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -135,7 +135,7 @@ representation." (synopsis package-synopsis) ; one-line description (description package-description) ; one or two paragraphs - (license package-license (default '())) + (license package-license) (home-page package-home-page) (platforms package-platforms (default '())) (maintainers package-maintainers (default '())) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 3dc227fdcd..3f989a3494 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -110,26 +110,27 @@ and the hash of its contents.\n")) (alist-cons 'argument arg result)) %default-options)) - (let* ((opts (parse-options)) - (store (open-connection)) - (arg (assq-ref opts 'argument)) - (uri (or (string->uri arg) - (leave (_ "guix-download: ~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)))))) - (hash (call-with-input-file - (or path - (leave (_ "guix-download: ~a: download failed~%") - arg)) - (compose sha256 get-bytevector-all))) - (fmt (assq-ref opts 'format))) - (format #t "~a~%~a~%" path (fmt hash)) - #t)) + (with-error-handling + (let* ((opts (parse-options)) + (store (open-connection)) + (arg (assq-ref opts 'argument)) + (uri (or (string->uri arg) + (leave (_ "guix-download: ~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)))))) + (hash (call-with-input-file + (or path + (leave (_ "guix-download: ~a: download failed~%") + arg)) + (compose sha256 get-bytevector-all))) + (fmt (assq-ref opts 'format))) + (format #t "~a~%~a~%" path (fmt hash)) + #t))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ccca614d88..6de2f1beb6 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -39,6 +39,7 @@ #:use-module (gnu packages) #:use-module ((gnu packages base) #:select (guile-final)) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:use-module (guix gnu-maintenance) #:export (guix-package)) (define %store @@ -266,6 +267,47 @@ matching packages." (assoc-ref (derivation-outputs drv) sub-drv)))) `(,name ,out)))))) +(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))) + +(define (check-package-freshness package) + "Check whether PACKAGE has a newer version available upstream, and report +it." + ;; TODO: Automatically inject the upstream version when desired. + + (catch #t + (lambda () + (when (false-if-exception (gnu-package? package)) + (let ((name (package-name package)) + (full-name (package-full-name package))) + (match (waiting (latest-release name) + (_ "looking for the latest release of GNU ~a...") name) + ((latest-version . _) + (when (version>? latest-version full-name) + (format (current-error-port) + (_ "~a: note: using ~a \ +but ~a is available upstream~%") + (location->string (package-location package)) + full-name latest-version))) + (_ #t))))) + (lambda (key . args) + ;; Silently ignore networking errors rather than preventing + ;; installation. + (case key + ((getaddrinfo-error ftp-error) #f) + (else (apply throw key args)))))) + ;;; ;;; Command-line options. @@ -510,6 +552,44 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) ,path ,(canonicalize-deps deps)))) + (define (show-what-to-remove/install remove install dry-run?) + ;; Tell the user what's going to happen in high-level terms. + ;; TODO: Report upgrades more clearly. + (match remove + (((name version _ path _) ..1) + (let ((len (length name)) + (remove (map (cut format #f " ~a-~a\t~a" <> <> <>) + name version path))) + (if dry-run? + (format (current-error-port) + (N_ "The following package would be removed:~% ~{~a~%~}~%" + "The following packages would be removed:~% ~{~a~%~}~%" + len) + remove) + (format (current-error-port) + (N_ "The following package will be removed:~% ~{~a~%~}~%" + "The following packages will be removed:~% ~{~a~%~}~%" + len) + remove)))) + (_ #f)) + (match install + (((name version _ path _) ..1) + (let ((len (length name)) + (install (map (cut format #f " ~a-~a\t~a" <> <> <>) + name version path))) + (if dry-run? + (format (current-error-port) + (N_ "The following package would be installed:~% ~{~a~%~}~%" + "The following packages would be installed:~% ~{~a~%~}~%" + len) + install) + (format (current-error-port) + (N_ "The following package will be installed:~% ~{~a~%~}~%" + "The following packages will be installed:~% ~{~a~%~}~%" + len) + install)))) + (_ #f))) + ;; First roll back if asked to. (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) (begin @@ -547,6 +627,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) ((name version sub-drv (? package? package) (deps ...)) + (check-package-freshness package) (package-derivation (%store) package)) (_ #f)) install)) @@ -576,6 +657,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) package) (_ #f)) opts)) + (remove* (filter-map (cut assoc <> installed) remove)) (packages (append install* (fold (lambda (package result) (match package @@ -587,6 +669,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (when (equal? profile %current-profile) (ensure-default-profile)) + (show-what-to-remove/install remove* install* dry-run?) (show-what-to-build (%store) drv dry-run?) (or dry-run? @@ -669,8 +752,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (let ((opts (parse-options))) (or (process-query opts) - (parameterize ((%store (open-connection))) - (with-error-handling + (with-error-handling + (parameterize ((%store (open-connection))) (parameterize ((%guile-for-build (package-derivation (%store) (if (assoc-ref opts 'bootstrap?) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 942bf501c5..bc72dc4088 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -194,9 +194,9 @@ Download and deploy the latest version of Guix.\n")) (leave (_ "~A: unexpected argument~%") arg)) %default-options)) - (let ((opts (parse-options)) - (store (open-connection))) - (with-error-handling + (with-error-handling + (let ((opts (parse-options)) + (store (open-connection))) (let ((tarball (download-and-store store))) (unless tarball (leave (_ "failed to download up-to-date source, exiting\n"))) diff --git a/guix/snix.scm b/guix/snix.scm index 3a470b9b8b..0c19fecb28 100644 --- a/guix/snix.scm +++ b/guix/snix.scm @@ -277,7 +277,7 @@ ATTRIBUTE is true, only that attribute is considered." %nix-instantiate "--strict" "--eval-only" "--xml" ;; Pass a dummy `crossSystem' argument so that `buildInputs' and - ;; `buildNativeInputs' are not coalesced. + ;; `nativeBuildInputs' are not coalesced. ;; XXX: This is hacky and has other problems. ;"--arg" "crossSystem" cross-system @@ -423,12 +423,15 @@ location of DERIVATION." (build-system gnu-build-system) ;; When doing a native Nixpkgs build, `buildInputs' is empty and - ;; everything is in `buildNativeInputs'. So we can't distinguish + ;; everything is in `nativeBuildInputs'. So we can't distinguish ;; between both, here. + ;; + ;; Note that `nativeBuildInputs' was renamed from + ;; `buildNativeInputs' in Nixpkgs sometime around March 2013. ,@(maybe-inputs 'inputs - (convert-inputs "buildNativeInputs")) + (convert-inputs "nativeBuildInputs")) ,@(maybe-inputs 'propagated-inputs - (convert-inputs "propagatedBuildNativeInputs")) + (convert-inputs "propagatedNativeBuildInputs")) (home-page ,(and=> (find-attribute-by-name "homepage" meta) attribute-value)) diff --git a/guix/store.scm b/guix/store.scm index 80b36daf93..4d078c5899 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -39,6 +39,9 @@ nix-server-socket &nix-error nix-error? + &nix-connection-error nix-connection-error? + nix-connection-error-file + nix-connection-error-code &nix-protocol-error nix-protocol-error? nix-protocol-error-message nix-protocol-error-status @@ -231,8 +234,19 @@ (define write-store-path-list write-string-list) (define read-store-path-list read-string-list) -(define (write-contents file p) - "Write the contents of FILE to output port P." +(define (write-contents file p size) + "Write SIZE bytes from FILE to output port P." + (define (call-with-binary-input-file file proc) + ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus + ;; avoids any initial buffering. Disable file name canonicalization to + ;; avoid stat'ing like crazy. + (with-fluids ((%file-port-name-canonicalization #f)) + (let ((port (open-file file "rb"))) + (catch #t (cut proc port) + (lambda args + (close-port port) + (apply throw args)))))) + (define (dump in size) (define buf-size 65536) (define buf (make-bytevector buf-size)) @@ -247,13 +261,14 @@ (put-bytevector p buf 0 read) (loop (- left read)))))))) - (let ((size (stat:size (lstat file)))) - (write-string "contents" p) - (write-long-long size p) - (call-with-input-file file - (lambda (p) - (dump p size))) - (write-padding size p))) + (write-string "contents" p) + (write-long-long size p) + (call-with-binary-input-file file + ;; Use `sendfile' when available (Guile 2.0.8+). + (if (compile-time-value (defined? 'sendfile)) + (cut sendfile p <> size 0) + (cut dump <> size))) + (write-padding size p)) (define (write-file f p) (define %archive-version-1 "nix-archive-1") @@ -271,7 +286,7 @@ (begin (write-string "executable" p) (write-string "" p))) - (write-contents f p)) + (write-contents f p (stat:size s))) ((directory) (write-string "type" p) (write-string "directory" p) @@ -373,6 +388,11 @@ (define-condition-type &nix-error &error nix-error?) +(define-condition-type &nix-connection-error &nix-error + nix-connection-error? + (file nix-connection-error-file) + (errno nix-connection-error-code)) + (define-condition-type &nix-protocol-error &nix-error nix-protocol-error? (message nix-protocol-error-message) @@ -392,7 +412,15 @@ operate, should the disk become full. Return a server object." ;; Enlarge the receive buffer. (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) - (connect s a) + (catch 'system-error + (cut connect s a) + (lambda args + ;; Translate the error to something user-friendly. + (let ((errno (system-error-errno args))) + (raise (condition (&nix-connection-error + (file file) + (errno errno))))))) + (write-int %worker-magic-1 s) (let ((r (read-int s))) (and (eqv? r %worker-magic-2) diff --git a/guix/ui.scm b/guix/ui.scm index 03d881a428..94f0825a0a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -111,6 +111,10 @@ General help using GNU software: <http://www.gnu.org/gethelp/>")) (leave (_ "~a:~a:~a: error: 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~%") + (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~%") |