guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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'.
version-0.15.0
Ludovic Courtès 4 years ago
parent
eaae07ec28
commit
f0527ce3a4
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
1 changed files with 237 additions and 221 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 458
      build-aux/build-self.scm

458
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.
(define guix
(first (find-best-packages-by-name "guix" #f)))
(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.
;;;
;;; Generating (guix config).
;;;
;;; This is copied from (guix self) because we cannot assume (guix self) is
;;; available at this point.
;;;
(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")))))
(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) "/.."))))
;;;
;;; '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 (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 (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"))))))
(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)))
(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

Write Preview
Loading…
Cancel
Save