[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#27284: [PATCH 3/4] Add (guix self) and use it when pulling.
|
From: |
Ludovic Courtès |
|
Subject: |
bug#27284: [PATCH 3/4] Add (guix self) and use it when pulling. |
|
Date: |
Mon, 11 Dec 2017 11:52:52 +0100 |
This mitigates <https://bugs.gnu.org/27284>.
* guix/self.scm: New file.
* Makefile.am (MODULES): Add it.
* po/guix/POTFILES.in: 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, matching-guile-2.2): 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 | 287 ++++-----------------
gnu/packages.scm | 21 +-
guix/discovery.scm | 3 +-
guix/scripts/pull.scm | 91 ++++---
guix/self.scm | 652 +++++++++++++++++++++++++++++++++++++++++++++++
po/guix/POTFILES.in | 1 +
7 files changed, 788 insertions(+), 268 deletions(-)
create mode 100644 guix/self.scm
diff --git a/Makefile.am b/Makefile.am
index ddbf7a798..c0774d4f3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -67,6 +67,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 641597883..d9d926367 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -17,11 +17,9 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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,122 +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 (matching-guile-2.2)
- "Return a Guile 2.2 with the same version as the current one or immediately
-older than then current one. This is so that we do not build ABI-incompatible
-objects. See <https://bugs.gnu.org/29570>."
- (let loop ((packages (find-packages-by-name "guile" "2.2"))
- (best #f))
- (match packages
- (()
- best)
- ((head tail ...)
- (if (string=? (package-version head) (version))
- head
- (if best
- (if (version>? (package-version head) (version))
- (loop tail best)
- (loop tail head))
- (loop tail head)))))))
+(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 (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 (matching-guile-2.2)))
- (else
- (canonical-package
- (specification->package "address@hidden"))))))
+(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
@@ -155,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 <https://bugs.gnu.org/29226>.
+ (%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 97e6cb347..44a56dfde 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 7b5757902..8ffcf7cd9 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 64c2196e0..313d87344 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -150,8 +150,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
@@ -172,33 +170,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 <derivation>
+ ;; 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."
@@ -259,6 +272,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)
@@ -277,10 +294,16 @@ certificates~%"))
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.2)))))
- (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 000000000..2f7f83b59
--- /dev/null
+++ b/guix/self.scm
@@ -0,0 +1,652 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix self)
+ #:use-module (guix config)
+ #:use-module (guix i18n)
+ #: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 utils)
+ #:use-module (guix modules)
+ #:use-module (guix build utils)
+ #:use-module ((guix build compile) #:select (%lightweight-optimizations))
+ #: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>
+ (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? guile-for-build)
+ "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?
+ #:guile-for-build guile-for-build))))
+
+(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))
+ (guile-for-build (guile-for-build guile-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"))))
+
+ #:guile-for-build guile-for-build))
+
+ (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
+ #:guile-for-build guile-for-build))
+
+ (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)))))
+ #:guile-for-build guile-for-build))
+
+ (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))
+ #:guile-for-build
+ guile-for-build))
+
+ (define *cli-modules*
+ (scheme-node "guix-cli"
+ (scheme-modules* source "/guix/scripts")
+ (list *core-modules* *extra-modules* *package-modules*
+ *system-modules*)
+ #:extensions dependencies
+ #:guile-for-build guile-for-build))
+
+ (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)))
+ #:guile-for-build guile-for-build))
+
+ (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)
+ (string<? (symbol->string (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 "address@hidden")
+ (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 <http://bugs.gnu.org/15602>.
+ (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?
+ guile-for-build)
+ ;; 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
+ #:guile guile-for-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."
+
+ ;; Caveat! Until we've reloaded all the guix and gnu modules, we cannot rely
+ ;; on bindings coming from guix/gnu modules, except for (guix self), because
+ ;; the other modules might be outdated.
+
+ (let* ((guix (resolve-module '(guix) #f #f #:ensure #f))
+ (gnu (resolve-module '(gnu) #f #f #:ensure #f))
+ (guix-submodules (recursive-submodules guix))
+ (gnu-submodules (recursive-submodules gnu)))
+ (define (reload module)
+ ;; Reload MODULE, unless it's already been reloaded indirectly in the
+ ;; meantime.
+ (unless (resolve-module (module-name module) #f #f #:ensure #f)
+ (match (module-filename module)
+ (#f #f)
+ ((? string? file)
+ (primitive-load (search-path %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 <package> record types,
+ ;; for instance.)
+ (format log-port (G_ "Unloading current modules...~%"))
+ (unload-module-tree! gnu)
+ (unload-module-tree! guix)
+
+ ;; When reloading, we compile the core modules and interpret the rest.
+ ;; This appears to be the most efficient approach.
+ (format log-port (G_ "Loading new modules...~%"))
+ (set! %auto-compilation-options %lightweight-optimizations)
+ (reload (resolve-module '(guix packages)))
+
+ (set! %load-should-auto-compile #f)
+ (for-each reload (append guix-submodules (list guix)))
+ (for-each reload (append gnu-submodules (list gnu)))
+ (format log-port (G_ "New modules successfully loaded.~%"))))
+
+
+;;;
+;;; Building.
+;;;
+
+(define (guile-for-build version)
+ "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
+running Guile."
+ (define canonical-package ;soft reference
+ (module-ref (resolve-interface '(gnu packages base))
+ 'canonical-package))
+
+ (match version
+ ("2.2"
+ ;; Use the same 2.2 variant for everyone so that people can get
+ ;; substitutes, and also to avoid ABI incompatibilities (see
+ ;; <https://bugs.gnu.org/29570>.)
+ (canonical-package (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-2.2/fixed)))
+ ("2.0"
+ (canonical-package (specification->package "address@hidden")))))
+
+(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))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 6510b99e8..01ba5638b 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -33,6 +33,7 @@ guix/scripts/weather.scm
guix/gnu-maintenance.scm
guix/scripts/container.scm
guix/scripts/container/exec.scm
+guix/self.scm
guix/upstream.scm
guix/ui.scm
guix/http-client.scm
--
2.15.1