|
|
@ -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 |
|
|
|