me/guix
Archived
1
0
Fork 0
Code Activity

build-self: Use (guix self).

Browse source 
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'.
This commit is contained in:
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 ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -19,10 +19,14 @@
(define-module (build-self) (define-module (build-self)
#:use-module (gnu) #:use-module (gnu)
#:use-module (guix) #:use-module (guix)
#:use-module (guix ui)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix modules)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (rnrs io ports)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:export (build)) #:export (build))
;;; Commentary: ;;; Commentary:
@ -40,242 +44,254 @@
;;; Code: ;;; Code:
;; The dependencies. Don't refer explicitly to the variables because they ;;;
;; could be renamed or shuffled around in modules over time. Conversely, ;;; Generating (guix config).
;; 'find-best-packages-by-name' is expected to always have the same semantics. ;;;
;;; This is copied from (guix self) because we cannot assume (guix self) is
;;; available at this point.
;;;
(define guix (define %dependency-variables
(first (find-best-packages-by-name "guix" #f))) ;; (guix config) variables corresponding to dependencies.
'(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
(define libgcrypt (define %persona-variables
(first (find-best-packages-by-name "libgcrypt" #f))) ;; (guix config) variables that define Guix's persona.
'(%guix-package-name
%guix-version
%guix-bug-report-address
%guix-home-page-url))
(define zlib (define %config-variables
(first (find-best-packages-by-name "zlib" #f))) ;; (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 (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
(first (find-best-packages-by-name "gzip" #f))) (package-name "GNU Guix")
(package-version "0")
(bug-report-address "bug-guix@gnu.org")
(home-page-url "https://gnu.org/s/guix"))
(define bzip2 ;; Hack so that Geiser is not confused.
(first (find-best-packages-by-name "bzip2" #f))) (define defmod 'define-module)
(define xz (scheme-file "config.scm"
(first (find-best-packages-by-name "xz" #f))) #~(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) ;; XXX: Work around <http://bugs.gnu.org/15602>.
"Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., (eval-when (expand load eval)
2.0 instead of 2.2), otherwise return PACKAGE." #$@(map (match-lambda
(let ((guile (any (match-lambda ((name . value)
((label (? package? dep) _ ...) #~(define-public #$name #$value)))
(and (string=? (package-name dep) "guile") %config-variables)
dep)))
(package-direct-inputs package))))
(and (or (not guile)
(string-prefix? (effective-version)
(package-version guile)))
package)))
(define (package-for-current-guile . names) (define %guix-package-name #$package-name)
"Return the package with one of the given NAMES that depends on the current (define %guix-version #$package-version)
Guile major version (2.0 or 2.2), or #f if none of the packages matches." (define %guix-bug-report-address #$bug-report-address)
(let loop ((names names)) (define %guix-home-page-url #$home-page-url)
(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 (define %gzip
(package-for-current-guile "guile-json" #+(and gzip (file-append gzip "/bin/gzip")))
"guile2.2-json" (define %bzip2
"guile2.0-json")) #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
(define %xz
#+(and xz (file-append xz "/bin/xz")))
(define guile-ssh (define %libgcrypt
(package-for-current-guile "guile-ssh" #+(and libgcrypt
"guile2.2-ssh" (file-append libgcrypt "/lib/libgcrypt")))
"guile2.0-ssh")) (define %libz
#+(and zlib
(file-append zlib "/lib/libz")))
(define guile-git (define %nix-instantiate ;for (guix import snix)
(package-for-current-guile "guile-git" "nix-instantiate")))))
"guile2.0-git"))
(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) (define (load-path-expression modules path)
"Return the name of the top-level directory of this source tree." "Return as a monadic value a gexp that sets '%load-path' and
(and=> (assoc-ref (current-source-location) 'filename) '%load-compiled-path' to point to MODULES, a list of module names. MODULES
(lambda (file) are searched for in PATH."
(string-append (dirname file) "/..")))) (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) (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: Replace with a Git commit id.
(date->string (current-date 0) "~Y~m~d.~H")) (date->string (current-date 0) "~Y~m~d.~H"))
(define (matching-guile-2.2) (define* (build-program source version
"Return a Guile 2.2 with the same version as the current one or immediately #:optional (guile-version (effective-version)))
older than then current one. This is so that we do not build ABI-incompatible "Return a program that computes the derivation to build Guix from SOURCE."
objects. See <https://bugs.gnu.org/29570>." (define select?
(let loop ((packages (find-packages-by-name "guile" "2.2")) ;; Select every module but (guix config) and non-Guix modules.
(best #f)) (match-lambda
(match packages (('guix 'config) #f)
(() (('guix _ ...) #t)
best) (('gnu _ ...) #t)
((head tail ...) (_ #f)))
(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 (guile-for-build) (with-imported-modules `(((guix config)
"Return a derivation for Guile 2.0 or 2.2, whichever matches the currently => ,(make-config.scm
running Guile." #:libgcrypt
(package->derivation (cond-expand (specification->package "libgcrypt")))
(guile-2.2 ,@(source-module-closure `((guix store)
(canonical-package (matching-guile-2.2))) (guix self)
(else (guix derivations)
(canonical-package (gnu packages bootstrap))
(specification->package "guile@2.0")))))) (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. ;; The procedure below is our return value.
(define* (build source (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 #:allow-other-keys
#: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 ;; Build the build program and then use it as a trampoline to build from
;; cannot assume that they are defined. Try to guess their value when ;; SOURCE.
;; they're undefined (XXX: we get an incorrect guess when environment (mlet %store-monad ((build (build-program source version guile-version))
;; variables such as 'NIX_STATE_DIR' are defined!). (system (if system (return system) (current-system))))
(define storedir (mbegin %store-monad
(if (defined? '%storedir) %storedir %store-directory)) (show-what-to-build* (list build))
(define localstatedir (built-derivations (list build))
(if (defined? '%localstatedir) %localstatedir (dirname %state-directory))) (let ((pipe (begin
(define sysconfdir (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
(if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory))) (open-pipe* OPEN_READ
(derivation->output-path build)
(define builder source system))))
#~(begin (match (get-string-all pipe)
(use-modules (guix build pull)) ((? eof-object?)
(error "build program failed" build))
(letrec-syntax ((maybe-load-path ((? derivation-path? drv)
(syntax-rules () (mbegin %store-monad
((_ item rest ...) (return (newline (current-output-port)))
(let ((tail (maybe-load-path rest ...))) ((store-lift add-temp-root) drv)
(if (string? item) (return (read-derivation-from-file drv))))
(cons (string-append item ((? string? str)
"/share/guile/site/" (error "invalid build result" (list build str))))))))
#$(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)))
;; 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