me
/
guix
Archived
1
0
Fork 0
Code

build-self: Use (guix self). 

This mitigates <https://bugs.gnu.org/27284>.

* 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.
(%dependency-variables, %persona-variables, %config-variables): New
variables.
(make-config.scm, load-path-expression, gexp->script)
(build-program): New procedures.
(build): Rewrite to simply delegate to 'guix-derivation'.
master
Ludovic Courtès 2018-03-23 17:18:15 +01:00
parent eaae07ec28
commit f0527ce3a4
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 223 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -19,10 +19,14 @@
(define-module (build-self)
#:use-module (gnu)
#:use-module (guix)
#:use-module (guix ui)
#:use-module (guix config)
#:use-module (guix modules)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:export (build))
;;; Commentary:
@ -40,242 +44,254 @@
;;; 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.
;;;
;;; Generating (guix config).
;;;
;;; This is copied from (guix self) because we cannot assume (guix self) is
;;; available at this point.
;;;
(define guix
(first (find-best-packages-by-name "guix" #f)))
(define %dependency-variables
;; (guix config) variables corresponding to dependencies.
'(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
(define libgcrypt
(first (find-best-packages-by-name "libgcrypt" #f)))
(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 zlib
(first (find-best-packages-by-name "zlib" #f)))
(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 gzip
(first (find-best-packages-by-name "gzip" #f)))
(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"))
(define bzip2
(first (find-best-packages-by-name "bzip2" #f)))
;; Hack so that Geiser is not confused.
(define defmod 'define-module)
(define xz
(first (find-best-packages-by-name "xz" #f)))
(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))
(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)))
;; 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 (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 %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 guile-json
(package-for-current-guile "guile-json"
"guile2.2-json"
"guile2.0-json"))
(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 guile-ssh
(package-for-current-guile "guile-ssh"
"guile2.2-ssh"
"guile2.0-ssh"))
(define %libgcrypt
#+(and libgcrypt
(file-append libgcrypt "/lib/libgcrypt")))
(define %libz
#+(and zlib
(file-append zlib "/lib/libz")))
(define guile-git
(package-for-current-guile "guile-git"
"guile2.0-git"))
(define %nix-instantiate ;for (guix import snix)
"nix-instantiate")))))
(define guile-bytestructures
(package-for-current-guile "guile-bytestructures"
"guile2.0-bytestructures"))
;; The actual build procedure.
;;;
;;; 'gexp->script'.
;;;
;;; This is our own variant of 'gexp->script' with an extra #:module-path
;;; parameter, which was unavailable in (guix gexp) until commit
;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
;;;
(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) "/.."))))
(define (load-path-expression modules path)
"Return as a monadic value a gexp that sets '%load-path' and
'%load-compiled-path' to point to MODULES, a list of module names. MODULES
are searched for in PATH."
(mlet %store-monad ((modules (imported-modules modules
#:module-path path))
(compiled (compiled-modules modules
#:module-path path)))
(return (gexp (eval-when (expand load eval)
(set! %load-path
(cons (ungexp modules) %load-path))
(set! %load-compiled-path
(cons (ungexp compiled)
%load-compiled-path)))))))
(define* (gexp->script name exp
#:key (guile (default-guile))
(module-path %load-path))
"Return an executable script NAME that runs EXP using GUILE, with EXP's
imported modules in its search path."
(mlet %store-monad ((set-load-path
(load-path-expression (gexp-modules exp)
module-path)))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(lambda (port)
;; Note: that makes a long shebang. When the store
;; is /gnu/store, that fits within the 128-byte
;; limit imposed by Linux, but that may go beyond
;; when running tests.
(format port
"#!~a/bin/guile --no-auto-compile~%!#~%"
(ungexp guile))
(write '(ungexp set-load-path) port)
(write '(ungexp exp) port)
(chmod port #o555))))
#:module-path module-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.
(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* (build-program source version
#:optional (guile-version (effective-version)))
"Return a program that computes the derivation to build Guix from SOURCE."
(define select?
;; Select every module but (guix config) and non-Guix modules.
(match-lambda
(('guix 'config) #f)
(('guix _ ...) #t)
(('gnu _ ...) #t)
(_ #f)))
(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 "guile@2.0"))))))
(with-imported-modules `(((guix config)
=> ,(make-config.scm
#:libgcrypt
(specification->package "libgcrypt")))
,@(source-module-closure `((guix store)
(guix self)
(guix derivations)
(gnu packages bootstrap))
(list source)
#:select? select?))
(gexp->script "compute-guix-derivation"
#~(begin
(use-modules (ice-9 match))
(eval-when (expand load eval)
;; Don't augment '%load-path'.
(unsetenv "GUIX_PACKAGE_PATH")
;; (gnu packages …) modules are going to be looked up
;; under SOURCE. (guix config) is looked up in FRONT.
(match %load-path
((#$source _ ...)
#t) ;already done
((front _ ...)
(set! %load-path (list #$source front))))
;; Only load our own modules or those of Guile.
(match %load-compiled-path
((front _ ... sys1 sys2)
(set! %load-compiled-path
(list front sys1 sys2)))))
(use-modules (guix store)
(guix self)
(guix derivations)
(srfi srfi-1))
(define (spin system)
(define spin
(circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
(format (current-error-port)
"Computing Guix derivation for '~a'... "
system)
(let loop ((spin spin))
(display (string-append "\b" (car spin))
(current-error-port))
(force-output (current-error-port))
(sleep 1)
(loop (cdr spin))))
(match (command-line)
((_ _ system)
(with-store store
(call-with-new-thread
(lambda ()
(spin system)))
(display
(derivation-file-name
(run-with-store store
(guix-derivation #$source #$version
#$guile-version)
#:system system)))))))
#:module-path (list source))))
;; The procedure below is our return value.
(define* (build source
#:key verbose? (version (date-version-string))
#:key verbose? (version (date-version-string)) system
(guile-version (match ((@ (guile) version))
("2.2.2" "2.2.2")
(_ (effective-version))))
#:allow-other-keys
#: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 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 (string-append #$guix "/sbin")
#: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 profiling)
(guix sets))
;; Arrange so that our own (guix build …) modules are
;; used.
#:module-path (list (top-source-directory))
#:guile-for-build guile)))
;; Build the build program and then use it as a trampoline to build from
;; SOURCE.
(mlet %store-monad ((build (build-program source version guile-version))
(system (if system (return system) (current-system))))
(mbegin %store-monad
(show-what-to-build* (list build))
(built-derivations (list build))
(let ((pipe (begin
(setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
(open-pipe* OPEN_READ
(derivation->output-path build)
source system))))
(match (get-string-all pipe)
((? eof-object?)
(error "build program failed" build))
((? derivation-path? drv)
(mbegin %store-monad
(return (newline (current-output-port)))
((store-lift add-temp-root) drv)
(return (read-derivation-from-file drv))))
((? string? str)
(error "invalid build result" (list build str))))))))
;; This file is loaded by 'guix pull'; return it the build procedure.
build