diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/scons.scm | 134 | ||||
| -rw-r--r-- | guix/build/compile.scm | 6 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 2 | ||||
| -rw-r--r-- | guix/build/scons-build-system.scm | 65 | ||||
| -rw-r--r-- | guix/build/union.scm | 11 | ||||
| -rw-r--r-- | guix/gexp.scm | 55 | ||||
| -rw-r--r-- | guix/git.scm | 12 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 10 | ||||
| -rw-r--r-- | guix/packages.scm | 1 | ||||
| -rw-r--r-- | guix/profiles.scm | 147 | ||||
| -rw-r--r-- | guix/progress.scm | 69 | ||||
| -rw-r--r-- | guix/records.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 85 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 106 | ||||
| -rw-r--r-- | guix/ssh.scm | 2 | ||||
| -rw-r--r-- | guix/ui.scm | 50 | ||||
| -rw-r--r-- | guix/utils.scm | 5 | ||||
| -rw-r--r-- | guix/zlib.scm | 46 |
23 files changed, 596 insertions, 259 deletions
diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm new file mode 100644 index 0000000000..da09cc7ded --- /dev/null +++ b/guix/build-system/scons.scm @@ -0,0 +1,134 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; 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 scons) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:export (%scons-build-system-modules + scons-build + scons-build-system)) + +;; Commentary: +;; +;; Standard build procedure for applications using SCons. This is implemented +;; as an extension of 'gnu-build-system'. +;; +;; Code: + +(define %scons-build-system-modules + ;; Build-side modules imported by default. + `((guix build scons-build-system) + ,@%gnu-build-system-modules)) + +(define (default-scons) + "Return the default SCons package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((python (resolve-interface '(gnu packages python)))) + (module-ref python 'scons))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (scons (default-scons)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:scons #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("scons" ,scons) + ,@native-inputs)) + (outputs outputs) + (build scons-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (scons-build store name inputs + #:key + (tests? #t) + (scons-flags ''()) + (test-target "test") + (phases '(@ (guix build scons-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %scons-build-system-modules) + (modules '((guix build scons-build-system) + (guix build utils)))) + "Build SOURCE using SCons, and with INPUTS. This assumes that SOURCE +provides a 'SConstruct' file as its build system." + (define builder + `(begin + (use-modules ,@modules) + (scons-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:scons-flags ,scons-flags + #:system ,system + #:test-target ,test-target + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define scons-build-system + (build-system + (name 'scons) + (description "The standard SCons build system") + (lower lower))) + +;;; scons.scm ends here diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 8b5a2faf84..1bd8c60fe5 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -163,7 +163,11 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." ;; compile files in parallel. (compile #f) - (n-par-for-each workers build files) + ;; XXX: Don't use too many workers to work around the insane memory + ;; requirements of the compiler in Guile 2.2.2: + ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>. + (n-par-for-each (min workers 8) build files) + (unless (zero? total) (report-compilation #f total total))))) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 5c96fe9067..b4160fba1b 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -82,7 +82,7 @@ definitions for all the SEARCH-PATHS." # for this profile. You may want to define the 'GUIX_PROFILE' environment # variable to point to the \"visible\" name of the profile, like this: # -# GUIX_PROFILE=/path/to/profile \\ +# GUIX_PROFILE=/path/to/profile ; \\ # source /path/to/profile/etc/profile # # When GUIX_PROFILE is undefined, the various environment variables refer diff --git a/guix/build/scons-build-system.scm b/guix/build/scons-build-system.scm new file mode 100644 index 0000000000..a8760968d8 --- /dev/null +++ b/guix/build/scons-build-system.scm @@ -0,0 +1,65 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; 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 scons-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:export (%standard-phases + scons-build)) + +;; Commentary: +;; +;; Builder-side code of the SCons build system. +;; +;; Code: + +(define* (build #:key outputs (scons-flags '()) (parallel-build? #t) #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (mkdir-p out) + (zero? (apply system* "scons" + (append (if parallel-build? + (list "-j" (number->string + (parallel-job-count))) + (list)) + scons-flags))))) + +(define* (check #:key tests? test-target (scons-flags '()) #:allow-other-keys) + "Run the test suite of a given SCons application." + (cond (tests? + (zero? (apply system* "scons" test-target scons-flags))) + (else + (format #t "test suite not run~%") + #t))) + +(define* (install #:key outputs (scons-flags '()) #:allow-other-keys) + "Install a given SCons application." + (zero? (apply system* "scons" "install" scons-flags))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + +(define* (scons-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build a given SCons application, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; scons-build-system.scm ends here diff --git a/guix/build/union.scm b/guix/build/union.scm index 18167fa3e3..256123c566 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; @@ -78,11 +78,12 @@ identical, #f otherwise." (define* (union-build output inputs #:key (log-port (current-error-port)) - (create-all-directories? #f)) + (create-all-directories? #f) + (symlink symlink)) "Build in the OUTPUT directory a symlink tree that is the union of all the -INPUTS. As a special case, if CREATE-ALL-DIRECTORIES?, creates the -subdirectories in the output directory to make sure the caller can modify them -later." +INPUTS, using SYMLINK to create symlinks. As a special case, if +CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to +make sure the caller can modify them later." (define (symlink* input output) (format log-port "`~a' ~~> `~a'~%" input output) diff --git a/guix/gexp.scm b/guix/gexp.scm index b9525603ee..1929947d95 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -564,6 +564,7 @@ names and file names suitable for the #:allowed-references argument to allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) + deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When @@ -599,6 +600,9 @@ refer to. Any reference to another store item will lead to a build error. Similarly for DISALLOWED-REFERENCES, which can list items that must not be referenced by the outputs. +DEPRECATION-WARNINGS determines whether to show deprecation warnings while +compiling modules. It can be #f, #t, or 'detailed. + The other arguments are as for 'derivation'." (define %modules (delete-duplicates @@ -648,7 +652,9 @@ The other arguments are as for 'derivation'." (compiled-modules %modules #:system system #:module-path module-path - #:guile guile-for-build) + #:guile guile-for-build + #:deprecation-warnings + deprecation-warnings) (return #f))) (graphs (if references-graphs (lower-reference-graphs references-graphs @@ -1023,7 +1029,8 @@ last one is created from the given <scheme-file> object." #:key (name "module-import-compiled") (system (%current-system)) (guile (%guile-for-build)) - (module-path %load-path)) + (module-path %load-path) + (deprecation-warnings #f)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." @@ -1073,7 +1080,15 @@ they can refer to each other." (gexp->derivation name build #:system system #:guile-for-build guile - #:local-build? #t))) + #:local-build? #t + #:env-vars + (case deprecation-warnings + ((#f) + '(("GUILE_WARN_DEPRECATED" . "no"))) + ((detailed) + '(("GUILE_WARN_DEPRECATED" . "detailed"))) + (else + '()))))) ;;; @@ -1081,10 +1096,12 @@ they can refer to each other." ;;; (define (default-guile) - ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) + ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for + ;; programs returned by 'program-file' and we don't want to keep references + ;; to several Guile packages). This module must not refer to (gnu …) ;; modules directly, to avoid circular dependencies, hence this hack. - (module-ref (resolve-interface '(gnu packages commencement)) - 'guile-final)) + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-2.2)) (define (load-path-expression modules) "Return as a monadic value a gexp that sets '%load-path' and @@ -1204,13 +1221,30 @@ This yields an 'etc' directory containing these two files." (ungexp target)))))) files)))))) -(define (directory-union name things) +(define* (directory-union name things + #:key (copy? #f) (quiet? #f)) "Return a directory that is the union of THINGS, where THINGS is a list of file-like objects denoting directories. For example: (directory-union \"guile+emacs\" (list guile emacs)) -yields a directory that is the union of the 'guile' and 'emacs' packages." +yields a directory that is the union of the 'guile' and 'emacs' packages. + +When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET? +is true, the derivation will not print anything." + (define symlink + (if copy? + (gexp (lambda (old new) + (if (file-is-directory? old) + (symlink old new) + (copy-file old new)))) + (gexp symlink))) + + (define log-port + (if quiet? + (gexp (%make-void-port "w")) + (gexp (current-error-port)))) + (match things ((one) ;; Only one thing; return it. @@ -1221,7 +1255,10 @@ yields a directory that is the union of the 'guile' and 'emacs' packages." (gexp (begin (use-modules (guix build union)) (union-build (ungexp output) - '(ungexp things))))))))) + '(ungexp things) + + #:log-port (ungexp log-port) + #:symlink (ungexp symlink))))))))) ;;; diff --git a/guix/git.scm b/guix/git.scm index 7a83b56216..fc41e2ace3 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -80,11 +80,17 @@ of SHA1 string." "-" (string-take sha1 7))) (define* (copy-to-store store cache-directory #:key url repository) - "Copy items in cache-directory to store. URL and REPOSITORY are used -to forge store directory name." + "Copy CACHE-DIRECTORY recursively to STORE. URL and REPOSITORY are used to +create the store directory name." + (define (dot-git? file stat) + (and (string=? (basename file) ".git") + (eq? 'directory (stat:type stat)))) + (let* ((commit (repository->head-sha1 repository)) (name (url+commit->name url commit))) - (values (add-to-store store name #t "sha256" cache-directory) commit))) + (values (add-to-store store name #t "sha256" cache-directory + #:select? (negate dot-git?)) + commit))) (define (switch-to-ref repository ref) "Switch to REPOSITORY's branch, commit or tag specified by REF." diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 0de36f2f71..00e80bc79f 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -335,9 +335,6 @@ return the corresponding signature URL, or #f it signatures are unavailable." (if (version>? (upstream-source-version a) (upstream-source-version b)) a b)) - (define contains-digit? - (cut string-any char-set:digit <>)) - (define patch-directory-name? ;; Return #t for patch directory names such as 'bash-4.2-patches'. (cut string-suffix? "patches" <>)) @@ -361,8 +358,7 @@ return the corresponding signature URL, or #f it signatures are unavailable." (result #f)) (let* ((entries (ftp-list conn directory)) - ;; Filter out sub-directories that do not contain digits---e.g., - ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32" + ;; Filter out things like /gnupg/patches. Filter out "w32" ;; directories as found on ftp.gnutls.org. (subdirs (filter-map (match-lambda (((? patch-directory-name? dir) @@ -370,8 +366,8 @@ return the corresponding signature URL, or #f it signatures are unavailable." #f) (("w32" 'directory . _) #f) - (((? contains-digit? dir) 'directory . _) - (and (keep-file? dir) dir)) + ((directory 'directory . _) + directory) (_ #f)) entries)) diff --git a/guix/packages.scm b/guix/packages.scm index 35f9b685a3..d3f3cf0fdd 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -609,6 +609,7 @@ specifies modules in scope when evaluating SNIPPET." (gexp->derivation name build #:graft? #f #:system system + #:deprecation-warnings #t ;to avoid a rebuild #:guile-for-build guile-for-build)))) (define (transitive-inputs inputs) diff --git a/guix/profiles.scm b/guix/profiles.scm index 51c330b323..07fe2faa3c 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1118,82 +1118,80 @@ the entries in MANIFEST." (module-ref (resolve-interface '(gnu packages man)) 'man-db)) (define build - #~(begin - (use-modules (guix build utils) - (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-26)) - - (define entries - (filter-map (lambda (directory) - (let ((man (string-append directory "/share/man"))) - (and (directory-exists? man) - man))) - '#$(manifest-inputs manifest))) - - (define manpages-collection-dir - (string-append (getenv "PWD") "/manpages-collection")) - - (define man-directory - (string-append #$output "/share/man")) - - (define (get-manpage-tail-path manpage-path) - (let ((index (string-contains manpage-path "/share/man/"))) - (unless index - (error "Manual path doesn't contain \"/share/man/\":" - manpage-path)) - (string-drop manpage-path (+ index (string-length "/share/man/"))))) - - (define (populate-manpages-collection-dir entries) - (let ((manpages (append-map (cut find-files <> #:stat stat) entries))) - (for-each (lambda (manpage) - (let* ((dest-file (string-append - manpages-collection-dir "/" - (get-manpage-tail-path manpage)))) - (mkdir-p (dirname dest-file)) - (catch 'system-error - (lambda () - (symlink manpage dest-file)) - (lambda args - ;; Different packages may contain the same - ;; manpage. Simply ignore the symlink error. - #t)))) - manpages))) - - (mkdir-p manpages-collection-dir) - (populate-manpages-collection-dir entries) - - ;; Create a mandb config file which contains a custom made - ;; manpath. The associated catpath is the location where the database - ;; gets generated. - (copy-file #+(file-append man-db "/etc/man_db.conf") - "man_db.conf") - (substitute* "man_db.conf" - (("MANDB_MAP /usr/man /var/cache/man/fsstnd") - (string-append "MANDB_MAP " manpages-collection-dir " " - man-directory))) - - (mkdir-p man-directory) - (setenv "MANPATH" (string-join entries ":")) - - (format #t "Creating manual page database for ~a packages... " - (length entries)) - (force-output) - (let* ((start-time (current-time)) - (exit-status (system* #+(file-append man-db "/bin/mandb") - "--quiet" "--create" - "-C" "man_db.conf")) - (duration (time-difference (current-time) start-time))) - (format #t "done in ~,3f s~%" - (+ (time-second duration) - (* (time-nanosecond duration) (expt 10 -9)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-26)) + + (define entries + (filter-map (lambda (directory) + (let ((man (string-append directory "/share/man"))) + (and (directory-exists? man) + man))) + '#$(manifest-inputs manifest))) + + (define manpages-collection-dir + (string-append (getenv "PWD") "/manpages-collection")) + + (define man-directory + (string-append #$output "/share/man")) + + (define (get-manpage-tail-path manpage-path) + (let ((index (string-contains manpage-path "/share/man/"))) + (unless index + (error "Manual path doesn't contain \"/share/man/\":" + manpage-path)) + (string-drop manpage-path (+ index (string-length "/share/man/"))))) + + (define (populate-manpages-collection-dir entries) + (let ((manpages (append-map (cut find-files <> #:stat stat) entries))) + (for-each (lambda (manpage) + (let* ((dest-file (string-append + manpages-collection-dir "/" + (get-manpage-tail-path manpage)))) + (mkdir-p (dirname dest-file)) + (catch 'system-error + (lambda () + (symlink manpage dest-file)) + (lambda args + ;; Different packages may contain the same + ;; manpage. Simply ignore the symlink error. + #t)))) + manpages))) + + (mkdir-p manpages-collection-dir) + (populate-manpages-collection-dir entries) + + ;; Create a mandb config file which contains a custom made + ;; manpath. The associated catpath is the location where the database + ;; gets generated. + (copy-file #+(file-append man-db "/etc/man_db.conf") + "man_db.conf") + (substitute* "man_db.conf" + (("MANDB_MAP /usr/man /var/cache/man/fsstnd") + (string-append "MANDB_MAP " manpages-collection-dir " " + man-directory))) + + (mkdir-p man-directory) + (setenv "MANPATH" (string-join entries ":")) + + (format #t "Creating manual page database for ~a packages... " + (length entries)) (force-output) - (zero? exit-status)))) + (let* ((start-time (current-time)) + (exit-status (system* #+(file-append man-db "/bin/mandb") + "--quiet" "--create" + "-C" "man_db.conf")) + (duration (time-difference (current-time) start-time))) + (format #t "done in ~,3f s~%" + (+ (time-second duration) + (* (time-nanosecond duration) (expt 10 -9)))) + (force-output) + (zero? exit-status))))) (gexp->derivation "manual-database" build - #:modules '((guix build utils) - (srfi srfi-19) - (srfi srfi-26)) #:local-build? #t)) (define %default-profile-hooks @@ -1294,6 +1292,9 @@ are cross-built for TARGET." #:system system #:target target + ;; Don't complain about _IO* on Guile 2.2. + #:env-vars '(("GUILE_WARN_DEPRECATED" . "no")) + ;; Not worth offloading. #:local-build? #t diff --git a/guix/progress.scm b/guix/progress.scm index beca2c22a6..0ca5c08782 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,8 +31,13 @@ progress-reporter? call-with-progress-reporter + start-progress-reporter! + stop-progress-reporter! + progress-reporter-report! + progress-reporter/silent progress-reporter/file + progress-reporter/bar byte-count->string current-terminal-columns @@ -58,6 +64,24 @@ stopped." (($ <progress-reporter> start report stop) (dynamic-wind start (lambda () (proc report)) stop)))) +(define (start-progress-reporter! reporter) + "Low-level procedure to start REPORTER." + (match reporter + (($ <progress-reporter> start report stop) + (start)))) + +(define (progress-reporter-report! reporter) + "Low-level procedure to lead REPORTER to emit a report." + (match reporter + (($ <progress-reporter> start report stop) + (report)))) + +(define (stop-progress-reporter! reporter) + "Low-level procedure to stop REPORTER." + (match reporter + (($ <progress-reporter> start report stop) + (stop)))) + (define progress-reporter/silent (make-progress-reporter noop noop noop)) @@ -146,13 +170,19 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (define* (progress-bar % #:optional (bar-width 20)) "Return % as a string representing an ASCII-art progress bar. The total width of the bar is BAR-WIDTH." - (let* ((fraction (/ % 100)) + (let* ((bar-width (max 3 (- bar-width 2))) + (fraction (/ % 100)) (filled (inexact->exact (floor (* fraction bar-width)))) (empty (- bar-width filled))) (format #f "[~a~a]" (make-string filled #\#) (make-string empty #\space)))) +(define (erase-in-line port) + "Write an ANSI erase-in-line sequence to PORT to erase the whole line and +move the cursor to the beginning of the line." + (display "\r\x1b[K" port)) + (define* (progress-reporter/file file size #:optional (log-port (current-output-port)) #:key (abbreviation basename)) @@ -176,7 +206,7 @@ ABBREVIATION used to shorten FILE for display." (byte-count->string throughput) (seconds->string elapsed) (progress-bar %) %))) - (display "\r\x1b[K" log-port) + (erase-in-line log-port) (display (string-pad-middle left right (current-terminal-columns)) log-port) @@ -188,7 +218,7 @@ ABBREVIATION used to shorten FILE for display." (byte-count->string throughput) (seconds->string elapsed) (byte-count->string transferred)))) - (display "\r\x1b[K" log-port) + (erase-in-line log-port) (display (string-pad-middle left right (current-terminal-columns)) log-port) @@ -206,6 +236,39 @@ ABBREVIATION used to shorten FILE for display." ;; Don't miss the last report. (stop render)))) +(define* (progress-reporter/bar total + #:optional + (prefix "") + (port (current-error-port))) + "Return a reporter that shows a progress bar every time one of the TOTAL +tasks is performed. Write PREFIX at the beginning of the line." + (define done 0) + + (define (report-progress) + (set! done (+ 1 done)) + (unless (> done total) + (let* ((ratio (* 100. (/ done total)))) + (erase-in-line port) + (if (string-null? prefix) + (display (progress-bar ratio (current-terminal-columns)) port) + (let ((width (- (current-terminal-columns) + (string-length prefix) 3))) + (display prefix port) + (display " " port) + (display (progress-bar ratio width) port))) + (force-output port)))) + + (progress-reporter + (start (lambda () + (set! done 0))) + (report report-progress) + (stop (lambda () + (erase-in-line port) + (unless (string-null? prefix) + (display prefix port) + (newline port)) + (force-output port))))) + ;; TODO: replace '(@ (guix build utils) dump-port))'. (define* (dump-port* in out #:key (buffer-size 16384) diff --git a/guix/records.scm b/guix/records.scm index 1f00e16603..c02395f2ae 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -81,7 +81,7 @@ fields, and DELAYED is the list of identifiers of delayed fields." (record-error 'name s "extraneous field initializers ~a" unexpected))) - #`(make-struct type 0 + #`(make-struct/no-tail type #,@(map (lambda (field index) (or (field-inherited-value field) (if (innate-field? field) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0d69218338..e1b7feecfa 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -586,7 +586,7 @@ message if any test fails." store (if bootstrap? %bootstrap-guile - (canonical-package guile-2.0))))) + (canonical-package guile-2.2))))) (run-with-store store ;; Containers need a Bourne shell at /bin/sh. (mlet* %store-monad ((bash (environment-bash container? diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8840b1acb5..1b43b0a63c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -587,24 +587,49 @@ from ~a") (package-home-page package)) 'home-page))))) +(define %distro-directory + (dirname (search-path %load-path "gnu.scm"))) + (define (check-patch-file-names package) "Emit a warning if the patches requires by PACKAGE are badly named or if the patch could not be found." (guard (c ((message-condition? c) ;raised by 'search-patch' (emit-warning package (condition-message c) 'patch-file-names))) + (define patches + (or (and=> (package-source package) origin-patches) + '())) + (unless (every (match-lambda ;patch starts with package name? ((? string? patch) (and=> (string-contains (basename patch) (package-name package)) zero?)) (_ #f)) ;must be an <origin> or something like that. - (or (and=> (package-source package) origin-patches) - '())) + patches) (emit-warning package (G_ "file names of patches should start with the package name") - 'patch-file-names)))) + 'patch-file-names)) + + ;; Check whether we're reaching tar's maximum file name length. + (let ((prefix (string-length %distro-directory)) + (margin (string-length "guix-0.13.0-10-123456789/")) + (max 99)) + (for-each (match-lambda + ((? string? patch) + (when (> (+ margin (if (string-prefix? %distro-directory + patch) + (- (string-length patch) prefix) + (string-length patch))) + max) + (emit-warning + package + (format #f (G_ "~a: file name is too long") + (basename patch)) + 'patch-file-names))) + (_ #f)) + patches)))) (define (escape-quotes str) "Replace any quote character in STR by an escaped quote character." diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 6a2485a007..ebd0bf783d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -118,7 +118,7 @@ determined." (catch #t (lambda () ;; Avoid ABI incompatibility with the <build-machine> record. - (set! %fresh-auto-compile #t) + ;; (set! %fresh-auto-compile #t) (save-module-excursion (lambda () diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f972ca2ef7..0a4a07ae2a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -49,7 +49,7 @@ #:use-module (srfi srfi-37) #:use-module (gnu packages) #:autoload (gnu packages base) (canonical-package) - #:autoload (gnu packages guile) (guile-2.0) + #:autoload (gnu packages guile) (guile-2.2) #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:export (build-and-use-profile delete-generations @@ -918,5 +918,5 @@ processed, #f otherwise." (%store) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile - (canonical-package guile-2.0))))) + (canonical-package guile-2.2))))) (process-actions (%store) opts))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2400198000..be0c168444 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -25,7 +25,6 @@ #:use-module (guix config) #:use-module (guix packages) #:use-module (guix derivations) - #:use-module (guix download) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) @@ -39,14 +38,9 @@ #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) - #:use-module (gnu packages compression) - #:use-module (gnu packages gnupg) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (guix-pull)) @@ -281,7 +275,7 @@ certificates~%")) store (if (assoc-ref opts 'bootstrap?) %bootstrap-guile - (canonical-package guile-2.0))))) + (canonical-package guile-2.2))))) (run-with-store store (build-and-install checkout (config-directory) #:commit commit diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e50f1d8ac7..e2ff42693f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -36,6 +36,8 @@ #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix build utils) + #:use-module (guix progress) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (gnu build install) #:autoload (gnu build file-systems) (find-partition-by-label find-partition-by-uuid) @@ -107,47 +109,54 @@ BODY..., and restore them." (store-lift topologically-sorted)) -(define* (copy-item item target +(define* (copy-item item references target #:key (log-port (current-error-port))) - "Copy ITEM to the store under root directory TARGET and register it." - (mlet* %store-monad ((refs (references* item))) - (let ((dest (string-append target item)) - (state (string-append target "/var/guix"))) - (format log-port "copying '~a'...~%" item) - - ;; Remove DEST if it exists to make sure that (1) we do not fail badly - ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and - ;; (2) we end up with the right contents. - (when (file-exists? dest) - (delete-file-recursively dest)) - - (copy-recursively item dest - #:log (%make-void-port "w")) - - ;; Register ITEM; as a side-effect, it resets timestamps, etc. - ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid - ;; reproducing the user's current settings; see - ;; <http://bugs.gnu.org/18049>. - (unless (register-path item - #:prefix target - #:state-directory state - #:references refs) - (leave (G_ "failed to register '~a' under '~a'~%") - item target)) - - (return #t)))) + "Copy ITEM to the store under root directory TARGET and register it with +REFERENCES as its set of references." + (let ((dest (string-append target item)) + (state (string-append target "/var/guix"))) + (format log-port "copying '~a'...~%" item) + + ;; Remove DEST if it exists to make sure that (1) we do not fail badly + ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and + ;; (2) we end up with the right contents. + (when (file-exists? dest) + (delete-file-recursively dest)) + + (copy-recursively item dest + #:log (%make-void-port "w")) + + ;; Register ITEM; as a side-effect, it resets timestamps, etc. + ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid + ;; reproducing the user's current settings; see + ;; <http://bugs.gnu.org/18049>. + (unless (register-path item + #:prefix target + #:state-directory state + #:references references) + (leave (G_ "failed to register '~a' under '~a'~%") + item target)))) (define* (copy-closure item target #:key (log-port (current-error-port))) "Copy ITEM and all its dependencies to the store under root directory TARGET, and register them." - (mlet* %store-monad ((refs (references* item)) - (to-copy (topologically-sorted* - (delete-duplicates (cons item refs) - string=?)))) - (sequence %store-monad - (map (cut copy-item <> target #:log-port log-port) - to-copy)))) + (mlet* %store-monad ((to-copy (topologically-sorted* (list item))) + (refs (mapm %store-monad references* to-copy))) + (define progress-bar + (progress-reporter/bar (length to-copy) + (format #f (G_ "copying to '~a'...") + target))) + + (call-with-progress-reporter progress-bar + (lambda (report) + (let ((void (%make-void-port "w"))) + (for-each (lambda (item refs) + (copy-item item refs target #:log-port void) + (report)) + to-copy refs)))) + + (return *unspecified*))) (define* (install-bootloader installer-drv #:key @@ -667,7 +676,8 @@ and TARGET arguments." (gexp->file "bootloader-installer" (with-imported-modules '((guix build utils)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (ice-9 binary-ports)) (#$installer #$bootloader #$device #$target)))))) (define* (perform-action action os @@ -1095,7 +1105,8 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (current-terminal-columns (terminal-columns))) (process-command command args opts))))) ;;; Local Variables: diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 0d4a7fa26b..2e782e36ce 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -23,10 +23,11 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix progress) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix grafts) - #:use-module (guix build syscalls) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (guix scripts substitute) #:use-module (gnu packages) #:use-module (web uri) @@ -48,42 +49,38 @@ (cons package result)))) '())) +(define (call-with-progress-reporter reporter proc) + "This is a variant of 'call-with-progress-reporter' that works with monadic +scope." + ;; TODO: Move to a more appropriate place. + (with-monad %store-monad + (start-progress-reporter! reporter) + (mlet* %store-monad ((report -> (lambda () + (progress-reporter-report! reporter))) + (result (proc report))) + (stop-progress-reporter! reporter) + (return result)))) + (define* (package-outputs packages #:optional (system (%current-system))) "Return the list of outputs of all of PACKAGES for the given SYSTEM." (let ((packages (filter (cut supported-package? <> system) packages))) - - (define update-progress! - (let ((total (length packages)) - (done 0) - (width (max 10 (- (terminal-columns) 10)))) - (lambda () - (set! done (+ 1 done)) - (let* ((ratio (/ done total 1.)) - (done (inexact->exact (round (* width ratio)))) - (left (- width done))) - (format (current-error-port) "~5,1f% [~a~a]\r" - (* ratio 100.) - (make-string done #\#) - (make-string left #\space)) - (when (>= done total) - (newline (current-error-port))) - (force-output (current-error-port)))))) - (format (current-error-port) (G_ "computing ~h package derivations for ~a...~%") (length packages) system) - (foldm %store-monad - (lambda (package result) - (mlet %store-monad ((drv (package->derivation package system - #:graft? #f))) - (update-progress!) - (match (derivation->output-paths drv) - (((names . items) ...) - (return (append items result)))))) - '() - packages))) + (call-with-progress-reporter (progress-reporter/bar (length packages)) + (lambda (report) + (foldm %store-monad + (lambda (package result) + (mlet %store-monad ((drv (package->derivation package system + #:graft? #f))) + (report) + (match (derivation->output-paths drv) + (((names . items) ...) + (return (append items result)))))) + '() + packages))))) (cond-expand (guile-2.2 @@ -204,31 +201,32 @@ Report the availability of substitutes.\n")) (define (guix-weather . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options) - #:build-options? #f)) - (urls (assoc-ref opts 'substitute-urls)) - (systems (match (filter-map (match-lambda - (('system . system) system) - (_ #f)) - opts) - (() (list (%current-system))) - (systems systems))) - (packages (let ((file (assoc-ref opts 'manifest))) - (if file - (load-manifest file) - (all-packages)))) - (items (with-store store - (parameterize ((%graft? #f)) - (concatenate - (run-with-store store - (mapm %store-monad - (lambda (system) - (package-outputs packages system)) - systems))))))) - (for-each (lambda (server) - (report-server-coverage server items)) - urls)))) + (parameterize ((current-terminal-columns (terminal-columns))) + (let* ((opts (parse-command-line args %options + (list %default-options) + #:build-options? #f)) + (urls (assoc-ref opts 'substitute-urls)) + (systems (match (filter-map (match-lambda + (('system . system) system) + (_ #f)) + opts) + (() (list (%current-system))) + (systems systems))) + (packages (let ((file (assoc-ref opts 'manifest))) + (if file + (load-manifest file) + (all-packages)))) + (items (with-store store + (parameterize ((%graft? #f)) + (concatenate + (run-with-store store + (mapm %store-monad + (lambda (system) + (package-outputs packages system)) + systems))))))) + (for-each (lambda (server) + (report-server-coverage server items)) + urls))))) ;;; Local Variables: ;;; eval: (put 'let/time 'scheme-indent-function 1) diff --git a/guix/ssh.scm b/guix/ssh.scm index 32cf6e464b..7b33ef5a3b 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -18,7 +18,7 @@ (define-module (guix ssh) #:use-module (guix store) - #:use-module ((guix ui) #:select (G_ N_)) + #:use-module (guix i18n) #:use-module (ssh session) #:use-module (ssh auth) #:use-module (ssh key) diff --git a/guix/ui.scm b/guix/ui.scm index 0fc5ab63ad..e40fe576ba 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -28,6 +28,7 @@ (define-module (guix ui) #:use-module (guix i18n) #:use-module (guix gexp) + #:use-module (guix sets) #:use-module (guix utils) #:use-module (guix store) #:use-module (guix config) @@ -194,7 +195,7 @@ messages." (catch #t (lambda () ;; XXX: Force a recompilation to avoid ABI issues. - (set! %fresh-auto-compile #t) + ;; (set! %fresh-auto-compile #t) (set! %load-should-auto-compile #t) (save-module-excursion @@ -253,8 +254,9 @@ VARIABLE and return it, or #f if none was found." (_ #t))) (_ #f))) - (let loop ((modules (list (resolve-module '() #f #f #:ensure #f))) - (suggestions '())) + (let loop ((modules (list (resolve-module '() #f #f #:ensure #f))) + (suggestions '()) + (visited (setq))) (match modules (() ;; Pick the "best" suggestion. @@ -262,16 +264,19 @@ VARIABLE and return it, or #f if none was found." (() #f) ((first _ ...) first))) ((head tail ...) - (let ((next (append tail - (hash-map->list (lambda (name module) - module) - (module-submodules head))))) - (match (module-local-variable head variable) - (#f (loop next suggestions)) - (_ - (match (module-name head) - (('gnu _ ...) head) ;must be that one - (_ (loop next (cons head suggestions))))))))))) + (if (set-contains? visited head) + (loop tail suggestions visited) + (let ((visited (set-insert head visited)) + (next (append tail + (hash-map->list (lambda (name module) + module) + (module-submodules head))))) + (match (module-local-variable head variable) + (#f (loop next suggestions visited)) + (_ + (match (module-name head) + (('gnu _ ...) head) ;must be that one + (_ (loop next (cons head suggestions) visited))))))))))) (define* (display-hint message #:optional (port (current-error-port))) "Display MESSAGE, a l10n message possibly containing Texinfo markup, to @@ -308,7 +313,7 @@ ARGS is the list of arguments received by the 'throw' handler." (#f (display-hint (G_ "Did you forget a @code{use-modules} form?"))) (module - (display-hint (format #f (G_ "Try adding @code{(use-modules ~a)}.") + (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?") (module-name module)))))) (('srfi-34 obj) (if (message-condition? obj) @@ -545,19 +550,24 @@ interpreted." (manifest-entry-version parent)) (report-parent-entries parent)))) - (report-error (G_ "profile contains conflicting entries for ~a:~a~%") + (define (manifest-entry-output* entry) + (match (manifest-entry-output entry) + ("out" "") + (output (string-append ":" output)))) + + (report-error (G_ "profile contains conflicting entries for ~a~a~%") (manifest-entry-name entry) - (manifest-entry-output entry)) - (report-error (G_ " first entry: ~a@~a:~a ~a~%") + (manifest-entry-output* entry)) + (report-error (G_ " first entry: ~a@~a~a ~a~%") (manifest-entry-name entry) (manifest-entry-version entry) - (manifest-entry-output entry) + (manifest-entry-output* entry) (manifest-entry-item entry)) (report-parent-entries entry) - (report-error (G_ " second entry: ~a@~a:~a ~a~%") + (report-error (G_ " second entry: ~a@~a~a ~a~%") (manifest-entry-name conflict) (manifest-entry-version conflict) - (manifest-entry-output conflict) + (manifest-entry-output* conflict) (manifest-entry-item conflict)) (report-parent-entries conflict) (exit 1))) diff --git a/guix/utils.scm b/guix/utils.scm index c0ffed172a..fed31f4ca4 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,6 +76,7 @@ %current-target-system package-name->name+version target-mingw? + target-arm32? version-compare version>? version>=? @@ -467,6 +469,9 @@ a character other than '@'." (and target (string-suffix? "-mingw32" target))) +(define (target-arm32?) + (string-prefix? "arm" (or (%current-target-system) (%current-system)))) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) diff --git a/guix/zlib.scm b/guix/zlib.scm index 955589ab48..3bd0ad86c9 100644 --- a/guix/zlib.scm +++ b/guix/zlib.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -149,31 +149,6 @@ the number of uncompressed bytes written, a strictly positive integer." ;; Z_DEFAULT_COMPRESSION. -1) -(define (close-procedure gzfile port) - "Return a procedure that closes GZFILE, ensuring its underlying PORT is -closed even if closing GZFILE triggers an exception." - (let-syntax ((ignore-EBADF - (syntax-rules () - ((_ exp) - (catch 'system-error - (lambda () - exp) - (lambda args - (unless (= EBADF (system-error-errno args)) - (apply throw args)))))))) - - (lambda () - (catch 'zlib-error - (lambda () - ;; 'gzclose' closes the underlying file descriptor. 'close-port' - ;; calls close(2) and gets EBADF, which we swallow. - (gzclose gzfile) - (ignore-EBADF (close-port port))) - (lambda args - ;; Make sure PORT is closed despite the zlib error. - (ignore-EBADF (close-port port)) - (apply throw args)))))) - (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) "Return an input port that decompresses data read from PORT, a file port. PORT is automatically closed when the resulting port is closed. BUFFER-SIZE @@ -183,7 +158,14 @@ buffered input, which would be lost (and is lost anyway)." (define gzfile (match (drain-input port) ("" ;PORT's buffer is empty - (gzdopen (fileno port) "r")) + ;; 'gzclose' will eventually close the file descriptor beneath PORT. + ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it, + ;; so that's no good; revealed ports are no good either because they + ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after + ;; 'gzclose' doesn't work either because it leads to a race condition + ;; (see <https://bugs.gnu.org/29335>). So we dup and close PORT right + ;; away. + (gzdopen (dup (fileno port)) "r")) (_ ;; This is unrecoverable but it's better than having the buffered input ;; be lost, leading to unclear end-of-file or corrupt-data errors down @@ -197,8 +179,10 @@ buffered input, which would be lost (and is lost anyway)." (unless (= buffer-size %default-buffer-size) (gzbuffer! gzfile buffer-size)) + (close-port port) ;we no longer need it (make-custom-binary-input-port "gzip-input" read! #f #f - (close-procedure gzfile port))) + (lambda () + (gzclose gzfile)))) (define* (make-gzip-output-port port #:key @@ -210,7 +194,7 @@ port is closed." (define gzfile (begin (force-output port) ;empty PORT's buffer - (gzdopen (fileno port) + (gzdopen (dup (fileno port)) (string-append "w" (number->string level))))) (define (write! bv start count) @@ -219,8 +203,10 @@ port is closed." (unless (= buffer-size %default-buffer-size) (gzbuffer! gzfile buffer-size)) + (close-port port) (make-custom-binary-output-port "gzip-output" write! #f #f - (close-procedure gzfile port))) + (lambda () + (gzclose gzfile)))) (define* (call-with-gzip-input-port port proc #:key (buffer-size %default-buffer-size)) |