diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/scons.scm | 2 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 23 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 27 | ||||
| -rw-r--r-- | guix/channels.scm | 269 | ||||
| -rw-r--r-- | guix/discovery.scm | 28 | ||||
| -rw-r--r-- | guix/import/github.scm | 4 | ||||
| -rw-r--r-- | guix/inferior.scm | 33 | ||||
| -rw-r--r-- | guix/profiles.scm | 50 | ||||
| -rw-r--r-- | guix/profiling.scm | 25 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/edit.scm | 29 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 116 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 18 | ||||
| -rw-r--r-- | guix/self.scm | 8 | ||||
| -rw-r--r-- | guix/serialization.scm | 13 | ||||
| -rw-r--r-- | guix/status.scm | 26 |
18 files changed, 492 insertions, 211 deletions
diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index da09cc7ded..5e76d64180 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -43,7 +43,7 @@ (define (default-scons) "Return the default SCons package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((python (resolve-interface '(gnu packages python)))) + (let ((python (resolve-interface '(gnu packages python-xyz)))) (module-ref python 'scons))) (define* (lower name diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 0c23cd300e..1dc7976879 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,8 +67,14 @@ user-friendly name of the profile is, for instance ~/.guix-profile rather than (define (build-etc/profile output search-paths) "Build the 'OUTPUT/etc/profile' shell file containing environment variable definitions for all the SEARCH-PATHS." - (mkdir-p (string-append output "/etc")) - (call-with-output-file (string-append output "/etc/profile") + (define file + (string-append output "/etc/profile")) + + (mkdir-p (dirname file)) + (when (file-exists? file) + (delete-file file)) + + (call-with-output-file file (lambda (port) ;; The use of $GUIX_PROFILE described below is not great. Another ;; option would have been to use "$1" and have users run: @@ -144,13 +150,22 @@ instead make DIRECTORY a \"real\" directory containing symlinks." create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for -all the variables listed in SEARCH-PATHS." + (define manifest-file + (string-append output "/manifest")) + ;; Make the symlinks. (union-build output inputs #:symlink symlink #:log-port (%make-void-port "w")) + ;; If one of the INPUTS provides a '/manifest' file, delete it. That can + ;; happen if MANIFEST contains something such as a Guix instance, which is + ;; ultimately built as a profile. + (when (file-exists? manifest-file) + (delete-file manifest-file)) + ;; Store meta-data. - (call-with-output-file (string-append output "/manifest") + (call-with-output-file manifest-file (lambda (p) (pretty-print manifest p))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d75c11ada7..66d63a2931 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -73,6 +73,7 @@ file-system-mount-flags statfs free-disk-space + device-in-use? processes mkdtemp! @@ -684,6 +685,32 @@ mounted at FILE." (define AT_NO_AUTOMOUNT #x800) (define AT_EMPTY_PATH #x1000) +(define-syntax BLKRRPART ;<sys/mount.h> + (identifier-syntax #x125F)) + +(define* (device-in-use? device) + "Return #t if the block DEVICE is in use, #f otherwise. This is inspired +from fdisk_device_is_used function of util-linux. This is particulary useful +for devices that do not appear in /proc/self/mounts like overlayfs lowerdir +backend device." + (let*-values (((fd) (open-fdes device O_RDONLY)) + ((ret err) (%ioctl fd BLKRRPART %null-pointer))) + (close-fdes fd) + (cond + ((= ret 0) + #f) + ((= err EBUSY) + #t) + ((= err EINVAL) + ;; We get EINVAL for devices that have the GENHD_FL_NO_PART_SCAN flag + ;; set in the kernel, in particular loopback devices, though we do seem + ;; to get it for SCSI storage (/dev/sr0) on QEMU. + #f) + (else + (throw 'system-error "ioctl" "~A" + (list (strerror err)) + (list err)))))) + ;;; ;;; Containers. diff --git a/guix/channels.scm b/guix/channels.scm index 6b860f3bd8..10345c1ce5 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -21,18 +21,27 @@ #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix combinators) #:use-module (guix store) #:use-module (guix i18n) + #:use-module ((guix utils) + #:select (source-properties->location + &error-location)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) - #:autoload (guix self) (whole-package) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:autoload (guix self) (whole-package make-config.scm) + #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (channel channel? channel-name @@ -52,6 +61,7 @@ checkout->channel-instance latest-channel-derivation channel-instances->manifest + %channel-profile-hooks channel-instances->derivation)) ;;; Commentary: @@ -153,44 +163,43 @@ of previously processed channels." (or (channel-commit b) (not (or (channel-commit a) (channel-commit b)))))))) + ;; Accumulate a list of instances. A list of processed channels is also ;; accumulated to decide on duplicate channel specifications. - (match (fold (lambda (channel acc) - (match acc - ((#:channels previous-channels #:instances instances) - (if (ignore? channel previous-channels) - acc - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let-values (((checkout commit) - (latest-repository-commit store (channel-url channel) - #:ref (channel-reference - channel)))) - (let ((instance (channel-instance channel commit checkout))) - (let-values (((new-instances new-channels) - (latest-channel-instances - store - (channel-instance-dependencies instance) - previous-channels))) - `(#:channels - ,(append (cons channel new-channels) - previous-channels) - #:instances - ,(append (cons instance new-instances) - instances)))))))))) - `(#:channels ,previous-channels #:instances ()) - channels) - ((#:channels channels #:instances instances) - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - channels))))) + (define-values (resulting-channels instances) + (fold2 (lambda (channel previous-channels instances) + (if (ignore? channel previous-channels) + (values previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let-values (((checkout commit) + (latest-repository-commit store (channel-url channel) + #:ref (channel-reference + channel)))) + (let ((instance (channel-instance channel commit checkout))) + (let-values (((new-instances new-channels) + (latest-channel-instances + store + (channel-instance-dependencies instance) + previous-channels))) + (values (append (cons channel new-channels) + previous-channels) + (append (cons instance new-instances) + instances)))))))) + previous-channels + '() ;instances + channels)) + + (let ((instance-name (compose channel-name channel-instance-channel))) + ;; Remove all earlier channel specifications if they are followed by a + ;; more specific one. + (values (delete-duplicates instances + (lambda (a b) + (eq? (instance-name a) (instance-name b)))) + resulting-channels))) (define* (checkout->channel-instance checkout #:key commit @@ -214,45 +223,48 @@ of COMMIT at URL. Use NAME as the channel name." ;; place a set of compiled Guile modules in ~/.config/guix/latest. 1) -(define (standard-module-derivation name source dependencies) - "Return a derivation that builds the Scheme modules in SOURCE and that -depend on DEPENDENCIES, a list of lowerable objects. The assumption is that -SOURCE contains package modules to be added to '%package-module-path'." - (define modules - (scheme-modules* source)) - +(define (standard-module-derivation name source core dependencies) + "Return a derivation that builds with CORE, a Guix instance, the Scheme +modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable +objects. The assumption is that SOURCE contains package modules to be added +to '%package-module-path'." ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow ;; channel publishers to specify things such as the sub-directory where .scm ;; files live, files to exclude from the channel, preferred substitute URLs, ;; etc. - (mlet* %store-monad ((compiled - (compiled-modules modules - #:name name - #:module-path (list source) - #:extensions dependencies))) - - (gexp->derivation name - (with-extensions dependencies - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (let ((go (string-append #$output "/lib/guile/" - (effective-version) - "/site-ccache")) - (scm (string-append #$output - "/share/guile/site/" - (effective-version)))) - (mkdir-p (dirname go)) - (symlink #$compiled go) - (mkdir-p (dirname scm)) - (symlink #$source scm)))))))) + + (define build + ;; This is code that we'll run in CORE, a Guix instance, with its own + ;; modules and so on. That way, we make sure these modules are built for + ;; the right Guile version, with the right dependencies, and that they get + ;; to see the right (gnu packages …) modules. + (with-extensions dependencies + #~(begin + (use-modules (guix build compile) + (guix build utils) + (srfi srfi-26)) + + (define go + (string-append #$output "/lib/guile/" (effective-version) + "/site-ccache")) + (define scm + (string-append #$output "/share/guile/site/" + (effective-version))) + + (compile-files #$source go + (find-files #$source "\\.scm$")) + (mkdir-p (dirname scm)) + (symlink #$source scm) + scm))) + + (gexp->derivation-in-inferior name build core)) (define* (build-from-source name source - #:key verbose? commit + #:key core verbose? commit (dependencies '())) "Return a derivation to build Guix from SOURCE, using the self-build script -contained therein. Use COMMIT as the version string." +contained therein; use COMMIT as the version string. When CORE is true, build +package modules under SOURCE using CORE, an instance of Guix." ;; Running the self-build script makes it easier to update the build ;; procedure: the self-build script of the Guix-to-be-installed contains the ;; right dependencies, build procedure, etc., which the Guix-in-use may not @@ -274,9 +286,10 @@ contained therein. Use COMMIT as the version string." #:pull-version %pull-version)) ;; Build a set of modules that extend Guix using the standard method. - (standard-module-derivation name source dependencies))) + (standard-module-derivation name source core dependencies))) -(define* (build-channel-instance instance #:optional (dependencies '())) +(define* (build-channel-instance instance + #:optional core (dependencies '())) "Return, as a monadic value, the derivation for INSTANCE, a channel instance. DEPENDENCIES is a list of extensions providing Guile modules that INSTANCE depends on." @@ -284,8 +297,37 @@ INSTANCE depends on." (channel-name (channel-instance-channel instance))) (channel-instance-checkout instance) #:commit (channel-instance-commit instance) + #:core core #:dependencies dependencies)) +(define (resolve-dependencies instances) + "Return a procedure that, given one of the elements of INSTANCES, returns +list of instances it depends on." + (define channel-instance-name + (compose channel-name channel-instance-channel)) + + (define table ;map a name to an instance + (fold (lambda (instance table) + (vhash-consq (channel-instance-name instance) + instance table)) + vlist-null + instances)) + + (define edges + (fold (lambda (instance edges) + (fold (lambda (channel edges) + (let ((name (channel-name channel))) + (match (vhash-assq name table) + ((_ . target) + (vhash-consq instance target edges))))) + edges + (channel-instance-dependencies instance))) + vlist-null + instances)) + + (lambda (instance) + (vhash-foldq* cons '() instance edges))) + (define (channel-instance-derivations instances) "Return the list of derivations to build INSTANCES, in the same order as INSTANCES." @@ -296,38 +338,30 @@ INSTANCES." (guix-channel? (channel-instance-channel instance))) instances)) - (define dependencies - ;; Dependencies of CORE-INSTANCE. - ;; FIXME: It would be best not to hard-wire this information here and - ;; instead query it to CORE-INSTANCE. - (list (module-ref (resolve-interface '(gnu packages gnupg)) - 'guile-gcrypt) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-git) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-bytestructures))) - - (mlet %store-monad ((core (build-channel-instance core-instance))) - (mapm %store-monad - (lambda (instance) - (if (eq? instance core-instance) - (return core) - (match (channel-instance-dependencies instance) - (() - (build-channel-instance instance - (cons core dependencies))) - (channels - (mlet %store-monad ((dependencies-derivation - (latest-channel-derivation - ;; %default-channels is used here to - ;; ensure that the core channel is - ;; available for channels declared as - ;; dependencies. - (append channels %default-channels)))) - (build-channel-instance instance - (cons dependencies-derivation - (cons core dependencies)))))))) - instances))) + (define edges + (resolve-dependencies instances)) + + (define (instance->derivation instance) + (mcached (if (eq? instance core-instance) + (build-channel-instance instance) + (mlet %store-monad ((core (instance->derivation core-instance)) + (deps (mapm %store-monad instance->derivation + (edges instance)))) + (build-channel-instance instance core deps))) + instance)) + + (unless core-instance + (let ((loc (and=> (any (compose channel-location channel-instance-channel) + instances) + source-properties->location))) + (raise (apply make-compound-condition + (condition + (&message (message "'guix' channel is lacking"))) + (if loc + (list (condition (&error-location (location loc)))) + '()))))) + + (mapm %store-monad instance->derivation instances)) (define (whole-package-for-legacy name modules) "Return a full-blown Guix package for MODULES, a derivation that builds Guix @@ -416,11 +450,40 @@ channel instances." (zip instances derivations)))) (return (manifest entries)))) +(define (package-cache-file manifest) + "Build a package cache file for the instance in MANIFEST. This is meant to +be used as a profile hook." + (mlet %store-monad ((profile (profile-derivation manifest + #:hooks '()))) + + (define build + #~(begin + (use-modules (gnu packages)) + + (if (defined? 'generate-package-cache) + (begin + ;; Delegate package cache generation to the inferior. + (format (current-error-port) + "Generating package cache for '~a'...~%" + #$profile) + (generate-package-cache #$output)) + (mkdir #$output)))) + + (gexp->derivation-in-inferior "guix-package-cache" build + profile + #:properties '((type . profile-hook) + (hook . package-cache))))) + +(define %channel-profile-hooks + ;; The default channel profile hooks. + (cons package-cache-file %default-profile-hooks)) + (define (channel-instances->derivation instances) "Return the derivation of the profile containing INSTANCES, a list of channel instances." (mlet %store-monad ((manifest (channel-instances->manifest instances))) - (profile-derivation manifest))) + (profile-derivation manifest + #:hooks %channel-profile-hooks))) (define latest-channel-instances* (store-lift latest-channel-instances)) diff --git a/guix/discovery.scm b/guix/discovery.scm index 3fc6e2c9e7..ef5ae73973 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,7 +30,8 @@ scheme-modules* fold-modules all-modules - fold-module-public-variables)) + fold-module-public-variables + fold-module-public-variables*)) ;;; Commentary: ;;; @@ -147,10 +148,33 @@ search. Entries in PATH can be directory names (strings) or (DIRECTORY SUB-DIRECTORY." (fold-modules cons '() path #:warn warn)) +(define (fold-module-public-variables* proc init modules) + "Call (PROC MODULE SYMBOL VARIABLE) for each variable exported by one of MODULES, +using INIT as the initial value of RESULT. It is guaranteed to never traverse +the same object twice." + ;; Here SEEN is populated by variables; if two different variables refer to + ;; the same object, we still let them through. + (identity ;discard second return value + (fold2 (lambda (module result seen) + (fold2 (lambda (sym+var result seen) + (match sym+var + ((sym . var) + (if (not (vhash-assq var seen)) + (values (proc module sym var result) + (vhash-consq var #t seen)) + (values result seen))))) + result + seen + (module-map cons module))) + init + vlist-null + modules))) + (define (fold-module-public-variables proc init modules) "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES, using INIT as the initial value of RESULT. It is guaranteed to never traverse the same object twice." + ;; Note: here SEEN is populated by objects, not by variables. (identity ; discard second return value (fold2 (lambda (module result seen) (fold2 (lambda (var result seen) diff --git a/guix/import/github.scm b/guix/import/github.scm index ad662e7b02..b287313d98 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,7 +55,6 @@ false if none is recognized" (github-user-slash-repository url))) (repo (github-repository url))) (cond - ((string-suffix? ".git" url) url) ((string-suffix? (string-append "/tarball/v" version) url) (string-append prefix "/tarball/v" new-version)) ((string-suffix? (string-append "/tarball/" version) url) @@ -99,7 +99,7 @@ false if none is recognized" ((source-uri ...) (find updated-url source-uri)))) ((eq? fetch-method download:git-fetch) - (updated-url (download:git-reference-url source-uri))) + (download:git-reference-url source-uri)) (else #f)))) (define (github-package? package) diff --git a/guix/inferior.scm b/guix/inferior.scm index ba8d00866b..9f19e7d316 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -81,6 +81,8 @@ inferior-package->manifest-entry + gexp->derivation-in-inferior + %inferior-cache-directory inferior-for-channels)) @@ -484,6 +486,37 @@ PACKAGE must be live." ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. (inferior-package->derivation package system #:target target)) +(define* (gexp->derivation-in-inferior name exp guix + #:rest rest) + "Return a derivation that evaluates EXP with GUIX, an instance of Guix as +returned for example by 'channel-instances->derivation'. Other arguments are +passed as-is to 'gexp->derivation'." + (define script + ;; EXP wrapped with a proper (set! %load-path …) prologue. + (scheme-file "inferior-script.scm" exp)) + + (define trampoline + ;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and + ;; make 'guix repl' the "builder"; this will require "opening up" the + ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'. + #~(begin + (use-modules (ice-9 popen)) + + (let ((pipe (open-pipe* OPEN_WRITE + #+(file-append guix "/bin/guix") + "repl" "-t" "machine"))) + + ;; XXX: EXP presumably refers to #$output but that reference is lost + ;; so explicitly reference it here. + #$output + + (write `(primitive-load #$script) pipe) + + (unless (zero? (close-pipe pipe)) + (error "inferior failed" #+guix))))) + + (apply gexp->derivation name trampoline rest)) + ;;; ;;; Manifest entries. diff --git a/guix/profiles.scm b/guix/profiles.scm index 8142e5e8e2..598e0acf62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> -;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -1338,6 +1338,53 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) +(define (texlive-configuration manifest) + "Return a derivation that builds a TeXlive configuration for the entries in +MANIFEST." + (define entry->texlive-input + (match-lambda + (($ <manifest-entry> name version output thing deps) + (if (string-prefix? "texlive-" name) + (cons (gexp-input thing output) + (append-map entry->texlive-input deps)) + '())))) + (define build + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (guix build utils) + (guix build union)) + + ;; Build a modifiable union of all texlive inputs. We do this so + ;; that TeX live can resolve the parent and grandparent directories + ;; correctly. There might be a more elegant way to accomplish this. + (union-build #$output + '#$(append-map entry->texlive-input + (manifest-entries manifest)) + #:create-all-directories? #t + #:log-port (%make-void-port "w")) + (let ((texmf.cnf (string-append + #$output + "/share/texmf-dist/web2c/texmf.cnf"))) + (when (file-exists? texmf.cnf) + (substitute* texmf.cnf + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " #$output "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")))) + #t))) + + (with-monad %store-monad + (if (any (cut string-prefix? "texlive-" <>) + (map manifest-entry-name (manifest-entries manifest))) + (gexp->derivation "texlive-configuration" build + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . texlive-configuration))) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. @@ -1349,6 +1396,7 @@ the entries in MANIFEST." glib-schemas gtk-icon-themes gtk-im-modules + texlive-configuration xdg-desktop-database xdg-mime-database)) diff --git a/guix/profiling.scm b/guix/profiling.scm index 753fc6c22e..e1c205a543 100644 --- a/guix/profiling.scm +++ b/guix/profiling.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix profiling) #:use-module (ice-9 match) + #:autoload (ice-9 format) (format) #:export (profiled? register-profiling-hook!)) @@ -50,3 +51,25 @@ (for-each (lambda (hook) (add-hook! hook thunk)) %profiling-hooks))) + +(define (show-gc-stats) + "Display garbage collection statistics." + (define MiB (* 1024 1024.)) + (define stats (gc-stats)) + + (format (current-error-port) "Garbage collection statistics: + heap size: ~,2f MiB + allocated: ~,2f MiB + GC times: ~a + time spent in GC: ~,2f seconds (~d% of user time)~%" + (/ (assq-ref stats 'heap-size) MiB) + (/ (assq-ref stats 'heap-total-allocated) MiB) + (assq-ref stats 'gc-times) + (/ (assq-ref stats 'gc-time-taken) + internal-time-units-per-second 1.) + (inexact->exact + (round (* (/ (assq-ref stats 'gc-time-taken) + (tms:utime (times)) 1.) + 100))))) + +(register-profiling-hook! "gc" show-gc-stats) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 4c85929858..be4ce4364b 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix scripts) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix scripts build) @@ -116,6 +117,8 @@ Copy ITEMS to or from the specified host over SSH.\n")) --to=HOST send ITEMS to HOST")) (display (G_ " --from=HOST receive ITEMS from HOST")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) (newline) @@ -134,6 +137,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (option '("from") #t #f (lambda (opt name arg result) (alist-cons 'source arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -152,7 +160,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (debug . 0) + (verbosity . 2))) ;;; @@ -164,6 +176,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (let* ((opts (parse-command-line args %options (list %default-options))) (source (assoc-ref opts 'source)) (target (assoc-ref opts 'destination))) - (cond (target (send-to-remote-host target opts)) - (source (retrieve-from-remote-host source opts)) - (else (leave (G_ "use '--to' or '--from'~%"))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (G_ "use '--to' or '--from'~%")))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index b9162d3449..d8fe71ce12 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -77,7 +77,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) - (format #f (G_ " + (format #t (G_ " -o, --output=FILE download to FILE")) (newline) (display (G_ " diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8b2b61d76a..da3d2775e8 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix utils) - #:use-module (guix packages) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) file path)) absolute-file-name)) -(define (package->location-specification package) - "Return the location specification for PACKAGE for a typical editor command +(define (location->location-specification location) + "Return the location specification for LOCATION for a typical editor command line." - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) + (list (string-append "+" + (number->string + (location-line location))) + (search-path* %load-path (location-file location)))) (define (guix-edit . args) @@ -83,18 +81,13 @@ line." '())) (with-error-handling - (let* ((specs (reverse (parse-arguments))) - (packages (map specification->package specs))) - (for-each (lambda (package) - (unless (package-location package) - (leave (G_ "source location of package '~a' is unknown~%") - (package-full-name package)))) - packages) + (let* ((specs (reverse (parse-arguments))) + (locations (map specification->location specs))) (catch 'system-error (lambda () - (let ((file-names (append-map package->location-specification - packages))) + (let ((file-names (append-map location->location-specification + locations))) ;; Use `system' instead of `exec' in order to sanely handle ;; possible command line arguments in %EDITOR. (exit (system (string-join (cons (%editor) file-names)))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 0f315a9352..665adcfb8d 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -758,9 +758,10 @@ descriptions maintained upstream." "Emit a warning if PACKAGE's source is an autogenerated tarball." (define (check-source-uri uri) (when (and (string=? (uri-host (string->uri uri)) "github.com") - (string=? (third (split-and-decode-uri-path - (uri-path (string->uri uri)))) - "archive")) + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) (emit-warning package (G_ "the source URI should not be an autogenerated tarball") 'source))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7ff6bfd6d8..a633d2ee6d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + (hooks %default-profile-hooks) allow-collisions? bootstrap? use-substitutes? dry-run?) "Build a new generation of PROFILE, a file name, using the packages specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, -do not treat collisions in MANIFEST as an error." +do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile +hooks\" run when building the profile." (when (equal? profile %current-profile) (ensure-default-profile)) (let* ((prof-drv (run-with-store store (profile-derivation manifest #:allow-collisions? allow-collisions? - #:hooks (if bootstrap? - '() - %default-profile-hooks) + #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) @@ -220,31 +220,32 @@ of relevance scores." ('dismiss transaction) (($ <manifest-entry> name version output (? string? path)) - (match (vhash-assoc name (find-newest-available-packages)) - ((_ candidate-version pkg . rest) - (match (package-superseded pkg) - ((? package? new) - (supersede entry new)) - (#f - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (string=? path candidate-path) - (null? (package-propagated-inputs pkg))) - transaction - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)))))))) - (#f + (match (find-best-packages-by-name name #f) + ((pkg . rest) + (let ((candidate-version (package-version pkg))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? path candidate-path) + (null? (package-propagated-inputs pkg))) + transaction + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction))))))))) + (() (warning (G_ "package '~a' no longer exists~%") name) transaction))))) @@ -604,12 +605,12 @@ and upgrades." (options->upgrade-predicate opts)) (define upgraded - (fold-right (lambda (entry transaction) - (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) - transaction)) - transaction - (manifest-entries manifest))) + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -735,29 +736,34 @@ processed, #f otherwise." (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (and (supported-package? p) - (not (package-superseded p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) + (available (fold-available-packages + (lambda* (name version result + #:key outputs location + supported? superseded? + #:allow-other-keys) + (if (and supported? (not superseded?)) + (if regexp + (if (regexp-exec regexp name) + (cons `(,name ,version + ,outputs ,location) + result) + result) + (cons `(,name ,version + ,outputs ,location) + result)) + result)) '()))) (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) + (for-each (match-lambda + ((name version outputs location) + (format #t "~a\t~a\t~a\t~a~%" + name version + (string-join outputs ",") + (location->string location)))) (sort available - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2)))))) + (match-lambda* + (((name1 . _) (name2 . _)) + (string<? name1 name2)))))) #t)) (('search _) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 6d1914f7c2..d3a4401a01 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -34,11 +34,12 @@ #:use-module (guix channels) #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) + #:autoload (guix build utils) (which) #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) #:use-module ((guix scripts package) #:select (build-and-use-profile)) - #:use-module (gnu packages base) + #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) @@ -125,8 +126,7 @@ Download and deploy the latest version of Guix.\n")) (alist-cons 'ref `(commit . ,arg) result))) (option '("branch") #t #f (lambda (opt name arg result) - (alist-cons 'ref `(branch . ,(string-append "origin/" arg)) - result))) + (alist-cons 'ref `(branch . ,arg) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) @@ -189,9 +189,19 @@ true, display what would be built without actually building it." (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest + #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)))))) + (return (display-profile-news profile)) + (match (which "guix") + (#f (return #f)) + (str + (let ((command (string-append profile "/bin/guix"))) + (unless (string=? command str) + (display-hint (format #f (G_ "After setting @code{PATH}, run +@command{hash guix} to make sure your shell refers to @file{~a}.") + command))) + (return #f)))))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." diff --git a/guix/self.scm b/guix/self.scm index cf6110613c..fa78015a41 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -613,6 +613,13 @@ Info manual." (append (file-imports source "gnu/system/examples" (const #t)) + ;; Need so we get access system tests from an + ;; inferior. + (file-imports source "gnu/tests" (const #t)) + + ;; All the installer code is on the build-side. + (file-imports source "gnu/installer/" + (const #t)) ;; Build-side code that we don't build. Some of ;; these depend on guile-rsvg, the Shepherd, etc. (file-imports source "gnu/build" (const #t))) @@ -806,7 +813,6 @@ Info manual." ;; made relative to a nonexistent anonymous module. #:splice? #t)) - ;;; ;;; Building. diff --git a/guix/serialization.scm b/guix/serialization.scm index 87ad7eeec0..7c0fea552d 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -380,10 +380,19 @@ which case you can use 'identity'." (&nar-error (file f) (port port)))))) (write-string ")" p))) +(define port-conversion-strategy + (fluid->parameter %default-port-conversion-strategy)) + (define (restore-file port file) "Read a file (possibly a directory structure) in Nar format from PORT. Restore it as FILE." - (parameterize ((currently-restored-file file)) + (parameterize ((currently-restored-file file) + + ;; Error out if we can convert file names to the current + ;; locale. (XXX: We'd prefer UTF-8 encoding for file names + ;; regardless of the locale, but that's what Guile gives us + ;; so far.) + (port-conversion-strategy 'error)) (let ((signature (read-string port))) (unless (equal? signature %archive-version-1) (raise diff --git a/guix/status.scm b/guix/status.scm index 2928733257..93e119bed1 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ #:select (nar-uri-abbreviation)) #:use-module (guix store) #:use-module (guix derivations) + #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) @@ -229,22 +230,27 @@ build-log\" traces." (and (current-store-protocol-version) (>= (current-store-protocol-version) #x163))) +(define isatty?* + (mlambdaq (port) + (isatty? port))) + (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) (lambda (port) "Display a spinner on PORT." - (match steps - ((first . rest) - (set! steps rest) - (display "\r\x1b[K" port) - (display first port) - (force-output port)))))) + (when (isatty?* port) + (match steps + ((first . rest) + (set! steps rest) + (display "\r\x1b[K" port) + (display first port) + (force-output port))))))) (define (color-output? port) "Return true if we should write colored output to PORT." (and (not (getenv "INSIDE_EMACS")) (not (getenv "NO_COLOR")) - (isatty? port))) + (isatty?* port))) (define-syntax color-rules (syntax-rules () @@ -312,8 +318,12 @@ on." (G_ "building XDG MIME database...")) ('fonts-dir (G_ "building fonts directory...")) + ('texlive-configuration + (G_ "building TeX Live configuration...")) ('manual-database (G_ "building database for manual pages...")) + ('package-cache ;package cache generated by 'guix pull' + (G_ "building package cache...")) (_ #f))) (define* (print-build-event event old-status status |