nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add (guix self) and use it when pulling. 

This mitigates <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.
(indirect-root-added): Remove.
(guix-pull): Call 'add-indirect-root'.  Call 'build-from-source' and
pass the result to 'build-and-install'.
This commit is contained in:
Ludovic Courtès 2017-10-16 10:41:37 +02:00
parent fe9b3ec3ee
commit 5f93d97005
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
6 changed files with 753 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -66,6 +66,7 @@ MODULES = \
guix/derivations.scm \ guix/derivations.scm \
guix/grafts.scm \ guix/grafts.scm \
guix/gnu-maintenance.scm \ guix/gnu-maintenance.scm \
guix/self.scm \
guix/upstream.scm \ guix/upstream.scm \
guix/licenses.scm \ guix/licenses.scm \
guix/git.scm \ guix/git.scm \

268
build-aux/build-self.scm
View File

@ -17,11 +17,9 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (build-self) (define-module (build-self)
#:use-module (gnu)
#:use-module (guix)
#:use-module (guix config)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (build)) #:export (build))
@ -31,105 +29,51 @@
;;; argument: the source tree to build. It returns a derivation that ;;; argument: the source tree to build. It returns a derivation that
;;; builds it. ;;; 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: ;;; Code:
;; Use our very own Guix modules.
;; The dependencies. Don't refer explicitly to the variables because they (eval-when (compile load eval)
;; 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) (and=> (assoc-ref (current-source-location) 'filename)
(lambda (file) (lambda (file)
(string-append (dirname file) "/..")))) (let ((dir (string-append (dirname file) "/..")))
(set! %load-path (cons dir %load-path))))))
(define (date-version-string) (define (date-version-string)
"Return the current date and hour in UTC timezone, for use as a poor "Return the current date and hour in UTC timezone, for use as a poor
person's version identifier." 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")) (date->string (current-date 0) "~Y~m~d.~H"))
(define (guile-for-build) (define-syntax parameterize*
"Return a derivation for Guile 2.0 or 2.2, whichever matches the currently (syntax-rules ()
running Guile." "Like 'parameterize' but for regular variables (!)."
(package->derivation (cond-expand ((_ ((var value) rest ...) body ...)
(guile-2.2 (let ((old var)
(canonical-package (new value))
(specification->package "guile@2.2"))) (dynamic-wind
(else (lambda ()
(canonical-package (set! var new))
(specification->package "guile@2.0")))))) (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. ;; The procedure below is our return value.
(define* (build source (define* (build source
@ -138,131 +82,29 @@ running Guile."
#:rest rest) #:rest rest)
"Return a derivation that unpacks SOURCE into STORE and compiles Scheme "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files." files."
;; The '%xxxdir' variables were added to (guix config) in July 2016 so we ;; Start by jumping into the target Guix so that we have access to the
;; cannot assume that they are defined. Try to guess their value when ;; latest packages and APIs.
;; they're undefined (XXX: we get an incorrect guess when environment ;;
;; variables such as 'NIX_STATE_DIR' are defined!). ;; Our checkout in the store has mtime set to the epoch, and thus .go
(define storedir ;; files look newer, even though they may not correspond.
(if (defined? '%storedir) %storedir %store-directory)) (parameterize* ((%load-should-auto-compile #f)
(define localstatedir (%fresh-auto-compile #f)
(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 ;; Work around <https://bugs.gnu.org/29226>.
#~(begin (%load-compiled-path (pure-load-compiled-path)))
(use-modules (guix build pull)) ;; 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!
(letrec-syntax ((maybe-load-path (let ((guix-derivation (module-ref (resolve-interface '(guix self))
(syntax-rules () 'guix-derivation)))
((_ item rest ...) (guix-derivation source version))))
(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. ;; This file is loaded by 'guix pull'; return it the build procedure.
build build
;; Local Variables:
;; eval: (put 'with-load-path 'scheme-indent-function 1)
;; End:
;;; build-self.scm ends here ;;; build-self.scm ends here

21
gnu/packages.scm
View File

@ -110,8 +110,25 @@ for system '~a'")
file-name system))))))) file-name system)))))))
(define %distro-root-directory (define %distro-root-directory
;; Absolute file name of the module hierarchy. ;; Absolute file name of the module hierarchy. Since (gnu packages …) might
(dirname (search-path %load-path "guix.scm"))) ;; 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 (define %package-module-path
;; Search path for package modules. Each item must be either a directory ;; Search path for package modules. Each item must be either a directory

3
guix/discovery.scm
View File

@ -25,7 +25,8 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:export (scheme-modules #:export (scheme-files
scheme-modules
fold-modules fold-modules
all-modules all-modules
fold-module-public-variables)) fold-module-public-variables))

91
guix/scripts/pull.scm
View File

@ -149,8 +149,6 @@ Download and deploy the latest version of Guix.\n"))
(define what-to-build (define what-to-build
(store-lift show-what-to-build)) (store-lift show-what-to-build))
(define indirect-root-added
(store-lift add-indirect-root))
(define %self-build-file (define %self-build-file
;; The file containing code to build Guix. This serves the same purpose as ;; 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. ;; tree.
(build source #:verbose? verbose? #:version commit))) (build source #:verbose? verbose? #:version commit)))
(define* (build-and-install source config-dir (define* (install-latest source-dir config-dir)
#:key verbose? commit) "Make SOURCE-DIR, a store file name, the latest Guix in CONFIG-DIR."
"Build the tool from SOURCE, and install it in CONFIG-DIR." (let ((latest (string-append config-dir "/latest")))
(mlet* %store-monad ((source (build-from-source source (if (and (file-exists? latest)
#:commit commit (string=? (readlink latest) source-dir))
#:verbose? verbose?)) (begin
(source-dir -> (derivation->output-path source)) (display (G_ "Guix already up to date\n"))
(to-do? (what-to-build (list source))) #t)
(built? (built-derivations (list source)))) (begin
;; Always update the 'latest' symlink, regardless of whether SOURCE was (switch-symlinks latest source-dir)
;; already built or not. (format #t
(if built? (G_ "updated ~a successfully deployed under `~a'~%")
(mlet* %store-monad %guix-package-name latest)
((latest -> (string-append config-dir "/latest")) #t))))
(done (indirect-root-added latest)))
(if (and (file-exists? latest) (define (build-and-install mdrv)
(string=? (readlink latest) source-dir)) "Bind MDRV, a monadic value for a derivation, build it, and finally install
(begin it as the latest Guix."
(display (G_ "Guix already up to date\n")) (define do-it
(return #t)) ;; Weirdness follows! Before we were called, the Guix modules have
(begin ;; probably been reloaded, leading to a "parallel universe" with disjoint
(switch-symlinks latest source-dir) ;; record types. However, procedures in this file have already cached the
(format #t ;; module relative to which they lookup global bindings (see
(G_ "updated ~a successfully deployed under `~a'~%") ;; 'toplevel-box' documentation), so they're stuck in the old world. To
%guix-package-name latest) ;; work around that, evaluate our procedure in the context of the "new"
(return #t)))) ;; (guix scripts pull) module--which has access to the new <derivation>
(leave (G_ "failed to update Guix, check the build log~%"))))) ;; 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) (define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates." "Tell Guile-Git to use the Let's Encrypt certificates."
@ -258,6 +271,10 @@ certificates~%"))
(when (use-le-certs? url) (when (use-le-certs? url)
(honor-lets-encrypt-certificates! store)) (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) (format (current-error-port)
(G_ "Updating from Git repository at '~a'...~%") (G_ "Updating from Git repository at '~a'...~%")
url) url)
@ -276,10 +293,16 @@ certificates~%"))
(if (assoc-ref opts 'bootstrap?) (if (assoc-ref opts 'bootstrap?)
%bootstrap-guile %bootstrap-guile
(canonical-package guile-2.0))))) (canonical-package guile-2.0)))))
(run-with-store store
(build-and-install checkout (config-directory) ;; 'build-from-source' may cause a reload of the Guix
#:commit commit ;; modules. This leads to a parallel world: its record types
#:verbose? ;; are disjoint from those we've seen until now (because we
(assoc-ref opts 'verbose?)))))))))))) ;; 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 ;;; pull.scm ends here

619
guix/self.scm Normal file
View File

@ -0,0 +1,619 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@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-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)
(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 "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 (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 <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."
(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))))