Hi Maxim,
Thanks for reviewing this!
I’ve fixed the many typos that you noticed. Apart from that, I’ve also
addressed the “parallel world” issue that module reloading creates: the
trick is to use ‘eval’ (evil!). Anyway, it seems to do the job. New
patches attached!
So at this point, I think it needs more testing mostly. To do that, you
need to create a branch with those patches, say ‘wip-pull-derivations’,
and then from there you can run:
./pre-inst-env guix pull --url=$PWD --branch=wip-pull-derivations
Some other comments:
Maxim Cournoyer <maxim.courno...@gmail.com> skribis:
>> + (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 profiles)
>> + (guix build gnu-build-system))
>
> Sorting the modules list lexicographically would be neat, here and in
> various places. If this seems reasonable, perhaps we could have this
> stylistic convention in our guidelines?
In this case I wanted to have them sorted “logically”, almost
topologically, and I prefer it that way.
For (gnu packages …) modules, I agree it makes sense to sort
alphabetically though, and yes, we could write it down somewhere in the
manual.
>> + (define (process-directory directory output)
>> + (let ((files (find-files directory "\\.scm$"))
>> + (prefix (+ 1 (string-length directory))))
>> + ;; Hide compilation warnings.
>
> Should this be configurable? Hidden warnings don't have much chance to
> get addressed :)
The idea is that when you type ‘make’ you still get warnings, but you
don’t get them when you run ‘guix pull’, as is already the case (on the
grounds that ‘make’ is for developers and ‘guix pull’ for users.)
Thanks,
Ludo’.
>From 4cfcfaf1d7564b49eeb267f3d56167891d06705c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org>
Date: Thu, 19 Oct 2017 16:07:34 +0200
Subject: [PATCH 1/4] 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(-)
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 18167fa3e..256123c56 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 <l...@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <l...@gnu.org>
;;; Copyright © 2014 Mark H Weaver <m...@netris.org>
;;; Copyright © 2017 Huang Ying <huang.ying.cari...@gmail.com>
;;;
@@ -78,11 +78,12 @@ identical, #f otherwise."
(define* (union-build output inputs
#:key (log-port (current-error-port))
- (create-all-directories? #f))
+ (create-all-directories? #f)
+ (symlink symlink))
"Build in the OUTPUT directory a symlink tree that is the union of all the
-INPUTS. As a special case, if CREATE-ALL-DIRECTORIES?, creates the
-subdirectories in the output directory to make sure the caller can modify them
-later."
+INPUTS, using SYMLINK to create symlinks. As a special case, if
+CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
+make sure the caller can modify them later."
(define (symlink* input output)
(format log-port "`~a' ~~> `~a'~%" input output)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index b9525603e..e8ac3dcdc 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)))))))))
;;;
--
2.14.2
>From 57a950b9e9721d02b420df582a968ee1e9c7229e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org>
Date: Thu, 19 Oct 2017 16:10:18 +0200
Subject: [PATCH 2/4] 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(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index e8ac3dcdc..3781a1e6e 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)))))))))
--
2.14.2
>From 12b687d92b8102e833fcbc7878eeb5f63aba73fb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org>
Date: Fri, 27 Oct 2017 15:26:19 -0700
Subject: [PATCH 3/4] pull: Trim import list.
* guix/scripts/pull.scm: Remove useless imports.
---
guix/scripts/pull.scm | 6 ------
1 file changed, 6 deletions(-)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 240019800..3e95bd511 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))
--
2.14.2
>From 0b262d35956befbbc670cc1b8ed275510c6b069e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org>
Date: Mon, 16 Oct 2017 10:41:37 +0200
Subject: [PATCH 4/4] DRAFT Add (guix self) and use it when pulling.
DRAFT: Needs more testing.
Partly addresses <https://bugs.gnu.org/27284>.
* 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.
(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 | 228 ++----------------
gnu/packages.scm | 21 +-
guix/discovery.scm | 3 +-
guix/scripts/pull.scm | 89 ++++---
guix/self.scm | 599 +++++++++++++++++++++++++++++++++++++++++++++++
6 files changed, 698 insertions(+), 243 deletions(-)
create mode 100644 guix/self.scm
diff --git a/Makefile.am b/Makefile.am
index fd6f9729c..bb12e9905 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 ed8ff5f4c..039d35acd 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -17,9 +17,6 @@
;;; 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 (ice-9 match)
@@ -39,98 +36,25 @@
;;;
;;; 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.
+;; Use our very own Guix modules.
+(eval-when (compile load eval)
-(define libgcrypt
- (first (find-best-packages-by-name "libgcrypt" #f)))
+ ;; Ignore any available .go, and force recompilation. This is because our
+ ;; checkout in the store has mtime set to the epoch, and thus .go files look
+ ;; newer, even though they may not correspond.
+ (set! %fresh-auto-compile #t)
-(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)
- (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"))))))
-
;; The procedure below is our return value.
(define* (build source
#:key verbose? (version (date-version-string))
@@ -138,131 +62,19 @@ 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)))
+ ;; FIXME: Closures in (guix scripts pull) have already cached old values of
+ ;; (guix …), so they keep referring to the "old" world, with different
+ ;; record types than the one we get after reloading (because record types
+ ;; are "generative".)
+ (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 b4ac6661c..7ca6c3093 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 3e95bd511..e212a5b05 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -171,33 +171,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."
@@ -258,6 +273,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 +295,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 000000000..cd7f2410d
--- /dev/null
+++ b/guix/self.scm
@@ -0,0 +1,599 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <l...@gnu.org>
+;;;
+;;; 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 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>
+ (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 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*)))
+
+ (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"
+ `(((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-" %guix-version)
+ (append-map (lambda (node)
+ (list (node-source node)
+ (node-compiled node)))
+ (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 %config-variables
+ ;; (guix config) variables corresponding to Guix configuration (storedir,
+ ;; localstatedir, etc.)
+ (filter pair?
+ (module-map (lambda (name var)
+ (and (not (memq name %dependency-variables))
+ (cons name (variable-ref var))))
+ (resolve-interface '(guix config)))))
+
+(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 <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?)
+ ;; 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 (process-file file output)
+ (let* ((base (string-drop-right file 4)) ;.scm
+ (output (string-append output "/" base
+ ".go")))
+ (compile-file file
+ #:output-file output
+ #:opts (optimization-options 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))))
+
+ (debug-disable 'warn-deprecated)
+ (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 '()))
+
+
+;;;
+;;; 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)
+ (resolve-module (module-name module)))))
+
+ ;; Ignore any available .go, and force recompilation. This is because our
+ ;; checkout in the store has mtime set to the epoch, and thus .go files look
+ ;; newer, even though they may not correspond.
+ (set! %fresh-auto-compile #t)
+
+ ;; 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 "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."
+ (mbegin %store-monad
+ (set-guile-for-build (guile-for-build guile-version))
+ (lower-object (compiled-guix source
+ #:version version
+ #:guile-version guile-version))))
--
2.14.2
