From 52d174d6d116d75c71ddf0aa448b05f58637e9df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Nov 2017 22:45:06 +0100 Subject: ssh: Use (guix i18n). * guix/ssh.scm: Use (guix i18n) instead of (guix ui). --- guix/ssh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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) -- cgit v1.2.3 From 85f4f7b79040d982c6a655c898b4cd00d868fa9c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Nov 2017 23:02:29 +0100 Subject: zlib: Fix race condition when closing gzip ports. Fixes . * guix/zlib.scm (close-procedure): Remove. (make-gzip-input-port): Do (dup (fileno port)) to get a file descriptor for 'gzdopen'. Close PORT before returning. Use 'gzclose' as the 'close' procedure of the returned port. (make-gzip-output-port): Likewise. --- guix/zlib.scm | 46 ++++++++++++++++------------------------------ 1 file changed, 16 insertions(+), 30 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; 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 ); calling 'close-port' after + ;; 'gzclose' doesn't work either because it leads to a race condition + ;; (see ). 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)) -- cgit v1.2.3 From bd7e136d295f0d6c1aa5d107356e28c259a54cb9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Nov 2017 18:41:47 +0100 Subject: Add semicolon in commands that set GUIX_PROFILE. Fixes . Reported by Rosebud Uplink . * doc/guix.texi (Binary Installation): Add missing semicolon after 'GUIX_PROFILE=' line. (Invoking guix package): Likewise. * gnu/system.scm (operating-system-etc-service)[profile]: Likewise. * guix/build/profiles.scm (build-etc/profile): Likewise. --- doc/guix.texi | 4 ++-- gnu/system.scm | 4 ++-- guix/build/profiles.scm | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index d4a2a696a4..4f8453ebf0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -456,7 +456,7 @@ Source @file{etc/profile} to augment @code{PATH} and other relevant environment variables: @example -# GUIX_PROFILE=$HOME/.guix-profile \ +# GUIX_PROFILE=$HOME/.guix-profile ; \ source $GUIX_PROFILE/etc/profile @end example @@ -1684,7 +1684,7 @@ Files,,, bash, The GNU Bash Reference Manual}) so that newly-spawned shells get all the right environment variable definitions: @example -GUIX_PROFILE="$HOME/.guix-profile" \ +GUIX_PROFILE="$HOME/.guix-profile" ; \ source "$HOME/.guix-profile/etc/profile" @end example diff --git a/gnu/system.scm b/gnu/system.scm index 9e05c4b213..7466ed780d 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -588,7 +588,7 @@ export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-sy unset PATH # Load the system profile's settings. -GUIX_PROFILE=/run/current-system/profile \\ +GUIX_PROFILE=/run/current-system/profile ; \\ . /run/current-system/profile/etc/profile # Prepend setuid programs. @@ -608,7 +608,7 @@ fi if [ -f \"$HOME/.guix-profile/etc/profile\" ] then # Load the user profile's settings. - GUIX_PROFILE=\"$HOME/.guix-profile\" \\ + GUIX_PROFILE=\"$HOME/.guix-profile\" ; \\ . \"$HOME/.guix-profile/etc/profile\" else # At least define this one so that basic things just work 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 -- cgit v1.2.3 From a5792deca5ed0cded624dc1bb161450427a0a9d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Nov 2017 22:33:54 +0100 Subject: compile: Put an upper bound on the number of workers. * guix/build/compile.scm (compile-files): Don't use more than 8 workers. --- guix/build/compile.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') 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: + ;; . + (n-par-for-each (min workers 8) build files) + (unless (zero? total) (report-compilation #f total total))))) -- cgit v1.2.3 From 59523429d61083f410d54ac8f8516c66459c1003 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Oct 2017 16:07:34 +0200 Subject: union: Parametrize the symlink procedure . * guix/gexp.scm (directory-union): Add #:hard-links and honor it. * guix/build/union.scm (union-build): Add #:symlink parameter. --- guix/build/union.scm | 11 ++++++----- guix/gexp.scm | 19 ++++++++++++++++--- 2 files changed, 22 insertions(+), 8 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; Copyright © 2017 Huang Ying ;;; @@ -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..e8ac3dcdc8 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1204,13 +1204,24 @@ 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)) "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 COPY? is true, copy files instead of creating symlinks." + (define symlink + (if copy? + (gexp (lambda (old new) + (if (file-is-directory? old) + (symlink old new) + (copy-file old new)))) + (gexp symlink))) + (match things ((one) ;; Only one thing; return it. @@ -1221,7 +1232,9 @@ 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) + + #:symlink (ungexp symlink))))))))) ;;; -- cgit v1.2.3 From de98b302a1794365ee88e2d78c5afff9296054b8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Oct 2017 16:10:18 +0200 Subject: gexp: 'directory-union' has a #:quiet? parameter. * guix/gexp.scm (directory-union): Add #:quiet? and honor it. --- guix/gexp.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index e8ac3dcdc8..3781a1e6ee 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1205,7 +1205,7 @@ This yields an 'etc' directory containing these two files." files)))))) (define* (directory-union name things - #:key (copy? #f)) + #: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: @@ -1213,7 +1213,8 @@ file-like objects denoting directories. For example: yields a directory that is the union of the 'guile' and 'emacs' packages. -When COPY? is true, copy files instead of creating symlinks." +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) @@ -1222,6 +1223,11 @@ When COPY? is true, copy files instead of creating symlinks." (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. @@ -1234,6 +1240,7 @@ When COPY? is true, copy files instead of creating symlinks." (union-build (ungexp output) '(ungexp things) + #:log-port (ungexp log-port) #:symlink (ungexp symlink))))))))) -- cgit v1.2.3 From a6591381fc1f5e1890efb8270a3671062249c2bc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Oct 2017 15:26:19 -0700 Subject: pull: Trim import list. * guix/scripts/pull.scm: Remove useless imports. --- guix/scripts/pull.scm | 6 ------ 1 file changed, 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2400198000..3e95bd511f 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)) -- cgit v1.2.3 From fe9b3ec3ee208c5bac7844f3d0fecce2c6b1297d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 21 Nov 2017 15:25:57 +0100 Subject: git: Do not add '.git' to the store. This makes 'latest-repository-commit' significantly more efficient and reduces disk usage in the store. * guix/git.scm (copy-to-store)[dot-git?]: New procedure. Pass it as the #:select? argument to 'add-to-store'. --- guix/git.scm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) (limited to 'guix') 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." -- cgit v1.2.3 From 5f93d97005897c2d859f0be1bdff34c88467ec61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Oct 2017 10:41:37 +0200 Subject: Add (guix self) and use it when pulling. This mitigates . * guix/self.scm: New file. * Makefile.am (MODULES): Add it. * build-aux/build-self.scm (libgcrypt, zlib, gzip, bzip2, xz) (false-if-wrong-guile, package-for-current-guile, guile-json) (guile-ssh, guile-git, guile-bytestructures): Remove. (build): Rewrite to simply delegate to 'compiled-guix'. * gnu/packages.scm (%distro-root-directory): Rewrite to try different directories. * guix/discovery.scm (guix): Export 'scheme-files'. * guix/scripts/pull.scm (build-and-install): Split into... (install-latest): ... this. New procedure. And... (build-and-install): ... this, which now takes a monadic value argument. (indirect-root-added): Remove. (guix-pull): Call 'add-indirect-root'. Call 'build-from-source' and pass the result to 'build-and-install'. --- Makefile.am | 1 + build-aux/build-self.scm | 272 +++++---------------- gnu/packages.scm | 21 +- guix/discovery.scm | 3 +- guix/scripts/pull.scm | 91 ++++--- guix/self.scm | 619 +++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 755 insertions(+), 252 deletions(-) create mode 100644 guix/self.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 925dd0a25a..a4156c834d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -66,6 +66,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/gnu-maintenance.scm \ + guix/self.scm \ guix/upstream.scm \ guix/licenses.scm \ guix/git.scm \ diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index ed8ff5f4ce..d9d9263678 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -17,11 +17,9 @@ ;;; along with GNU Guix. If not, see . (define-module (build-self) - #:use-module (gnu) - #:use-module (guix) - #:use-module (guix config) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (build)) @@ -31,105 +29,51 @@ ;;; argument: the source tree to build. It returns a derivation that ;;; builds it. ;;; -;;; This file uses modules provided by the already-installed Guix. Those -;;; modules may be arbitrarily old compared to the version we want to -;;; build. Because of that, it must rely on the smallest set of features -;;; that are likely to be provided by the (guix) and (gnu) modules, and by -;;; Guile itself, forever and ever. -;;; ;;; Code: - -;; The dependencies. Don't refer explicitly to the variables because they -;; could be renamed or shuffled around in modules over time. Conversely, -;; 'find-best-packages-by-name' is expected to always have the same semantics. - -(define libgcrypt - (first (find-best-packages-by-name "libgcrypt" #f))) - -(define zlib - (first (find-best-packages-by-name "zlib" #f))) - -(define gzip - (first (find-best-packages-by-name "gzip" #f))) - -(define bzip2 - (first (find-best-packages-by-name "bzip2" #f))) - -(define xz - (first (find-best-packages-by-name "xz" #f))) - -(define (false-if-wrong-guile package) - "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., -2.0 instead of 2.2), otherwise return PACKAGE." - (let ((guile (any (match-lambda - ((label (? package? dep) _ ...) - (and (string=? (package-name dep) "guile") - dep))) - (package-direct-inputs package)))) - (and (or (not guile) - (string-prefix? (effective-version) - (package-version guile))) - package))) - -(define (package-for-current-guile . names) - "Return the package with one of the given NAMES that depends on the current -Guile major version (2.0 or 2.2), or #f if none of the packages matches." - (let loop ((names names)) - (match names - (() - #f) - ((name rest ...) - (match (find-best-packages-by-name name #f) - (() - (loop rest)) - ((first _ ...) - (or (false-if-wrong-guile first) - (loop rest)))))))) - -(define guile-json - (package-for-current-guile "guile-json" - "guile2.2-json" - "guile2.0-json")) - -(define guile-ssh - (package-for-current-guile "guile-ssh" - "guile2.2-ssh" - "guile2.0-ssh")) - -(define guile-git - (package-for-current-guile "guile-git" - "guile2.0-git")) - -(define guile-bytestructures - (package-for-current-guile "guile-bytestructures" - "guile2.0-bytestructures")) - -;; The actual build procedure. - -(define (top-source-directory) - "Return the name of the top-level directory of this source tree." +;; Use our very own Guix modules. +(eval-when (compile load eval) (and=> (assoc-ref (current-source-location) 'filename) (lambda (file) - (string-append (dirname file) "/..")))) - + (let ((dir (string-append (dirname file) "/.."))) + (set! %load-path (cons dir %load-path)))))) (define (date-version-string) "Return the current date and hour in UTC timezone, for use as a poor person's version identifier." - ;; XXX: Replace with a Git commit id. + ;; XXX: Last resort when the Git commit id is missing. (date->string (current-date 0) "~Y~m~d.~H")) -(define (guile-for-build) - "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently -running Guile." - (package->derivation (cond-expand - (guile-2.2 - (canonical-package - (specification->package "guile@2.2"))) - (else - (canonical-package - (specification->package "guile@2.0")))))) +(define-syntax parameterize* + (syntax-rules () + "Like 'parameterize' but for regular variables (!)." + ((_ ((var value) rest ...) body ...) + (let ((old var) + (new value)) + (dynamic-wind + (lambda () + (set! var new)) + (lambda () + (parameterize* (rest ...) body ...)) + (lambda () + (set! var old))))) + ((_ () body ...) + (begin body ...)))) + +(define (pure-load-compiled-path) + "Return %LOAD-COMPILED-PATH minus the directories containing .go files from +Guix." + (define (purify path) + (fold-right delete path + (filter-map (lambda (file) + (and=> (search-path path file) dirname)) + '("guix.go" "gnu.go")))) + + (let loop ((path %load-compiled-path)) + (let ((next (purify path))) + (if (equal? next path) + path + (loop next))))) ;; The procedure below is our return value. (define* (build source @@ -138,131 +82,29 @@ running Guile." #:rest rest) "Return a derivation that unpacks SOURCE into STORE and compiles Scheme files." - ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we - ;; cannot assume that they are defined. Try to guess their value when - ;; they're undefined (XXX: we get an incorrect guess when environment - ;; variables such as 'NIX_STATE_DIR' are defined!). - (define storedir - (if (defined? '%storedir) %storedir %store-directory)) - (define localstatedir - (if (defined? '%localstatedir) %localstatedir (dirname %state-directory))) - (define sysconfdir - (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory))) - (define sbindir - (if (defined? '%sbindir) %sbindir (dirname %guix-register-program))) - - (define builder - #~(begin - (use-modules (guix build pull)) - - (letrec-syntax ((maybe-load-path - (syntax-rules () - ((_ item rest ...) - (let ((tail (maybe-load-path rest ...))) - (if (string? item) - (cons (string-append item - "/share/guile/site/" - #$(effective-version)) - tail) - tail))) - ((_) - '())))) - (set! %load-path - (append - (maybe-load-path #$guile-json #$guile-ssh - #$guile-git #$guile-bytestructures) - %load-path))) - - (letrec-syntax ((maybe-load-compiled-path - (syntax-rules () - ((_ item rest ...) - (let ((tail (maybe-load-compiled-path rest ...))) - (if (string? item) - (cons (string-append item - "/lib/guile/" - #$(effective-version) - "/site-ccache") - tail) - tail))) - ((_) - '())))) - (set! %load-compiled-path - (append - (maybe-load-compiled-path #$guile-json #$guile-ssh - #$guile-git #$guile-bytestructures) - %load-compiled-path))) - - ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was - ;; broken: libguile-ssh could not be found. Work around that. - ;; FIXME: We want Guile-SSH 0.10.2 or later anyway. - #$(if (string-prefix? "0.9." (package-version guile-ssh)) - #~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib")) - #t) - - (build-guix #$output #$source - - #:system #$%system - #:storedir #$storedir - #:localstatedir #$localstatedir - #:sysconfdir #$sysconfdir - #:sbindir #$sbindir - - #:package-name #$%guix-package-name - #:package-version #$version - #:bug-report-address #$%guix-bug-report-address - #:home-page-url #$%guix-home-page-url - - #:libgcrypt #$libgcrypt - #:zlib #$zlib - #:gzip #$gzip - #:bzip2 #$bzip2 - #:xz #$xz - - ;; XXX: This is not perfect, enabling VERBOSE? means - ;; building a different derivation. - #:debug-port (if #$verbose? - (current-error-port) - (%make-void-port "w"))))) - - (unless guile-git - ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether. - ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not - ;; build (guix git), which will leave us with an unusable 'guix pull'. To - ;; avoid that, fail early. - (format (current-error-port) - "\ -Your installation is too old and lacks a '~a' package. -Please upgrade to an intermediate version first, for instance with: - - guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz -\n" - (match (effective-version) - ("2.0" "guile2.0-git") - (_ "guile-git"))) - (exit 1)) - - (mlet %store-monad ((guile (guile-for-build))) - (gexp->derivation "guix-latest" builder - #:modules '((guix build pull) - (guix build utils) - (guix build compile) - - ;; Closure of (guix modules). - (guix modules) - (guix memoization) - (guix sets)) - - ;; Arrange so that our own (guix build …) modules are - ;; used. - #:module-path (list (top-source-directory)) - - #:guile-for-build guile))) + ;; Start by jumping into the target Guix so that we have access to the + ;; latest packages and APIs. + ;; + ;; Our checkout in the store has mtime set to the epoch, and thus .go + ;; files look newer, even though they may not correspond. + (parameterize* ((%load-should-auto-compile #f) + (%fresh-auto-compile #f) + + ;; Work around . + (%load-compiled-path (pure-load-compiled-path))) + ;; FIXME: This is currently too expensive notably because it involves + ;; compiling a number of the big package files such as perl.scm, which + ;; takes lots of time and memory as of Guile 2.2.2. + ;; + ;; (let ((reload-guix (module-ref (resolve-interface '(guix self)) + ;; 'reload-guix))) + ;; (reload-guix)) ;cross fingers! + + (let ((guix-derivation (module-ref (resolve-interface '(guix self)) + 'guix-derivation))) + (guix-derivation source version)))) ;; This file is loaded by 'guix pull'; return it the build procedure. build -;; Local Variables: -;; eval: (put 'with-load-path 'scheme-indent-function 1) -;; End: - ;;; build-self.scm ends here diff --git a/gnu/packages.scm b/gnu/packages.scm index 97e6cb347f..44a56dfde0 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -110,8 +110,25 @@ for system '~a'") file-name system))))))) (define %distro-root-directory - ;; Absolute file name of the module hierarchy. - (dirname (search-path %load-path "guix.scm"))) + ;; Absolute file name of the module hierarchy. Since (gnu packages …) might + ;; live in a directory different from (guix), try to get the best match. + (letrec-syntax ((dirname* (syntax-rules () + ((_ file) + (dirname file)) + ((_ file head tail ...) + (dirname (dirname* file tail ...))))) + (try (syntax-rules () + ((_ (file things ...) rest ...) + (match (search-path %load-path file) + (#f + (try rest ...)) + (absolute + (dirname* absolute things ...)))) + ((_) + #f)))) + (try ("gnu/packages/base.scm" gnu/ packages/) + ("gnu/packages.scm" gnu/) + ("guix.scm")))) (define %package-module-path ;; Search path for package modules. Each item must be either a directory diff --git a/guix/discovery.scm b/guix/discovery.scm index 7b57579023..8ffcf7cd9a 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -25,7 +25,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 ftw) - #:export (scheme-modules + #:export (scheme-files + scheme-modules fold-modules all-modules fold-module-public-variables)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 3e95bd511f..083b5c3711 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -149,8 +149,6 @@ Download and deploy the latest version of Guix.\n")) (define what-to-build (store-lift show-what-to-build)) -(define indirect-root-added - (store-lift add-indirect-root)) (define %self-build-file ;; The file containing code to build Guix. This serves the same purpose as @@ -171,33 +169,48 @@ contained therein. Use COMMIT as the version string." ;; tree. (build source #:verbose? verbose? #:version commit))) -(define* (build-and-install source config-dir - #:key verbose? commit) - "Build the tool from SOURCE, and install it in CONFIG-DIR." - (mlet* %store-monad ((source (build-from-source source - #:commit commit - #:verbose? verbose?)) - (source-dir -> (derivation->output-path source)) - (to-do? (what-to-build (list source))) - (built? (built-derivations (list source)))) - ;; Always update the 'latest' symlink, regardless of whether SOURCE was - ;; already built or not. - (if built? - (mlet* %store-monad - ((latest -> (string-append config-dir "/latest")) - (done (indirect-root-added latest))) - (if (and (file-exists? latest) - (string=? (readlink latest) source-dir)) - (begin - (display (G_ "Guix already up to date\n")) - (return #t)) - (begin - (switch-symlinks latest source-dir) - (format #t - (G_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - (return #t)))) - (leave (G_ "failed to update Guix, check the build log~%"))))) +(define* (install-latest source-dir config-dir) + "Make SOURCE-DIR, a store file name, the latest Guix in CONFIG-DIR." + (let ((latest (string-append config-dir "/latest"))) + (if (and (file-exists? latest) + (string=? (readlink latest) source-dir)) + (begin + (display (G_ "Guix already up to date\n")) + #t) + (begin + (switch-symlinks latest source-dir) + (format #t + (G_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + #t)))) + +(define (build-and-install mdrv) + "Bind MDRV, a monadic value for a derivation, build it, and finally install +it as the latest Guix." + (define do-it + ;; Weirdness follows! Before we were called, the Guix modules have + ;; probably been reloaded, leading to a "parallel universe" with disjoint + ;; record types. However, procedures in this file have already cached the + ;; module relative to which they lookup global bindings (see + ;; 'toplevel-box' documentation), so they're stuck in the old world. To + ;; work around that, evaluate our procedure in the context of the "new" + ;; (guix scripts pull) module--which has access to the new + ;; record, and so on. + (eval '(lambda (mdrv cont) + ;; Reopen a connection to the daemon so that we have a record + ;; with the new type. + (with-store store + (run-with-store store + (mlet %store-monad ((drv mdrv)) + (mbegin %store-monad + (what-to-build (list drv)) + (built-derivations (list drv)) + (return (cont (derivation->output-path drv)))))))) + (resolve-module '(guix scripts pull)))) ;the new module + + (do-it mdrv + (lambda (result) + (install-latest result (config-directory))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -258,6 +271,10 @@ certificates~%")) (when (use-le-certs? url) (honor-lets-encrypt-certificates! store)) + ;; Ensure the 'latest' symlink is registered as a GC root. + (add-indirect-root store + (string-append (config-directory) "/latest")) + (format (current-error-port) (G_ "Updating from Git repository at '~a'...~%") url) @@ -276,10 +293,16 @@ certificates~%")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.0))))) - (run-with-store store - (build-and-install checkout (config-directory) - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?)))))))))))) + + ;; 'build-from-source' may cause a reload of the Guix + ;; modules. This leads to a parallel world: its record types + ;; are disjoint from those we've seen until now (because we + ;; use "generative" record types), and so on. Thus, special + ;; care must be taken once we have return from that call. + (build-and-install + (build-from-source checkout + #:commit commit + #:verbose? + (assoc-ref opts 'verbose?)))))))))))) ;;; pull.scm ends here diff --git a/guix/self.scm b/guix/self.scm new file mode 100644 index 0000000000..242fc9defa --- /dev/null +++ b/guix/self.scm @@ -0,0 +1,619 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix self) + #:use-module (guix config) + #:use-module (guix modules) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix discovery) + #:use-module (guix packages) + #:use-module (guix sets) + #:use-module (guix build utils) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + #:export (compiled-guix + guix-derivation + reload-guix)) + + +;;; +;;; Dependency handling. +;;; + +(define* (false-if-wrong-guile package + #:optional (guile-version (effective-version))) + "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., +2.0 instead of 2.2), otherwise return PACKAGE." + (let ((guile (any (match-lambda + ((label (? package? dep) _ ...) + (and (string=? (package-name dep) "guile") + dep))) + (package-direct-inputs package)))) + (and (or (not guile) + (string-prefix? guile-version + (package-version guile))) + package))) + +(define (package-for-guile guile-version . names) + "Return the package with one of the given NAMES that depends on +GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." + (let loop ((names names)) + (match names + (() + #f) + ((name rest ...) + (match (specification->package name) + (#f + (loop rest)) + ((? package? package) + (or (false-if-wrong-guile package) + (loop rest)))))))) + + +;;; +;;; Derivations. +;;; + +;; Node in a DAG of build tasks. Each node maps to a derivation, but it's +;; easier to express things this way. +(define-record-type + (node name modules source dependencies compiled) + node? + (name node-name) ;string + (modules node-modules) ;list of module names + (source node-source) ;list of source files + (dependencies node-dependencies) ;list of nodes + (compiled node-compiled)) ;node -> lowerable object + +(define (node-fold proc init nodes) + (let loop ((nodes nodes) + (visited (setq)) + (result init)) + (match nodes + (() result) + ((head tail ...) + (if (set-contains? visited head) + (loop tail visited result) + (loop tail (set-insert head visited) + (proc head result))))))) + +(define (node-modules/recursive nodes) + (node-fold (lambda (node modules) + (append (node-modules node) modules)) + '() + nodes)) + +(define* (closure modules #:optional (except '())) + (source-module-closure modules + #:select? + (match-lambda + (('guix 'config) + #f) + ((and module + (or ('guix _ ...) ('gnu _ ...))) + (not (member module except))) + (rest #f)))) + +(define module->import + ;; Return a file-name/file-like object pair for the specified module and + ;; suitable for 'imported-files'. + (match-lambda + ((module '=> thing) + (let ((file (module-name->file-name module))) + (list file thing))) + (module + (let ((file (module-name->file-name module))) + (list file + (local-file (search-path %load-path file))))))) + +(define* (scheme-node name modules #:optional (dependencies '()) + #:key (extra-modules '()) (extra-files '()) + (extensions '()) + parallel?) + "Return a node that builds the given Scheme MODULES, and depends on +DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules +added to the source, and EXTRA-FILES is a list of additional files. +EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that +must be present in the search path." + (let* ((modules (append extra-modules + (closure modules + (node-modules/recursive dependencies)))) + (module-files (map module->import modules)) + (source (imported-files (string-append name "-source") + (append module-files extra-files)))) + (node name modules source dependencies + (compiled-modules name source modules + (map node-source dependencies) + (map node-compiled dependencies) + #:extensions extensions + #:parallel? parallel?)))) + +(define (file-imports directory sub-directory pred) + "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a +list of file-name/file-like objects suitable as inputs to 'imported-files'." + (map (lambda (file) + (list (string-drop file (+ 1 (string-length directory))) + (local-file file #:recursive? #t))) + (find-files (string-append directory "/" sub-directory) pred))) + +(define (scheme-modules* directory sub-directory) + "Return the list of module names found under SUB-DIRECTORY in DIRECTORY." + (let ((prefix (string-length directory))) + (map (lambda (file) + (file-name->module-name (string-drop file prefix))) + (scheme-files (string-append directory "/" sub-directory))))) + +(define* (compiled-guix source #:key (version %guix-version) + (guile-version (effective-version)) + (libgcrypt (specification->package "libgcrypt")) + (zlib (specification->package "zlib")) + (gzip (specification->package "gzip")) + (bzip2 (specification->package "bzip2")) + (xz (specification->package "xz"))) + "Return a file-like object that contains a compiled Guix." + (define guile-json + (package-for-guile guile-version + "guile-json" + "guile2.2-json" + "guile2.0-json")) + + (define guile-ssh + (package-for-guile guile-version + "guile-ssh" + "guile2.2-ssh" + "guile2.0-ssh")) + + (define guile-git + (package-for-guile guile-version + "guile-git" + "guile2.0-git")) + + + (define dependencies + (match (append-map (lambda (package) + (cons (list "x" package) + (package-transitive-inputs package))) + (list guile-git guile-json guile-ssh)) + (((labels packages _ ...) ...) + packages))) + + (define *core-modules* + (scheme-node "guix-core" + '((guix) + (guix monad-repl) + (guix packages) + (guix download) + (guix discovery) + (guix profiles) + (guix build-system gnu) + (guix build-system trivial) + (guix build profiles) + (guix build gnu-build-system)) + + ;; Provide a dummy (guix config) with the default version + ;; number, storedir, etc. This is so that "guix-core" is the + ;; same across all installations and doesn't need to be + ;; rebuilt when the version changes, which in turn means we + ;; can have substitutes for it. + #:extra-modules + `(((guix config) + => ,(make-config.scm #:libgcrypt + (specification->package "libgcrypt")))))) + + (define *extra-modules* + (scheme-node "guix-extra" + (filter-map (match-lambda + (('guix 'scripts _ ..1) #f) + (name name)) + (scheme-modules* source "guix")) + (list *core-modules*) + #:extensions dependencies)) + + (define *package-modules* + (scheme-node "guix-packages" + `((gnu packages) + ,@(scheme-modules* source "gnu/packages")) + (list *core-modules* *extra-modules*) + #:extra-files ;all the non-Scheme files + (file-imports source "gnu/packages" + (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (not (string-suffix? ".scm" file)) + (not (string-suffix? ".go" file)) + (not (string-prefix? ".#" file)) + (not (string-suffix? "~" file))))))) + + (define *system-modules* + (scheme-node "guix-system" + `((gnu system) + (gnu services) + ,@(scheme-modules* source "gnu/system") + ,@(scheme-modules* source "gnu/services")) + (list *package-modules* *extra-modules* *core-modules*) + #:extra-files + (file-imports source "gnu/system/examples" (const #t)))) + + (define *cli-modules* + (scheme-node "guix-cli" + (scheme-modules* source "/guix/scripts") + (list *core-modules* *extra-modules* *package-modules* + *system-modules*) + #:extensions dependencies)) + + (define *config* + (scheme-node "guix-config" + '() + #:extra-modules + `(((guix config) + => ,(make-config.scm #:libgcrypt libgcrypt + #:zlib zlib + #:gzip gzip + #:bzip2 bzip2 + #:xz xz + #:package-name + %guix-package-name + #:package-version + version + #:bug-report-address + %guix-bug-report-address + #:home-page-url + %guix-home-page-url))))) + + (directory-union (string-append "guix-" version) + (append-map (lambda (node) + (list (node-source node) + (node-compiled node))) + + ;; Note: *CONFIG* comes first so that it + ;; overrides the (guix config) module that + ;; comes with *CORE-MODULES*. + (list *config* + *cli-modules* + *system-modules* + *package-modules* + *extra-modules* + *core-modules*)) + + ;; When we do (add-to-store "utils.scm"), "utils.scm" must + ;; be a regular file, not a symlink. Thus, arrange so that + ;; regular files appear as regular files in the final + ;; output. + #:copy? #t + #:quiet? #t)) + + +;;; +;;; (guix config) generation. +;;; + +(define %dependency-variables + ;; (guix config) variables corresponding to dependencies. + '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate)) + +(define %persona-variables + ;; (guix config) variables that define Guix's persona. + '(%guix-package-name + %guix-version + %guix-bug-report-address + %guix-home-page-url)) + +(define %config-variables + ;; (guix config) variables corresponding to Guix configuration (storedir, + ;; localstatedir, etc.) + (sort (filter pair? + (module-map (lambda (name var) + (and (not (memq name %dependency-variables)) + (not (memq name %persona-variables)) + (cons name (variable-ref var)))) + (resolve-interface '(guix config)))) + (lambda (name+value1 name+value2) + (stringstring (car name+value1)) + (symbol->string (car name+value2)))))) + +(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 + (package-name "GNU Guix") + (package-version "0") + (bug-report-address "bug-guix@gnu.org") + (home-page-url "https://gnu.org/s/guix")) + + ;; Hack so that Geiser is not confused. + (define defmod 'define-module) + + (scheme-file "config.scm" + #~(begin + (#$defmod (guix config) + #:export (%guix-package-name + %guix-version + %guix-bug-report-address + %guix-home-page-url + %libgcrypt + %libz + %gzip + %bzip2 + %xz + %nix-instantiate)) + + ;; XXX: Work around . + (eval-when (expand load eval) + #$@(map (match-lambda + ((name . value) + #~(define-public #$name #$value))) + %config-variables) + + (define %guix-package-name #$package-name) + (define %guix-version #$package-version) + (define %guix-bug-report-address #$bug-report-address) + (define %guix-home-page-url #$home-page-url) + + (define %gzip + #+(and gzip (file-append gzip "/bin/gzip"))) + (define %bzip2 + #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) + (define %xz + #+(and xz (file-append xz "/bin/xz"))) + + (define %libgcrypt + #+(and libgcrypt + (file-append libgcrypt "/lib/libgcrypt"))) + (define %libz + #+(and zlib + (file-append zlib "/lib/libz"))) + + (define %nix-instantiate ;for (guix import snix) + "nix-instantiate"))))) + + + +;;; +;;; Building. +;;; + +(define (imported-files name files) + ;; This is a non-monadic, simplified version of 'imported-files' from (guix + ;; gexp). + (define build + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + + (mkdir (ungexp output)) (chdir (ungexp output)) + (for-each (match-lambda + ((final-path store-path) + (mkdir-p (dirname final-path)) + + ;; Note: We need regular files to be regular files, not + ;; symlinks, as this makes a difference for + ;; 'add-to-store'. + (copy-file store-path final-path))) + '#$files)))) + + (computed-file name build)) + +(define* (compiled-modules name module-tree modules + #:optional + (dependencies '()) + (dependencies-compiled '()) + #:key + (extensions '()) ;full-blown Guile packages + parallel?) + ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix + ;; gexp). + (define build + (with-imported-modules (source-module-closure + '((guix build compile) + (guix build utils))) + #~(begin + (use-modules (srfi srfi-26) + (ice-9 match) + (ice-9 format) + (ice-9 threads) + (guix build compile) + (guix build utils)) + + (define (regular? file) + (not (member file '("." "..")))) + + (define (report-load file total completed) + (display #\cr) + (format #t + "loading...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output)) + + (define (report-compilation file total completed) + (display #\cr) + (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output)) + + (define (process-directory directory output) + (let ((files (find-files directory "\\.scm$")) + (prefix (+ 1 (string-length directory)))) + ;; Hide compilation warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-files directory #$output + (map (cut string-drop <> prefix) files) + #:workers (parallel-job-count) + #:report-load report-load + #:report-compilation report-compilation)))) + + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) _IONBF) + + (set! %load-path (cons #+module-tree %load-path)) + (set! %load-path + (append '#+dependencies + (map (lambda (extension) + (string-append extension "/share/guile/site/" + (effective-version))) + '#+extensions) + %load-path)) + + (set! %load-compiled-path + (append '#+dependencies-compiled + (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + '#+extensions) + %load-compiled-path)) + + ;; Load the compiler modules upfront. + (compile #f) + + (mkdir #$output) + (chdir #+module-tree) + (process-directory "." #$output)))) + + (computed-file name build + #:options + '(#:local-build? #f ;allow substitutes + + ;; Don't annoy people about _IONBF deprecation. + #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) + + +;;; +;;; Live patching. +;;; + +(define (recursive-submodules module) + "Return the list of submodules of MODULE." + (let loop ((module module) + (result '())) + (let ((submodules (hash-map->list (lambda (name module) + module) + (module-submodules module)))) + (fold loop (append submodules result) submodules)))) + +(define (remove-submodule! module names) + (let loop ((module module) + (names names)) + (match names + (() #t) + ((head tail ...) + (match (nested-ref-module module tail) + (#f #t) + ((? module? submodule) + (hashq-remove! (module-submodules module) head) + (loop submodule tail))))))) + +(define (unload-module-tree! module) + (define (strip-prefix prefix lst) + (let loop ((prefix prefix) + (lst lst)) + (match prefix + (() + lst) + ((_ prefix ...) + (match lst + ((_ lst ...) + (loop prefix lst))))))) + + (let ((submodules (hash-map->list (lambda (name module) + module) + (module-submodules module)))) + (let loop ((root module) + (submodules submodules)) + (match submodules + (() + #t) + ((head tail ...) + (unload-module-tree! head) + (remove-submodule! root + (strip-prefix (module-name root) + (module-name head))) + + (match (module-name head) + ((parents ... leaf) + ;; Remove MODULE from the AUTOLOADS-DONE list. Note: We don't use + ;; 'module-filename' because it could be an absolute file name. + (set-autoloaded! (string-join (map symbol->string parents) + "/" 'suffix) + (symbol->string leaf) #f))) + (loop root tail)))))) + +(define* (reload-guix #:optional (log-port (current-error-port))) + "Reload all the Guix and GNU modules currently loaded." + (let* ((guix (resolve-module '(guix) #f #:ensure #f)) + (gnu (resolve-module '(gnu) #f #:ensure #f)) + (guix-submodules (recursive-submodules guix)) + (gnu-submodules (recursive-submodules gnu))) + (define (reload module) + (match (module-filename module) + (#f #f) + ((? string? file) + ;; The following should auto-compile FILE. + (primitive-load-path file)))) + + ;; First, we need to nuke all the (guix) and (gnu) submodules so we don't + ;; end up with a mixture of old and new modules when we reload (which + ;; wouldn't work, because we'd have two different record types, + ;; for instance.) + (format log-port "Unloading current Guix...~%") + (unload-module-tree! gnu) + (unload-module-tree! guix) + + (format log-port "Loading new Guix...~%") + (for-each reload (append guix-submodules (list guix))) + (for-each reload (append gnu-submodules (list gnu))) + (format log-port "New Guix modules successfully loaded.~%"))) + + +;;; +;;; Building. +;;; + +(define* (guile-for-build #:optional (version (effective-version))) + "Return a package for Guile VERSION." + (define canonical-package ;soft reference + (module-ref (resolve-interface '(gnu packages base)) + 'canonical-package)) + + (match version + ("2.2" + (canonical-package + (specification->package "guile@2.2"))) + ("2.0" + (canonical-package + (specification->package "guile@2.0"))))) + +(define* (guix-derivation source version + #:optional (guile-version (effective-version))) + "Return, as a monadic value, the derivation to build the Guix from SOURCE +for GUILE-VERSION. Use VERSION as the version string." + (define max-version-length 9) + + (define (shorten version) + ;; TODO: VERSION is a commit id, but we'd rather use something like what + ;; 'git describe' provides. + (if (> (string-length version) max-version-length) + (string-take version max-version-length) + version)) + + (mbegin %store-monad + (set-guile-for-build (guile-for-build guile-version)) + (lower-object (compiled-guix source + #:version (shorten version) + #:guile-version guile-version)))) -- cgit v1.2.3 From cd295fbe170a93844f9c42cbfaa0fbe2490b6693 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 21 Nov 2017 23:51:59 +0100 Subject: Revert "Add (guix self) and use it when pulling." This reverts commit 5f93d97005897c2d859f0be1bdff34c88467ec61. 'guix pull' would fail because (guix self) needs 'scheme-files' from (guix discovery), which was not exported until now. --- Makefile.am | 1 - build-aux/build-self.scm | 272 ++++++++++++++++----- gnu/packages.scm | 21 +- guix/discovery.scm | 3 +- guix/scripts/pull.scm | 91 +++---- guix/self.scm | 619 ----------------------------------------------- 6 files changed, 252 insertions(+), 755 deletions(-) delete mode 100644 guix/self.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index d64806de87..eab49181ad 100644 --- a/Makefile.am +++ b/Makefile.am @@ -66,7 +66,6 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/gnu-maintenance.scm \ - guix/self.scm \ guix/upstream.scm \ guix/licenses.scm \ guix/git.scm \ diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index d9d9263678..ed8ff5f4ce 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -17,9 +17,11 @@ ;;; along with GNU Guix. If not, see . (define-module (build-self) + #:use-module (gnu) + #:use-module (guix) + #:use-module (guix config) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (build)) @@ -29,51 +31,105 @@ ;;; argument: the source tree to build. It returns a derivation that ;;; builds it. ;;; +;;; This file uses modules provided by the already-installed Guix. Those +;;; modules may be arbitrarily old compared to the version we want to +;;; build. Because of that, it must rely on the smallest set of features +;;; that are likely to be provided by the (guix) and (gnu) modules, and by +;;; Guile itself, forever and ever. +;;; ;;; Code: -;; Use our very own Guix modules. -(eval-when (compile load eval) + +;; The dependencies. Don't refer explicitly to the variables because they +;; could be renamed or shuffled around in modules over time. Conversely, +;; 'find-best-packages-by-name' is expected to always have the same semantics. + +(define libgcrypt + (first (find-best-packages-by-name "libgcrypt" #f))) + +(define zlib + (first (find-best-packages-by-name "zlib" #f))) + +(define gzip + (first (find-best-packages-by-name "gzip" #f))) + +(define bzip2 + (first (find-best-packages-by-name "bzip2" #f))) + +(define xz + (first (find-best-packages-by-name "xz" #f))) + +(define (false-if-wrong-guile package) + "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., +2.0 instead of 2.2), otherwise return PACKAGE." + (let ((guile (any (match-lambda + ((label (? package? dep) _ ...) + (and (string=? (package-name dep) "guile") + dep))) + (package-direct-inputs package)))) + (and (or (not guile) + (string-prefix? (effective-version) + (package-version guile))) + package))) + +(define (package-for-current-guile . names) + "Return the package with one of the given NAMES that depends on the current +Guile major version (2.0 or 2.2), or #f if none of the packages matches." + (let loop ((names names)) + (match names + (() + #f) + ((name rest ...) + (match (find-best-packages-by-name name #f) + (() + (loop rest)) + ((first _ ...) + (or (false-if-wrong-guile first) + (loop rest)))))))) + +(define guile-json + (package-for-current-guile "guile-json" + "guile2.2-json" + "guile2.0-json")) + +(define guile-ssh + (package-for-current-guile "guile-ssh" + "guile2.2-ssh" + "guile2.0-ssh")) + +(define guile-git + (package-for-current-guile "guile-git" + "guile2.0-git")) + +(define guile-bytestructures + (package-for-current-guile "guile-bytestructures" + "guile2.0-bytestructures")) + +;; The actual build procedure. + +(define (top-source-directory) + "Return the name of the top-level directory of this source tree." (and=> (assoc-ref (current-source-location) 'filename) (lambda (file) - (let ((dir (string-append (dirname file) "/.."))) - (set! %load-path (cons dir %load-path)))))) + (string-append (dirname file) "/..")))) + (define (date-version-string) "Return the current date and hour in UTC timezone, for use as a poor person's version identifier." - ;; XXX: Last resort when the Git commit id is missing. + ;; XXX: Replace with a Git commit id. (date->string (current-date 0) "~Y~m~d.~H")) -(define-syntax parameterize* - (syntax-rules () - "Like 'parameterize' but for regular variables (!)." - ((_ ((var value) rest ...) body ...) - (let ((old var) - (new value)) - (dynamic-wind - (lambda () - (set! var new)) - (lambda () - (parameterize* (rest ...) body ...)) - (lambda () - (set! var old))))) - ((_ () body ...) - (begin body ...)))) - -(define (pure-load-compiled-path) - "Return %LOAD-COMPILED-PATH minus the directories containing .go files from -Guix." - (define (purify path) - (fold-right delete path - (filter-map (lambda (file) - (and=> (search-path path file) dirname)) - '("guix.go" "gnu.go")))) - - (let loop ((path %load-compiled-path)) - (let ((next (purify path))) - (if (equal? next path) - path - (loop next))))) +(define (guile-for-build) + "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently +running Guile." + (package->derivation (cond-expand + (guile-2.2 + (canonical-package + (specification->package "guile@2.2"))) + (else + (canonical-package + (specification->package "guile@2.0")))))) ;; The procedure below is our return value. (define* (build source @@ -82,29 +138,131 @@ Guix." #:rest rest) "Return a derivation that unpacks SOURCE into STORE and compiles Scheme files." - ;; Start by jumping into the target Guix so that we have access to the - ;; latest packages and APIs. - ;; - ;; Our checkout in the store has mtime set to the epoch, and thus .go - ;; files look newer, even though they may not correspond. - (parameterize* ((%load-should-auto-compile #f) - (%fresh-auto-compile #f) - - ;; Work around . - (%load-compiled-path (pure-load-compiled-path))) - ;; FIXME: This is currently too expensive notably because it involves - ;; compiling a number of the big package files such as perl.scm, which - ;; takes lots of time and memory as of Guile 2.2.2. - ;; - ;; (let ((reload-guix (module-ref (resolve-interface '(guix self)) - ;; 'reload-guix))) - ;; (reload-guix)) ;cross fingers! - - (let ((guix-derivation (module-ref (resolve-interface '(guix self)) - 'guix-derivation))) - (guix-derivation source version)))) + ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we + ;; cannot assume that they are defined. Try to guess their value when + ;; they're undefined (XXX: we get an incorrect guess when environment + ;; variables such as 'NIX_STATE_DIR' are defined!). + (define storedir + (if (defined? '%storedir) %storedir %store-directory)) + (define localstatedir + (if (defined? '%localstatedir) %localstatedir (dirname %state-directory))) + (define sysconfdir + (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory))) + (define sbindir + (if (defined? '%sbindir) %sbindir (dirname %guix-register-program))) + + (define builder + #~(begin + (use-modules (guix build pull)) + + (letrec-syntax ((maybe-load-path + (syntax-rules () + ((_ item rest ...) + (let ((tail (maybe-load-path rest ...))) + (if (string? item) + (cons (string-append item + "/share/guile/site/" + #$(effective-version)) + tail) + tail))) + ((_) + '())))) + (set! %load-path + (append + (maybe-load-path #$guile-json #$guile-ssh + #$guile-git #$guile-bytestructures) + %load-path))) + + (letrec-syntax ((maybe-load-compiled-path + (syntax-rules () + ((_ item rest ...) + (let ((tail (maybe-load-compiled-path rest ...))) + (if (string? item) + (cons (string-append item + "/lib/guile/" + #$(effective-version) + "/site-ccache") + tail) + tail))) + ((_) + '())))) + (set! %load-compiled-path + (append + (maybe-load-compiled-path #$guile-json #$guile-ssh + #$guile-git #$guile-bytestructures) + %load-compiled-path))) + + ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was + ;; broken: libguile-ssh could not be found. Work around that. + ;; FIXME: We want Guile-SSH 0.10.2 or later anyway. + #$(if (string-prefix? "0.9." (package-version guile-ssh)) + #~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib")) + #t) + + (build-guix #$output #$source + + #:system #$%system + #:storedir #$storedir + #:localstatedir #$localstatedir + #:sysconfdir #$sysconfdir + #:sbindir #$sbindir + + #:package-name #$%guix-package-name + #:package-version #$version + #:bug-report-address #$%guix-bug-report-address + #:home-page-url #$%guix-home-page-url + + #:libgcrypt #$libgcrypt + #:zlib #$zlib + #:gzip #$gzip + #:bzip2 #$bzip2 + #:xz #$xz + + ;; XXX: This is not perfect, enabling VERBOSE? means + ;; building a different derivation. + #:debug-port (if #$verbose? + (current-error-port) + (%make-void-port "w"))))) + + (unless guile-git + ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether. + ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not + ;; build (guix git), which will leave us with an unusable 'guix pull'. To + ;; avoid that, fail early. + (format (current-error-port) + "\ +Your installation is too old and lacks a '~a' package. +Please upgrade to an intermediate version first, for instance with: + + guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz +\n" + (match (effective-version) + ("2.0" "guile2.0-git") + (_ "guile-git"))) + (exit 1)) + + (mlet %store-monad ((guile (guile-for-build))) + (gexp->derivation "guix-latest" builder + #:modules '((guix build pull) + (guix build utils) + (guix build compile) + + ;; Closure of (guix modules). + (guix modules) + (guix memoization) + (guix sets)) + + ;; Arrange so that our own (guix build …) modules are + ;; used. + #:module-path (list (top-source-directory)) + + #:guile-for-build guile))) ;; This file is loaded by 'guix pull'; return it the build procedure. build +;; Local Variables: +;; eval: (put 'with-load-path 'scheme-indent-function 1) +;; End: + ;;; build-self.scm ends here diff --git a/gnu/packages.scm b/gnu/packages.scm index 44a56dfde0..97e6cb347f 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -110,25 +110,8 @@ for system '~a'") file-name system))))))) (define %distro-root-directory - ;; Absolute file name of the module hierarchy. Since (gnu packages …) might - ;; live in a directory different from (guix), try to get the best match. - (letrec-syntax ((dirname* (syntax-rules () - ((_ file) - (dirname file)) - ((_ file head tail ...) - (dirname (dirname* file tail ...))))) - (try (syntax-rules () - ((_ (file things ...) rest ...) - (match (search-path %load-path file) - (#f - (try rest ...)) - (absolute - (dirname* absolute things ...)))) - ((_) - #f)))) - (try ("gnu/packages/base.scm" gnu/ packages/) - ("gnu/packages.scm" gnu/) - ("guix.scm")))) + ;; Absolute file name of the module hierarchy. + (dirname (search-path %load-path "guix.scm"))) (define %package-module-path ;; Search path for package modules. Each item must be either a directory diff --git a/guix/discovery.scm b/guix/discovery.scm index 8ffcf7cd9a..7b57579023 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -25,8 +25,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 ftw) - #:export (scheme-files - scheme-modules + #:export (scheme-modules fold-modules all-modules fold-module-public-variables)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 083b5c3711..3e95bd511f 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -149,6 +149,8 @@ Download and deploy the latest version of Guix.\n")) (define what-to-build (store-lift show-what-to-build)) +(define indirect-root-added + (store-lift add-indirect-root)) (define %self-build-file ;; The file containing code to build Guix. This serves the same purpose as @@ -169,48 +171,33 @@ contained therein. Use COMMIT as the version string." ;; tree. (build source #:verbose? verbose? #:version commit))) -(define* (install-latest source-dir config-dir) - "Make SOURCE-DIR, a store file name, the latest Guix in CONFIG-DIR." - (let ((latest (string-append config-dir "/latest"))) - (if (and (file-exists? latest) - (string=? (readlink latest) source-dir)) - (begin - (display (G_ "Guix already up to date\n")) - #t) - (begin - (switch-symlinks latest source-dir) - (format #t - (G_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - #t)))) - -(define (build-and-install mdrv) - "Bind MDRV, a monadic value for a derivation, build it, and finally install -it as the latest Guix." - (define do-it - ;; Weirdness follows! Before we were called, the Guix modules have - ;; probably been reloaded, leading to a "parallel universe" with disjoint - ;; record types. However, procedures in this file have already cached the - ;; module relative to which they lookup global bindings (see - ;; 'toplevel-box' documentation), so they're stuck in the old world. To - ;; work around that, evaluate our procedure in the context of the "new" - ;; (guix scripts pull) module--which has access to the new - ;; record, and so on. - (eval '(lambda (mdrv cont) - ;; Reopen a connection to the daemon so that we have a record - ;; with the new type. - (with-store store - (run-with-store store - (mlet %store-monad ((drv mdrv)) - (mbegin %store-monad - (what-to-build (list drv)) - (built-derivations (list drv)) - (return (cont (derivation->output-path drv)))))))) - (resolve-module '(guix scripts pull)))) ;the new module - - (do-it mdrv - (lambda (result) - (install-latest result (config-directory))))) +(define* (build-and-install source config-dir + #:key verbose? commit) + "Build the tool from SOURCE, and install it in CONFIG-DIR." + (mlet* %store-monad ((source (build-from-source source + #:commit commit + #:verbose? verbose?)) + (source-dir -> (derivation->output-path source)) + (to-do? (what-to-build (list source))) + (built? (built-derivations (list source)))) + ;; Always update the 'latest' symlink, regardless of whether SOURCE was + ;; already built or not. + (if built? + (mlet* %store-monad + ((latest -> (string-append config-dir "/latest")) + (done (indirect-root-added latest))) + (if (and (file-exists? latest) + (string=? (readlink latest) source-dir)) + (begin + (display (G_ "Guix already up to date\n")) + (return #t)) + (begin + (switch-symlinks latest source-dir) + (format #t + (G_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + (return #t)))) + (leave (G_ "failed to update Guix, check the build log~%"))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -271,10 +258,6 @@ certificates~%")) (when (use-le-certs? url) (honor-lets-encrypt-certificates! store)) - ;; Ensure the 'latest' symlink is registered as a GC root. - (add-indirect-root store - (string-append (config-directory) "/latest")) - (format (current-error-port) (G_ "Updating from Git repository at '~a'...~%") url) @@ -293,16 +276,10 @@ certificates~%")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.0))))) - - ;; 'build-from-source' may cause a reload of the Guix - ;; modules. This leads to a parallel world: its record types - ;; are disjoint from those we've seen until now (because we - ;; use "generative" record types), and so on. Thus, special - ;; care must be taken once we have return from that call. - (build-and-install - (build-from-source checkout - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?)))))))))))) + (run-with-store store + (build-and-install checkout (config-directory) + #:commit commit + #:verbose? + (assoc-ref opts 'verbose?)))))))))))) ;;; pull.scm ends here diff --git a/guix/self.scm b/guix/self.scm deleted file mode 100644 index 242fc9defa..0000000000 --- a/guix/self.scm +++ /dev/null @@ -1,619 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès -;;; -;;; 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 . - -(define-module (guix self) - #:use-module (guix config) - #:use-module (guix modules) - #:use-module (guix gexp) - #:use-module (guix store) - #:use-module (guix monads) - #:use-module (guix discovery) - #:use-module (guix packages) - #:use-module (guix sets) - #:use-module (guix build utils) - #:use-module (gnu packages) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (ice-9 match) - #:export (compiled-guix - guix-derivation - reload-guix)) - - -;;; -;;; Dependency handling. -;;; - -(define* (false-if-wrong-guile package - #:optional (guile-version (effective-version))) - "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., -2.0 instead of 2.2), otherwise return PACKAGE." - (let ((guile (any (match-lambda - ((label (? package? dep) _ ...) - (and (string=? (package-name dep) "guile") - dep))) - (package-direct-inputs package)))) - (and (or (not guile) - (string-prefix? guile-version - (package-version guile))) - package))) - -(define (package-for-guile guile-version . names) - "Return the package with one of the given NAMES that depends on -GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." - (let loop ((names names)) - (match names - (() - #f) - ((name rest ...) - (match (specification->package name) - (#f - (loop rest)) - ((? package? package) - (or (false-if-wrong-guile package) - (loop rest)))))))) - - -;;; -;;; Derivations. -;;; - -;; Node in a DAG of build tasks. Each node maps to a derivation, but it's -;; easier to express things this way. -(define-record-type - (node name modules source dependencies compiled) - node? - (name node-name) ;string - (modules node-modules) ;list of module names - (source node-source) ;list of source files - (dependencies node-dependencies) ;list of nodes - (compiled node-compiled)) ;node -> lowerable object - -(define (node-fold proc init nodes) - (let loop ((nodes nodes) - (visited (setq)) - (result init)) - (match nodes - (() result) - ((head tail ...) - (if (set-contains? visited head) - (loop tail visited result) - (loop tail (set-insert head visited) - (proc head result))))))) - -(define (node-modules/recursive nodes) - (node-fold (lambda (node modules) - (append (node-modules node) modules)) - '() - nodes)) - -(define* (closure modules #:optional (except '())) - (source-module-closure modules - #:select? - (match-lambda - (('guix 'config) - #f) - ((and module - (or ('guix _ ...) ('gnu _ ...))) - (not (member module except))) - (rest #f)))) - -(define module->import - ;; Return a file-name/file-like object pair for the specified module and - ;; suitable for 'imported-files'. - (match-lambda - ((module '=> thing) - (let ((file (module-name->file-name module))) - (list file thing))) - (module - (let ((file (module-name->file-name module))) - (list file - (local-file (search-path %load-path file))))))) - -(define* (scheme-node name modules #:optional (dependencies '()) - #:key (extra-modules '()) (extra-files '()) - (extensions '()) - parallel?) - "Return a node that builds the given Scheme MODULES, and depends on -DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules -added to the source, and EXTRA-FILES is a list of additional files. -EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that -must be present in the search path." - (let* ((modules (append extra-modules - (closure modules - (node-modules/recursive dependencies)))) - (module-files (map module->import modules)) - (source (imported-files (string-append name "-source") - (append module-files extra-files)))) - (node name modules source dependencies - (compiled-modules name source modules - (map node-source dependencies) - (map node-compiled dependencies) - #:extensions extensions - #:parallel? parallel?)))) - -(define (file-imports directory sub-directory pred) - "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a -list of file-name/file-like objects suitable as inputs to 'imported-files'." - (map (lambda (file) - (list (string-drop file (+ 1 (string-length directory))) - (local-file file #:recursive? #t))) - (find-files (string-append directory "/" sub-directory) pred))) - -(define (scheme-modules* directory sub-directory) - "Return the list of module names found under SUB-DIRECTORY in DIRECTORY." - (let ((prefix (string-length directory))) - (map (lambda (file) - (file-name->module-name (string-drop file prefix))) - (scheme-files (string-append directory "/" sub-directory))))) - -(define* (compiled-guix source #:key (version %guix-version) - (guile-version (effective-version)) - (libgcrypt (specification->package "libgcrypt")) - (zlib (specification->package "zlib")) - (gzip (specification->package "gzip")) - (bzip2 (specification->package "bzip2")) - (xz (specification->package "xz"))) - "Return a file-like object that contains a compiled Guix." - (define guile-json - (package-for-guile guile-version - "guile-json" - "guile2.2-json" - "guile2.0-json")) - - (define guile-ssh - (package-for-guile guile-version - "guile-ssh" - "guile2.2-ssh" - "guile2.0-ssh")) - - (define guile-git - (package-for-guile guile-version - "guile-git" - "guile2.0-git")) - - - (define dependencies - (match (append-map (lambda (package) - (cons (list "x" package) - (package-transitive-inputs package))) - (list guile-git guile-json guile-ssh)) - (((labels packages _ ...) ...) - packages))) - - (define *core-modules* - (scheme-node "guix-core" - '((guix) - (guix monad-repl) - (guix packages) - (guix download) - (guix discovery) - (guix profiles) - (guix build-system gnu) - (guix build-system trivial) - (guix build profiles) - (guix build gnu-build-system)) - - ;; Provide a dummy (guix config) with the default version - ;; number, storedir, etc. This is so that "guix-core" is the - ;; same across all installations and doesn't need to be - ;; rebuilt when the version changes, which in turn means we - ;; can have substitutes for it. - #:extra-modules - `(((guix config) - => ,(make-config.scm #:libgcrypt - (specification->package "libgcrypt")))))) - - (define *extra-modules* - (scheme-node "guix-extra" - (filter-map (match-lambda - (('guix 'scripts _ ..1) #f) - (name name)) - (scheme-modules* source "guix")) - (list *core-modules*) - #:extensions dependencies)) - - (define *package-modules* - (scheme-node "guix-packages" - `((gnu packages) - ,@(scheme-modules* source "gnu/packages")) - (list *core-modules* *extra-modules*) - #:extra-files ;all the non-Scheme files - (file-imports source "gnu/packages" - (lambda (file stat) - (and (eq? 'regular (stat:type stat)) - (not (string-suffix? ".scm" file)) - (not (string-suffix? ".go" file)) - (not (string-prefix? ".#" file)) - (not (string-suffix? "~" file))))))) - - (define *system-modules* - (scheme-node "guix-system" - `((gnu system) - (gnu services) - ,@(scheme-modules* source "gnu/system") - ,@(scheme-modules* source "gnu/services")) - (list *package-modules* *extra-modules* *core-modules*) - #:extra-files - (file-imports source "gnu/system/examples" (const #t)))) - - (define *cli-modules* - (scheme-node "guix-cli" - (scheme-modules* source "/guix/scripts") - (list *core-modules* *extra-modules* *package-modules* - *system-modules*) - #:extensions dependencies)) - - (define *config* - (scheme-node "guix-config" - '() - #:extra-modules - `(((guix config) - => ,(make-config.scm #:libgcrypt libgcrypt - #:zlib zlib - #:gzip gzip - #:bzip2 bzip2 - #:xz xz - #:package-name - %guix-package-name - #:package-version - version - #:bug-report-address - %guix-bug-report-address - #:home-page-url - %guix-home-page-url))))) - - (directory-union (string-append "guix-" version) - (append-map (lambda (node) - (list (node-source node) - (node-compiled node))) - - ;; Note: *CONFIG* comes first so that it - ;; overrides the (guix config) module that - ;; comes with *CORE-MODULES*. - (list *config* - *cli-modules* - *system-modules* - *package-modules* - *extra-modules* - *core-modules*)) - - ;; When we do (add-to-store "utils.scm"), "utils.scm" must - ;; be a regular file, not a symlink. Thus, arrange so that - ;; regular files appear as regular files in the final - ;; output. - #:copy? #t - #:quiet? #t)) - - -;;; -;;; (guix config) generation. -;;; - -(define %dependency-variables - ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate)) - -(define %persona-variables - ;; (guix config) variables that define Guix's persona. - '(%guix-package-name - %guix-version - %guix-bug-report-address - %guix-home-page-url)) - -(define %config-variables - ;; (guix config) variables corresponding to Guix configuration (storedir, - ;; localstatedir, etc.) - (sort (filter pair? - (module-map (lambda (name var) - (and (not (memq name %dependency-variables)) - (not (memq name %persona-variables)) - (cons name (variable-ref var)))) - (resolve-interface '(guix config)))) - (lambda (name+value1 name+value2) - (stringstring (car name+value1)) - (symbol->string (car name+value2)))))) - -(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 - (package-name "GNU Guix") - (package-version "0") - (bug-report-address "bug-guix@gnu.org") - (home-page-url "https://gnu.org/s/guix")) - - ;; Hack so that Geiser is not confused. - (define defmod 'define-module) - - (scheme-file "config.scm" - #~(begin - (#$defmod (guix config) - #:export (%guix-package-name - %guix-version - %guix-bug-report-address - %guix-home-page-url - %libgcrypt - %libz - %gzip - %bzip2 - %xz - %nix-instantiate)) - - ;; XXX: Work around . - (eval-when (expand load eval) - #$@(map (match-lambda - ((name . value) - #~(define-public #$name #$value))) - %config-variables) - - (define %guix-package-name #$package-name) - (define %guix-version #$package-version) - (define %guix-bug-report-address #$bug-report-address) - (define %guix-home-page-url #$home-page-url) - - (define %gzip - #+(and gzip (file-append gzip "/bin/gzip"))) - (define %bzip2 - #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) - (define %xz - #+(and xz (file-append xz "/bin/xz"))) - - (define %libgcrypt - #+(and libgcrypt - (file-append libgcrypt "/lib/libgcrypt"))) - (define %libz - #+(and zlib - (file-append zlib "/lib/libz"))) - - (define %nix-instantiate ;for (guix import snix) - "nix-instantiate"))))) - - - -;;; -;;; Building. -;;; - -(define (imported-files name files) - ;; This is a non-monadic, simplified version of 'imported-files' from (guix - ;; gexp). - (define build - (with-imported-modules (source-module-closure - '((guix build utils))) - #~(begin - (use-modules (ice-9 match) - (guix build utils)) - - (mkdir (ungexp output)) (chdir (ungexp output)) - (for-each (match-lambda - ((final-path store-path) - (mkdir-p (dirname final-path)) - - ;; Note: We need regular files to be regular files, not - ;; symlinks, as this makes a difference for - ;; 'add-to-store'. - (copy-file store-path final-path))) - '#$files)))) - - (computed-file name build)) - -(define* (compiled-modules name module-tree modules - #:optional - (dependencies '()) - (dependencies-compiled '()) - #:key - (extensions '()) ;full-blown Guile packages - parallel?) - ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix - ;; gexp). - (define build - (with-imported-modules (source-module-closure - '((guix build compile) - (guix build utils))) - #~(begin - (use-modules (srfi srfi-26) - (ice-9 match) - (ice-9 format) - (ice-9 threads) - (guix build compile) - (guix build utils)) - - (define (regular? file) - (not (member file '("." "..")))) - - (define (report-load file total completed) - (display #\cr) - (format #t - "loading...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output)) - - (define (report-compilation file total completed) - (display #\cr) - (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output)) - - (define (process-directory directory output) - (let ((files (find-files directory "\\.scm$")) - (prefix (+ 1 (string-length directory)))) - ;; Hide compilation warnings. - (parameterize ((current-warning-port (%make-void-port "w"))) - (compile-files directory #$output - (map (cut string-drop <> prefix) files) - #:workers (parallel-job-count) - #:report-load report-load - #:report-compilation report-compilation)))) - - (setvbuf (current-output-port) _IONBF) - (setvbuf (current-error-port) _IONBF) - - (set! %load-path (cons #+module-tree %load-path)) - (set! %load-path - (append '#+dependencies - (map (lambda (extension) - (string-append extension "/share/guile/site/" - (effective-version))) - '#+extensions) - %load-path)) - - (set! %load-compiled-path - (append '#+dependencies-compiled - (map (lambda (extension) - (string-append extension "/lib/guile/" - (effective-version) - "/site-ccache")) - '#+extensions) - %load-compiled-path)) - - ;; Load the compiler modules upfront. - (compile #f) - - (mkdir #$output) - (chdir #+module-tree) - (process-directory "." #$output)))) - - (computed-file name build - #:options - '(#:local-build? #f ;allow substitutes - - ;; Don't annoy people about _IONBF deprecation. - #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) - - -;;; -;;; Live patching. -;;; - -(define (recursive-submodules module) - "Return the list of submodules of MODULE." - (let loop ((module module) - (result '())) - (let ((submodules (hash-map->list (lambda (name module) - module) - (module-submodules module)))) - (fold loop (append submodules result) submodules)))) - -(define (remove-submodule! module names) - (let loop ((module module) - (names names)) - (match names - (() #t) - ((head tail ...) - (match (nested-ref-module module tail) - (#f #t) - ((? module? submodule) - (hashq-remove! (module-submodules module) head) - (loop submodule tail))))))) - -(define (unload-module-tree! module) - (define (strip-prefix prefix lst) - (let loop ((prefix prefix) - (lst lst)) - (match prefix - (() - lst) - ((_ prefix ...) - (match lst - ((_ lst ...) - (loop prefix lst))))))) - - (let ((submodules (hash-map->list (lambda (name module) - module) - (module-submodules module)))) - (let loop ((root module) - (submodules submodules)) - (match submodules - (() - #t) - ((head tail ...) - (unload-module-tree! head) - (remove-submodule! root - (strip-prefix (module-name root) - (module-name head))) - - (match (module-name head) - ((parents ... leaf) - ;; Remove MODULE from the AUTOLOADS-DONE list. Note: We don't use - ;; 'module-filename' because it could be an absolute file name. - (set-autoloaded! (string-join (map symbol->string parents) - "/" 'suffix) - (symbol->string leaf) #f))) - (loop root tail)))))) - -(define* (reload-guix #:optional (log-port (current-error-port))) - "Reload all the Guix and GNU modules currently loaded." - (let* ((guix (resolve-module '(guix) #f #:ensure #f)) - (gnu (resolve-module '(gnu) #f #:ensure #f)) - (guix-submodules (recursive-submodules guix)) - (gnu-submodules (recursive-submodules gnu))) - (define (reload module) - (match (module-filename module) - (#f #f) - ((? string? file) - ;; The following should auto-compile FILE. - (primitive-load-path file)))) - - ;; First, we need to nuke all the (guix) and (gnu) submodules so we don't - ;; end up with a mixture of old and new modules when we reload (which - ;; wouldn't work, because we'd have two different record types, - ;; for instance.) - (format log-port "Unloading current Guix...~%") - (unload-module-tree! gnu) - (unload-module-tree! guix) - - (format log-port "Loading new Guix...~%") - (for-each reload (append guix-submodules (list guix))) - (for-each reload (append gnu-submodules (list gnu))) - (format log-port "New Guix modules successfully loaded.~%"))) - - -;;; -;;; Building. -;;; - -(define* (guile-for-build #:optional (version (effective-version))) - "Return a package for Guile VERSION." - (define canonical-package ;soft reference - (module-ref (resolve-interface '(gnu packages base)) - 'canonical-package)) - - (match version - ("2.2" - (canonical-package - (specification->package "guile@2.2"))) - ("2.0" - (canonical-package - (specification->package "guile@2.0"))))) - -(define* (guix-derivation source version - #:optional (guile-version (effective-version))) - "Return, as a monadic value, the derivation to build the Guix from SOURCE -for GUILE-VERSION. Use VERSION as the version string." - (define max-version-length 9) - - (define (shorten version) - ;; TODO: VERSION is a commit id, but we'd rather use something like what - ;; 'git describe' provides. - (if (> (string-length version) max-version-length) - (string-take version max-version-length) - version)) - - (mbegin %store-monad - (set-guile-for-build (guile-for-build guile-version)) - (lower-object (compiled-guix source - #:version (shorten version) - #:guile-version guile-version)))) -- cgit v1.2.3 From b5bfa4773d50b12ec7e71e89892474e7f3c679ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Nov 2017 18:16:43 +0100 Subject: ui: 'known-variable-definition' protects against module cycles. Fixes . Reported by Marius Bakke . * guix/ui.scm (known-variable-definition): Add 'visited' set to guard against cycles on 2.0. --- guix/ui.scm | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 0fc5ab63ad..ae727eb837 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) @@ -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 -- cgit v1.2.3 From 026f6a42b680207a59beadf0b0b9cc1753f55605 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Nov 2017 18:44:08 +0100 Subject: gnu-maintenance: Relax recursion cutoff in 'latest-ftp-release'. Fixes . Reported by Hartmut Goebel . * guix/gnu-maintenance.scm (latest-ftp-release)[contains-digit?]: Remove. Relax test as to whether to recurse into subdirectories. --- guix/gnu-maintenance.scm | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) (limited to 'guix') 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)) -- cgit v1.2.3 From 0d2ecf8b5091eee4fde47f21a9a19ac9d4e38a90 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 28 Nov 2017 10:18:40 +0100 Subject: ui: Avoid "pkg:out" syntax when reporting collisions. * guix/ui.scm (call-with-error-handling)[manifest-entry-output*]: New procedure. Use it when reporting collisions. --- guix/ui.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index ae727eb837..b65702474d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -550,19 +550,24 @@ interpreted." (manifest-entry-version parent)) (report-parent-entries parent)))) + (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~%") + (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))) -- cgit v1.2.3 From eef01cfe8eac8dee8ecf727e4ca459ae065e15ea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 28 Nov 2017 15:05:55 +0100 Subject: lint: 'patch-file-names' checks for file name length. Reported at by Danny Milosavljevic . * guix/scripts/lint.scm (%distro-directory): New variable. (check-patch-file-names): Add check for the file name length. * tests/lint.scm ("patches: file name too long"): New test. --- guix/scripts/lint.scm | 28 +++++++++++++++++++++++++--- tests/lint.scm | 15 ++++++++++++++- 2 files changed, 39 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8840b1acb5..7300e55de2 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -587,24 +587,46 @@ 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 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 (- (string-length patch) prefix)) + 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/tests/lint.scm b/tests/lint.scm index 1d0fc4708c..064f3d177e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014, 2015, 2016 Eric Bavier -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost @@ -331,6 +331,19 @@ (check-patch-file-names pkg))) "file names of patches should start with the package name"))) +(test-assert "patches: file name too long" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source + (dummy-origin + (patches (list (string-append "x-" + (make-string 100 #\a) + ".patch")))))))) + (check-patch-file-names pkg))) + "file name is too long"))) + (test-assert "patches: not found" (->bool (string-contains -- cgit v1.2.3 From 0a154c15a81ef80bf512a38ae8473a5bc511302b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 28 Nov 2017 15:52:01 +0100 Subject: lint: Adjust file-name length test for out-of-tree file names. * guix/scripts/lint.scm (check-patch-file-names): Adjust file-name-length calculation. --- guix/scripts/lint.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 7300e55de2..1b43b0a63c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -618,7 +618,10 @@ patch could not be found." (max 99)) (for-each (match-lambda ((? string? patch) - (when (> (+ margin (- (string-length patch) prefix)) + (when (> (+ margin (if (string-prefix? %distro-directory + patch) + (- (string-length patch) prefix) + (string-length patch))) max) (emit-warning package -- cgit v1.2.3 From a912c723f76d9762072ce27204a9227a64bcb625 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 Nov 2017 16:38:13 +0100 Subject: gexp: 'compiled-modules' disables deprecation warnings by default. This avoids repeated deprecation messages, particularly while running 'guix system build' or similar. * guix/gexp.scm (gexp->derivation): Add #:deprecation-warnings. Pass it to 'compiled-modules'. (compiled-modules): Add #:deprecation-warnings and honor it. * doc/guix.texi (G-Expressions): Update 'gexp->derivation' documentation. * guix/packages.scm (patch-and-repack): Pass #:deprecation-warnings #t. --- doc/guix.texi | 4 ++++ guix/gexp.scm | 21 ++++++++++++++++++--- guix/packages.scm | 1 + 3 files changed, 23 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 777ca2738b..ddbb6c8939 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4879,6 +4879,7 @@ information about monads.) [#:disallowed-references #f] @ [#:leaked-env-vars #f] @ [#:script-name (string-append @var{name} "-builder")] @ + [#:deprecation-warnings #f] @ [#:local-build? #f] [#:substitutable? #t] [#:guile-for-build #f] Return a derivation @var{name} that runs @var{exp} (a gexp) with @var{guile-for-build} (a derivation) on @var{system}; @var{exp} is @@ -4919,6 +4920,9 @@ refer to. Any reference to another store item will lead to a build error. Similarly for @var{disallowed-references}, which can list items that must not be referenced by the outputs. +@var{deprecation-warnings} determines whether to show deprecation warnings while +compiling modules. It can be @code{#f}, @code{#t}, or @code{'detailed}. + The other arguments are as for @code{derivation} (@pxref{Derivations}). @end deffn diff --git a/guix/gexp.scm b/guix/gexp.scm index 3781a1e6ee..27a8f35a58 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 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 + '()))))) ;;; diff --git a/guix/packages.scm b/guix/packages.scm index f619d9b370..d68af1569f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -608,6 +608,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) -- cgit v1.2.3 From 6ee797f326274284ac60dad50688f877a93711d2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 Nov 2017 22:29:26 +0100 Subject: gexp: Default to 'guile-2.2' for 'program-file'. Previously things returned by 'program-file', such as %MODPROBE-WRAPPER in (gnu services), would refer to 'guile-final'. This would introduce 'guile-final' in the system closure, which is otherwise absent. By referring to 'guile-2.2' we remove that extra Guile. * guix/gexp.scm (default-guile): Refer to GUILE-2.2 instead of GUILE-FINAL. --- guix/gexp.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 27a8f35a58..1929947d95 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1096,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 -- cgit v1.2.3 From 3d0aa7f70bed99fd04c7b2c2a8d7a4486e0a1364 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Thu, 31 Aug 2017 17:03:02 +0530 Subject: build-system: Add scons-build-system. * guix/build-system/scons.scm: New file. * guix/build/scons-build-system.scm: New file. * Makefile.am (MODULES): Register them. * doc/guix.texi (Build Systems): Add scons-build-system. --- Makefile.am | 3 + doc/guix.texi | 16 ++++- guix/build-system/scons.scm | 134 ++++++++++++++++++++++++++++++++++++++ guix/build/scons-build-system.scm | 65 ++++++++++++++++++ 4 files changed, 217 insertions(+), 1 deletion(-) create mode 100644 guix/build-system/scons.scm create mode 100644 guix/build/scons-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index eab49181ad..24a803a21a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -8,6 +8,7 @@ # Copyright © 2017 Leo Famulari # Copyright © 2017 Ricardo Wurmus # Copyright © 2017 Jan Nieuwenhuizen +# Copyright © 2017 Arun Isaac # # This file is part of GNU Guix. # @@ -94,6 +95,7 @@ MODULES = \ guix/build-system/waf.scm \ guix/build-system/r.scm \ guix/build-system/ruby.scm \ + guix/build-system/scons.scm \ guix/build-system/texlive.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ @@ -127,6 +129,7 @@ MODULES = \ guix/build/ocaml-build-system.scm \ guix/build/r-build-system.scm \ guix/build/ruby-build-system.scm \ + guix/build/scons-build-system.scm \ guix/build/texlive-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index b20848da5e..88764437a6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -42,7 +42,8 @@ Copyright @copyright{} 2017 Hartmut Goebel@* Copyright @copyright{} 2017 Maxim Cournoyer@* Copyright @copyright{} 2017 Tobias Geerinckx-Rice@* Copyright @copyright{} 2017 George Clemmer@* -Copyright @copyright{} 2017 Andy Wingo +Copyright @copyright{} 2017 Andy Wingo@* +Copyright @copyright{} 2017 Arun Isaac Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -3868,6 +3869,19 @@ Python package is used to run the script can be specified with the @code{#:python} parameter. @end defvr +@defvr {Scheme Variable} scons-build-system +This variable is exported by @code{(guix build-system scons)}. It +implements the build procedure used by the SCons software construction +tool. This build system runs @code{scons} to build the package, +@code{scons test} to run tests, and then @code{scons install} to install +the package. + +Additional flags to be passed to @code{scons} can be specified with the +@code{#:scons-flags} parameter. The version of Python used to run SCons +can be specified by selecting the appropriate SCons package with the +@code{#:scons} parameter. +@end defvr + @defvr {Scheme Variable} haskell-build-system This variable is exported by @code{(guix build-system haskell)}. It implements the Cabal build procedure used by Haskell packages, which 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 +;;; +;;; 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 . + +(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/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 +;;; +;;; 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 . + +(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 -- cgit v1.2.3 From e42f026eb52bb77039bac6b6a96dfc2ed2f86cc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Nov 2017 11:42:30 +0100 Subject: ui: Present 'use-modules' hints with a question mark. Suggested by myglc2 . * guix/ui.scm (report-load-error): Write "Did you forget" rather than "Try adding." --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index b65702474d..13cbe3a0f7 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -313,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) -- cgit v1.2.3 From e45b573c2d4f251d57caccb01ff19078b4f2e8e7 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 29 Nov 2017 15:10:12 +0100 Subject: utils: Add target-arm32? procedure. * guix/utils.scm (target-arm32?): New exported procedure. --- guix/utils.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') 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 ;;; Copyright © 2015 David Thompson ;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; 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)) -- cgit v1.2.3 From 1252dd325bbb71387092e9e89ff1ede8ef3f1d5f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Nov 2017 14:05:35 +0100 Subject: progress: Factorize erase-in-line. * guix/progress.scm (erase-in-line): New procedure. (progress-reporter/file): Use it. --- guix/progress.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/progress.scm b/guix/progress.scm index beca2c22a6..1993c74030 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -153,6 +153,11 @@ width of the bar is BAR-WIDTH." (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 +181,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 +193,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) -- cgit v1.2.3 From 5ed534ccc352cea9fd7920e820c8e5f47ea456ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Nov 2017 14:36:20 +0100 Subject: progress: 'progress-bar' accounts for brackets. * guix/progress.scm (progress-bar): Subtract 2 to BAR-WIDTH to account for brackets. --- guix/progress.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/progress.scm b/guix/progress.scm index 1993c74030..ba7944214b 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -146,7 +146,8 @@ 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]" -- cgit v1.2.3 From 4cdb27af48c83b7d036c4d8cccb792a51d766790 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Nov 2017 14:39:00 +0100 Subject: progress: Add 'progress-reporter/bar'. * guix/progress.scm (progress-reporter/bar): New procedure. --- guix/progress.scm | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) (limited to 'guix') diff --git a/guix/progress.scm b/guix/progress.scm index ba7944214b..1ee7ec319f 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Sou Bunnbu ;;; Copyright © 2015 Steve Sprang +;;; Copyright © 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ progress-reporter/silent progress-reporter/file + progress-reporter/bar byte-count->string current-terminal-columns @@ -212,6 +214,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) -- cgit v1.2.3 From 1fafa2f58732a3fb75258be342c92a2772af2860 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Nov 2017 14:39:26 +0100 Subject: weather: Use (guix progress) for progress report. * guix/progress.scm (start-progress-reporter!, stop-progress-reporter!) (progress-reporter-report!): New procedures. * guix/scripts/weather.scm (call-with-progress-reporter): New procedure. (package-outputs)[update-progress!]: Remove. Use 'call-with-progress-reporter' instead. (guix-weather): Parameterize 'current-terminal-columns'. --- .dir-locals.el | 3 +- guix/progress.scm | 22 ++++++++++ guix/scripts/weather.scm | 106 +++++++++++++++++++++++------------------------ 3 files changed, 76 insertions(+), 55 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 04b58d2ce0..949f7e0bc8 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -77,7 +77,8 @@ (eval . (put 'container-excursion 'scheme-indent-function 1)) (eval . (put 'eventually 'scheme-indent-function 1)) - ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols. + (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1)) + ;; This notably allows '(' in Paredit to not insert a space when the ;; preceding symbol is one of these. (eval . (modify-syntax-entry ?~ "'")) diff --git a/guix/progress.scm b/guix/progress.scm index 1ee7ec319f..0ca5c08782 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -31,6 +31,10 @@ progress-reporter? call-with-progress-reporter + start-progress-reporter! + stop-progress-reporter! + progress-reporter-report! + progress-reporter/silent progress-reporter/file progress-reporter/bar @@ -60,6 +64,24 @@ stopped." (($ start report stop) (dynamic-wind start (lambda () (proc report)) stop)))) +(define (start-progress-reporter! reporter) + "Low-level procedure to start REPORTER." + (match reporter + (($ start report stop) + (start)))) + +(define (progress-reporter-report! reporter) + "Low-level procedure to lead REPORTER to emit a report." + (match reporter + (($ start report stop) + (report)))) + +(define (stop-progress-reporter! reporter) + "Low-level procedure to stop REPORTER." + (match reporter + (($ start report stop) + (stop)))) + (define progress-reporter/silent (make-progress-reporter noop noop noop)) 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) -- cgit v1.2.3 From e4ecd51e239adba226709a793240cc6f1a396858 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Nov 2017 14:17:24 +0100 Subject: guix system: Simplify closure copy. * guix/scripts/system.scm (copy-item): Add 'references' argument and remove 'references*' call. Turn into a non-monadic procedure. (copy-closure): Remove initial call to 'references*'. Only pass ITEM to 'topologically-sorted*' since that's equivalent. Compute the list of references corresponding to TO-COPY and pass it to 'copy-item'. --- guix/scripts/system.scm | 67 +++++++++++++++++++++++-------------------------- 1 file changed, 32 insertions(+), 35 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e50f1d8ac7..acfa5fdbfd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -107,47 +107,44 @@ 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 ), 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 - ;; . - (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 ), 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 + ;; . + (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))) + (for-each (cut copy-item <> <> target #:log-port log-port) + to-copy refs) + + (return *unspecified*))) (define* (install-bootloader installer-drv #:key -- cgit v1.2.3 From e261e27676c018f23fb6c6fdc282e2dd40fa1985 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Nov 2017 14:38:13 +0100 Subject: guix system: 'init' displays a progress bar while copying. Until now it would print the name of each store item being copied, which was verbose and unhelpful. * guix/scripts/system.scm (copy-closure): Use 'progress-reporter/bar' and 'call-with-progress-reporter'. (guix-system): Parameterize 'current-terminal-columns'. --- guix/scripts/system.scm | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index acfa5fdbfd..91d151d22b 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) @@ -141,8 +143,18 @@ REFERENCES as its set of references." TARGET, and register them." (mlet* %store-monad ((to-copy (topologically-sorted* (list item))) (refs (mapm %store-monad references* to-copy))) - (for-each (cut copy-item <> <> target #:log-port log-port) - to-copy refs) + (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*))) @@ -1092,7 +1104,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: -- cgit v1.2.3 From cea25b08bfd22bda940e5ac7ea29d4fa035d8303 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Dec 2017 18:09:22 +0100 Subject: records: Use 'make-struct/no-tail'. * guix/records.scm (make-syntactic-constructor): Use 'make-struct/no-tail' as 'make-struct' is deprecated as of 2.2.3. --- guix/records.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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) -- cgit v1.2.3 From e2721a05e7d778bdf845b7cb7a42fd9f76095b69 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Dec 2017 18:31:16 +0100 Subject: Do not set '%fresh-auto-compile'. * guix/scripts/offload.scm (build-machines): Comment out '(set! %fresh-auto-compile #t)' since with Guile 2.2.3 it could lead to an actual rebuild of everything that gets loaded from there on. See . * guix/ui.scm (load*): Likewise. --- guix/scripts/offload.scm | 2 +- guix/ui.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') 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 record. - (set! %fresh-auto-compile #t) + ;; (set! %fresh-auto-compile #t) (save-module-excursion (lambda () diff --git a/guix/ui.scm b/guix/ui.scm index 13cbe3a0f7..9ed8f37521 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -195,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 -- cgit v1.2.3 From cdc938daf91f159e082c5b81a44b074f7bf6d991 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Dec 2017 17:14:41 +0100 Subject: profiles: Do not import the host's srfi-{19,26}.scm files. Previously the "manual-database" derivation would always import the host's srfi-{19,26}.scm files in the build side. In practice this means that different users could get different manual-database.drv depending on the Guile version they're using in the host. For example, the (gnu tests install) tests would fail if the host was running Guile 2.2.3 because the guest is running 2.2.2, and thus has different srfi-{19,26}.scm files. The manual-database.drv would need to be built from source, which would fail because prerequisites were missing. Reported by Mathieu Othacehe at . * guix/profiles.scm (manual-database): Do not pass #:modules to 'gexp->derivation'. Wrap 'build' gexp in 'with-imported-modules' form. --- guix/profiles.scm | 144 +++++++++++++++++++++++++++--------------------------- 1 file changed, 71 insertions(+), 73 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 0eb99f40de..5ef84e8a0b 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1117,82 +1117,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 -- cgit v1.2.3 From 2f60084f77815f454d1521396c2a383390ea2865 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Dec 2017 17:32:50 +0100 Subject: profiles: Avoid _IO* in profile builder. * guix/profiles.scm (profile-derivation)[builder]: Avoid the deprecated _IO* constants. --- guix/profiles.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 5ef84e8a0b..011bc54d23 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1268,8 +1268,8 @@ are cross-built for TARGET." (guix search-paths) (srfi srfi-1)) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) #+(if locales? set-utf8-locale #t) -- cgit v1.2.3 From 2815fca1423cf72e6f3d0e774f1058bcbf8dfdbf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Dec 2017 21:50:46 +0100 Subject: profile: Use _IO* but disable deprecation warning. This fixes a regression introduced in 2f60084f77815f454d1521396c2a383390ea2865, whereby the profile derivation would fail to run on Guile 2.0 (as is the case with "guix package --bootstrap"). Reported by Christopher Baines. * guix/profiles.scm (profile-derivation)[builder]: Use _IO* but add 'debug-disable' call. --- guix/profiles.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 011bc54d23..d8b83bf730 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1268,8 +1268,11 @@ are cross-built for TARGET." (guix search-paths) (srfi srfi-1)) - (setvbuf (current-output-port) 'line) - (setvbuf (current-error-port) 'line) + ;; Don't complain about _IO* on Guile 2.2. + (debug-disable 'warn-deprecated) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) #+(if locales? set-utf8-locale #t) -- cgit v1.2.3 From d9721c2096525747c7fbbe008c8100846aefd392 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Dec 2017 22:13:33 +0100 Subject: scripts: Default to Guile 2.2 as the guile-for-build. * guix/scripts/environment.scm (guix-environment): '%guile-for-build' now defaults to GUILE-2.2 instead of GUILE-2.0. * guix/scripts/package.scm (guix-package): Likewise. * guix/scripts/pull.scm (guix-pull): Likewise. --- guix/scripts/environment.scm | 2 +- guix/scripts/package.scm | 4 ++-- guix/scripts/pull.scm | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') 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/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 3e95bd511f..be0c168444 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -275,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 -- cgit v1.2.3 From cbb76780ef5e4aed113a1065d96fd6e035f60eaf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Dec 2017 22:14:50 +0100 Subject: profiles: Really disable deprecation warnings for 'profile-derivation'. This is a followup to 2815fca1423cf72e6f3d0e774f1058bcbf8dfdbf. * guix/profiles.scm (profile-derivation)[builder]: Remove 'debug-disable' call, which was ineffective. Pass #:env-vars to 'gexp->derivation'. --- guix/profiles.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index d8b83bf730..cedf9faa82 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1268,9 +1268,6 @@ are cross-built for TARGET." (guix search-paths) (srfi srfi-1)) - ;; Don't complain about _IO* on Guile 2.2. - (debug-disable 'warn-deprecated) - (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) @@ -1293,6 +1290,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 -- cgit v1.2.3 From 3fb6464ba43141b671481ce5ba158b6e6d1badfe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Dec 2017 23:17:26 +0100 Subject: ui: Tweak conflicting profile entry error message. * guix/ui.scm (call-with-error-handling): Use 'manifest-entry-output*' when reporting conflicting profile entries. --- guix/ui.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9ed8f37521..e40fe576ba 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -555,9 +555,9 @@ interpreted." ("out" "") (output (string-append ":" output)))) - (report-error (G_ "profile contains conflicting entries for ~a:~a~%") + (report-error (G_ "profile contains conflicting entries for ~a~a~%") (manifest-entry-name entry) - (manifest-entry-output entry)) + (manifest-entry-output* entry)) (report-error (G_ " first entry: ~a@~a~a ~a~%") (manifest-entry-name entry) (manifest-entry-version entry) -- cgit v1.2.3 From 4307397b5e060b54d69b7d2818654504ebde9c1d Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 1 Dec 2017 14:09:38 +0100 Subject: bootloader: extlinux: Stop using dd binary. * gnu/bootloader/extlinux.scm (dd): Remove it, (install-extlinux): replace dd call by Guile I/O procedures. * gnu/system/vm.scm (qemu-image): Add (ice-9 binary-ports) to used-modules list to provide "get-bytevector-n" and "put-bytevector". * guix/scripts/system.scm (bootloader-installer-derivation): Ditto. --- gnu/bootloader/extlinux.scm | 20 +++++++++----------- gnu/system/vm.scm | 3 ++- guix/scripts/system.scm | 3 ++- 3 files changed, 13 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm index 0db5598fc9..9b6e2c7f2a 100644 --- a/gnu/bootloader/extlinux.scm +++ b/gnu/bootloader/extlinux.scm @@ -85,14 +85,6 @@ TIMEOUT ~a~%" ;;; Install procedures. ;;; -(define dd - #~(lambda (bs count if of) - (zero? (system* "dd" - (string-append "bs=" (number->string bs)) - (string-append "count=" (number->string count)) - (string-append "if=" if) - (string-append "of=" of))))) - (define (install-extlinux mbr) #~(lambda (bootloader device mount-point) (let ((extlinux (string-append bootloader "/sbin/extlinux")) @@ -101,9 +93,15 @@ TIMEOUT ~a~%" (for-each (lambda (file) (install-file file install-dir)) (find-files syslinux-dir "\\.c32$")) - - (unless (and (zero? (system* extlinux "--install" install-dir)) - (#$dd 440 1 (string-append syslinux-dir "/" #$mbr) device)) + (unless + (and (zero? (system* extlinux "--install" install-dir)) + (call-with-input-file (string-append syslinux-dir "/" #$mbr) + (lambda (input) + (let ((bv (get-bytevector-n input 440))) + (call-with-output-file device + (lambda (output) + (put-bytevector output bv)) + #:binary #t))))) (error "failed to install SYSLINUX"))))) (define install-extlinux-mbr diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b68cce3eb5..d754ac76f0 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -278,7 +278,8 @@ the image." #~(begin (use-modules (gnu build vm) (guix build utils) - (srfi srfi-26)) + (srfi srfi-26) + (ice-9 binary-ports)) (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 91d151d22b..e2ff42693f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -676,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 -- cgit v1.2.3