Commit | Line | Data |
---|---|---|
f81ac34d | 1 | ;;; GNU Guix --- Functional package management for GNU |
316fc2ac | 2 | ;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
f81ac34d LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (build-self) | |
cd295fbe LC |
20 | #:use-module (gnu) |
21 | #:use-module (guix) | |
f0527ce3 | 22 | #:use-module (guix ui) |
cd295fbe | 23 | #:use-module (guix config) |
f0527ce3 | 24 | #:use-module (guix modules) |
ca719424 | 25 | #:use-module (guix build-system gnu) |
f81ac34d | 26 | #:use-module (srfi srfi-1) |
b006ba50 | 27 | #:use-module (srfi srfi-19) |
ac4d2ec8 LC |
28 | #:use-module (srfi srfi-34) |
29 | #:use-module (srfi srfi-35) | |
f0527ce3 | 30 | #:use-module (rnrs io ports) |
838ba73d | 31 | #:use-module (ice-9 match) |
f0527ce3 | 32 | #:use-module (ice-9 popen) |
f81ac34d LC |
33 | #:export (build)) |
34 | ||
35 | ;;; Commentary: | |
36 | ;;; | |
37 | ;;; When loaded, this module returns a monadic procedure of at least one | |
38 | ;;; argument: the source tree to build. It returns a derivation that | |
39 | ;;; builds it. | |
40 | ;;; | |
cd295fbe LC |
41 | ;;; This file uses modules provided by the already-installed Guix. Those |
42 | ;;; modules may be arbitrarily old compared to the version we want to | |
43 | ;;; build. Because of that, it must rely on the smallest set of features | |
44 | ;;; that are likely to be provided by the (guix) and (gnu) modules, and by | |
45 | ;;; Guile itself, forever and ever. | |
46 | ;;; | |
f81ac34d LC |
47 | ;;; Code: |
48 | ||
cd295fbe | 49 | \f |
f0527ce3 LC |
50 | ;;; |
51 | ;;; Generating (guix config). | |
52 | ;;; | |
53 | ;;; This is copied from (guix self) because we cannot assume (guix self) is | |
54 | ;;; available at this point. | |
55 | ;;; | |
56 | ||
f0527ce3 LC |
57 | (define %persona-variables |
58 | ;; (guix config) variables that define Guix's persona. | |
59 | '(%guix-package-name | |
60 | %guix-version | |
61 | %guix-bug-report-address | |
62 | %guix-home-page-url)) | |
63 | ||
64 | (define %config-variables | |
45779fa6 LC |
65 | ;; (guix config) variables corresponding to Guix configuration. |
66 | (letrec-syntax ((variables (syntax-rules () | |
67 | ((_) | |
68 | '()) | |
69 | ((_ variable rest ...) | |
70 | (cons `(variable . ,variable) | |
71 | (variables rest ...)))))) | |
7af5c2a2 | 72 | (variables %localstatedir %storedir %sysconfdir %system))) |
f0527ce3 | 73 | |
4c0c65ac | 74 | (define* (make-config.scm #:key gzip xz bzip2 |
f0527ce3 LC |
75 | (package-name "GNU Guix") |
76 | (package-version "0") | |
77 | (bug-report-address "bug-guix@gnu.org") | |
3fb3291e | 78 | (home-page-url "https://guix.gnu.org")) |
f0527ce3 LC |
79 | |
80 | ;; Hack so that Geiser is not confused. | |
81 | (define defmod 'define-module) | |
82 | ||
83 | (scheme-file "config.scm" | |
84 | #~(begin | |
85 | (#$defmod (guix config) | |
86 | #:export (%guix-package-name | |
87 | %guix-version | |
88 | %guix-bug-report-address | |
89 | %guix-home-page-url | |
7af5c2a2 LC |
90 | %store-directory |
91 | %state-directory | |
92 | %store-database-directory | |
93 | %config-directory | |
f0527ce3 LC |
94 | %libz |
95 | %gzip | |
96 | %bzip2 | |
e8cb9c01 | 97 | %xz)) |
f0527ce3 LC |
98 | |
99 | ;; XXX: Work around <http://bugs.gnu.org/15602>. | |
100 | (eval-when (expand load eval) | |
101 | #$@(map (match-lambda | |
102 | ((name . value) | |
103 | #~(define-public #$name #$value))) | |
104 | %config-variables) | |
105 | ||
7af5c2a2 LC |
106 | (define %store-directory |
107 | (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) | |
108 | %storedir)) | |
109 | ||
110 | (define %state-directory | |
111 | ;; This must match `NIX_STATE_DIR' as defined in | |
112 | ;; `nix/local.mk'. | |
a87d66f3 | 113 | (or (getenv "GUIX_STATE_DIRECTORY") |
7af5c2a2 LC |
114 | (string-append %localstatedir "/guix"))) |
115 | ||
116 | (define %store-database-directory | |
a87d66f3 | 117 | (or (getenv "GUIX_DATABASE_DIRECTORY") |
7af5c2a2 LC |
118 | (string-append %state-directory "/db"))) |
119 | ||
120 | (define %config-directory | |
121 | ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as | |
122 | ;; defined in `nix/local.mk'. | |
123 | (or (getenv "GUIX_CONFIGURATION_DIRECTORY") | |
124 | (string-append %sysconfdir "/guix"))) | |
125 | ||
f0527ce3 LC |
126 | (define %guix-package-name #$package-name) |
127 | (define %guix-version #$package-version) | |
128 | (define %guix-bug-report-address #$bug-report-address) | |
129 | (define %guix-home-page-url #$home-page-url) | |
130 | ||
131 | (define %gzip | |
132 | #+(and gzip (file-append gzip "/bin/gzip"))) | |
133 | (define %bzip2 | |
134 | #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) | |
135 | (define %xz | |
4c0c65ac | 136 | #+(and xz (file-append xz "/bin/xz"))))))) |
cd295fbe | 137 | |
f0527ce3 LC |
138 | \f |
139 | ;;; | |
140 | ;;; 'gexp->script'. | |
141 | ;;; | |
142 | ;;; This is our own variant of 'gexp->script' with an extra #:module-path | |
143 | ;;; parameter, which was unavailable in (guix gexp) until commit | |
144 | ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.) | |
145 | ;;; | |
cd295fbe | 146 | |
f0527ce3 LC |
147 | (define (load-path-expression modules path) |
148 | "Return as a monadic value a gexp that sets '%load-path' and | |
149 | '%load-compiled-path' to point to MODULES, a list of module names. MODULES | |
150 | are searched for in PATH." | |
151 | (mlet %store-monad ((modules (imported-modules modules | |
152 | #:module-path path)) | |
153 | (compiled (compiled-modules modules | |
154 | #:module-path path))) | |
155 | (return (gexp (eval-when (expand load eval) | |
156 | (set! %load-path | |
157 | (cons (ungexp modules) %load-path)) | |
158 | (set! %load-compiled-path | |
159 | (cons (ungexp compiled) | |
160 | %load-compiled-path))))))) | |
161 | ||
162 | (define* (gexp->script name exp | |
163 | #:key (guile (default-guile)) | |
164 | (module-path %load-path)) | |
165 | "Return an executable script NAME that runs EXP using GUILE, with EXP's | |
166 | imported modules in its search path." | |
167 | (mlet %store-monad ((set-load-path | |
168 | (load-path-expression (gexp-modules exp) | |
169 | module-path))) | |
170 | (gexp->derivation name | |
171 | (gexp | |
172 | (call-with-output-file (ungexp output) | |
173 | (lambda (port) | |
174 | ;; Note: that makes a long shebang. When the store | |
175 | ;; is /gnu/store, that fits within the 128-byte | |
176 | ;; limit imposed by Linux, but that may go beyond | |
177 | ;; when running tests. | |
178 | (format port | |
179 | "#!~a/bin/guile --no-auto-compile~%!#~%" | |
180 | (ungexp guile)) | |
181 | ||
182 | (write '(ungexp set-load-path) port) | |
183 | (write '(ungexp exp) port) | |
184 | (chmod port #o555)))) | |
185 | #:module-path module-path))) | |
b006ba50 | 186 | |
f0527ce3 | 187 | \f |
b006ba50 LC |
188 | (define (date-version-string) |
189 | "Return the current date and hour in UTC timezone, for use as a poor | |
190 | person's version identifier." | |
cd295fbe | 191 | ;; XXX: Replace with a Git commit id. |
b006ba50 LC |
192 | (date->string (current-date 0) "~Y~m~d.~H")) |
193 | ||
ca719424 LC |
194 | (define guile-gcrypt |
195 | ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in | |
196 | ;; August 2018. If it has it, it's at least version 0.1.0, which is good | |
197 | ;; enough. If it doesn't, specify our own package because the target Guix | |
198 | ;; requires it. | |
199 | (match (find-best-packages-by-name "guile-gcrypt" #f) | |
200 | (() | |
201 | (package | |
202 | (name "guile-gcrypt") | |
203 | (version "0.1.0") | |
204 | (home-page "https://notabug.org/cwebber/guile-gcrypt") | |
205 | (source (origin | |
206 | (method url-fetch) | |
207 | (uri (string-append home-page "/archive/v" version ".tar.gz")) | |
208 | (sha256 | |
209 | (base32 | |
210 | "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3")) | |
211 | (file-name (string-append name "-" version ".tar.gz")))) | |
212 | (build-system gnu-build-system) | |
3ffcad7d LC |
213 | (arguments |
214 | ;; The 'bootstrap' phase appeared in 'core-updates', which was merged | |
215 | ;; into 'master' ca. June 2018. | |
216 | '(#:phases (modify-phases %standard-phases | |
217 | (delete 'bootstrap) | |
218 | (add-before 'configure 'bootstrap | |
219 | (lambda _ | |
220 | (unless (zero? (system* "autoreconf" "-vfi")) | |
221 | (error "autoreconf failed")) | |
222 | #t))))) | |
ca719424 LC |
223 | (native-inputs |
224 | `(("pkg-config" ,(specification->package "pkg-config")) | |
225 | ("autoconf" ,(specification->package "autoconf")) | |
226 | ("automake" ,(specification->package "automake")) | |
227 | ("texinfo" ,(specification->package "texinfo")))) | |
228 | (inputs | |
229 | `(("guile" ,(specification->package "guile")) | |
230 | ("libgcrypt" ,(specification->package "libgcrypt")))) | |
231 | (synopsis "Cryptography library for Guile using Libgcrypt") | |
232 | (description | |
233 | "Guile-Gcrypt provides a Guile 2.x interface to a subset of the | |
234 | GNU Libgcrypt crytographic library. It provides modules for cryptographic | |
235 | hash functions, message authentication codes (MAC), public-key cryptography, | |
236 | strong randomness, and more. It is implemented using the foreign function | |
237 | interface (FFI) of Guile.") | |
238 | (license #f))) ;license:gpl3+ | |
239 | ((package . _) | |
240 | package))) | |
241 | ||
f0527ce3 | 242 | (define* (build-program source version |
8a0d9bc8 | 243 | #:optional (guile-version (effective-version)) |
316fc2ac | 244 | #:key (pull-version 0) (channel-metadata #f)) |
f0527ce3 LC |
245 | "Return a program that computes the derivation to build Guix from SOURCE." |
246 | (define select? | |
247 | ;; Select every module but (guix config) and non-Guix modules. | |
aedbc5ff LC |
248 | ;; Also exclude (guix channels): it is autoloaded by (guix describe), but |
249 | ;; only for peripheral functionality. | |
f0527ce3 LC |
250 | (match-lambda |
251 | (('guix 'config) #f) | |
aedbc5ff | 252 | (('guix 'channels) #f) |
f0527ce3 LC |
253 | (('guix _ ...) #t) |
254 | (('gnu _ ...) #t) | |
255 | (_ #f))) | |
256 | ||
ca719424 LC |
257 | (define fake-gcrypt-hash |
258 | ;; Fake (gcrypt hash) module; see below. | |
259 | (scheme-file "hash.scm" | |
260 | #~(define-module (gcrypt hash) | |
261 | #:export (sha1 sha256)))) | |
262 | ||
78c9058d LC |
263 | (define fake-git |
264 | (scheme-file "git.scm" #~(define-module (git)))) | |
265 | ||
f0527ce3 | 266 | (with-imported-modules `(((guix config) |
ca719424 LC |
267 | => ,(make-config.scm)) |
268 | ||
269 | ;; To avoid relying on 'with-extensions', which was | |
270 | ;; introduced in 0.15.0, provide a fake (gcrypt | |
271 | ;; hash) just so that we can build modules, and | |
272 | ;; adjust %LOAD-PATH later on. | |
273 | ((gcrypt hash) => ,fake-gcrypt-hash) | |
274 | ||
78c9058d LC |
275 | ;; (guix git-download) depends on (git) but only |
276 | ;; for peripheral functionality. Provide a dummy | |
277 | ;; (git) to placate it. | |
278 | ((git) => ,fake-git) | |
279 | ||
f0527ce3 LC |
280 | ,@(source-module-closure `((guix store) |
281 | (guix self) | |
282 | (guix derivations) | |
283 | (gnu packages bootstrap)) | |
284 | (list source) | |
285 | #:select? select?)) | |
286 | (gexp->script "compute-guix-derivation" | |
287 | #~(begin | |
05e78387 MB |
288 | (use-modules (ice-9 match) |
289 | (ice-9 threads)) | |
f0527ce3 LC |
290 | |
291 | (eval-when (expand load eval) | |
f0527ce3 LC |
292 | ;; (gnu packages …) modules are going to be looked up |
293 | ;; under SOURCE. (guix config) is looked up in FRONT. | |
1f1d76a1 LC |
294 | (match (command-line) |
295 | ((_ source _ ...) | |
296 | (match %load-path | |
297 | ((front _ ...) | |
298 | (unless (string=? front source) ;already done? | |
ca719424 LC |
299 | (set! %load-path |
300 | (list source | |
301 | (string-append #$guile-gcrypt | |
302 | "/share/guile/site/" | |
303 | (effective-version)) | |
304 | front))))))) | |
f0527ce3 | 305 | |
ca719424 LC |
306 | ;; Only load Guile-Gcrypt, our own modules, or those |
307 | ;; of Guile. | |
e9dfa4d8 LC |
308 | (set! %load-compiled-path |
309 | (cons (string-append #$guile-gcrypt "/lib/guile/" | |
310 | (effective-version) | |
311 | "/site-ccache") | |
ec8bc4a3 LC |
312 | %load-compiled-path)) |
313 | ||
314 | ;; Disable position recording to save time and space | |
315 | ;; when loading the package modules. | |
316 | (read-disable 'positions)) | |
f0527ce3 LC |
317 | |
318 | (use-modules (guix store) | |
319 | (guix self) | |
320 | (guix derivations) | |
321 | (srfi srfi-1)) | |
322 | ||
323 | (define (spin system) | |
324 | (define spin | |
325 | (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/")) | |
326 | ||
327 | (format (current-error-port) | |
328 | "Computing Guix derivation for '~a'... " | |
329 | system) | |
c108c46f LC |
330 | (when (isatty? (current-error-port)) |
331 | (let loop ((spin spin)) | |
332 | (display (string-append "\b" (car spin)) | |
333 | (current-error-port)) | |
334 | (force-output (current-error-port)) | |
335 | (sleep 1) | |
336 | (loop (cdr spin))))) | |
f0527ce3 LC |
337 | |
338 | (match (command-line) | |
790c3e01 LC |
339 | ((_ source system version protocol-version) |
340 | ;; The current input port normally wraps a file | |
341 | ;; descriptor connected to the daemon, or it is | |
342 | ;; connected to /dev/null. In the former case, reuse | |
343 | ;; the connection such that we inherit build options | |
344 | ;; such as substitute URLs and so on; in the latter | |
345 | ;; case, attempt to open a new connection. | |
346 | (let* ((proto (string->number protocol-version)) | |
347 | (store (if (integer? proto) | |
348 | (port->connection (duplicate-port | |
349 | (current-input-port) | |
350 | "w+0") | |
351 | #:version proto) | |
352 | (open-connection)))) | |
f0527ce3 LC |
353 | (call-with-new-thread |
354 | (lambda () | |
355 | (spin system))) | |
356 | ||
357 | (display | |
8a0d9bc8 | 358 | (and=> |
f0527ce3 | 359 | (run-with-store store |
1f1d76a1 | 360 | (guix-derivation source version |
8a0d9bc8 | 361 | #$guile-version |
316fc2ac LC |
362 | #:channel-metadata |
363 | '#$channel-metadata | |
8a0d9bc8 LC |
364 | #:pull-version |
365 | #$pull-version) | |
366 | #:system system) | |
367 | derivation-file-name)))))) | |
f0527ce3 | 368 | #:module-path (list source)))) |
838ba73d | 369 | |
e9dfa4d8 LC |
370 | (define (call-with-clean-environment thunk) |
371 | (let ((env (environ))) | |
372 | (dynamic-wind | |
373 | (lambda () | |
374 | (environ '())) | |
375 | thunk | |
376 | (lambda () | |
377 | (environ env))))) | |
378 | ||
379 | (define-syntax-rule (with-clean-environment exp ...) | |
380 | "Evaluate EXP in a context where zero environment variables are defined." | |
381 | (call-with-clean-environment (lambda () exp ...))) | |
382 | ||
f81ac34d | 383 | ;; The procedure below is our return value. |
b006ba50 | 384 | (define* (build source |
316fc2ac LC |
385 | #:key verbose? |
386 | (version (date-version-string)) channel-metadata | |
387 | system | |
8a0d9bc8 | 388 | (pull-version 0) |
1428bce3 | 389 | |
b6bee63b | 390 | ;; For the standalone Guix, default to Guile 3.0. For old |
1428bce3 LC |
391 | ;; versions of 'guix pull' (pre-0.15.0), we have to use the |
392 | ;; same Guile as the current one. | |
393 | (guile-version (if (> pull-version 0) | |
b6bee63b | 394 | "3.0" |
1428bce3 LC |
395 | (effective-version))) |
396 | ||
f81ac34d LC |
397 | #:allow-other-keys |
398 | #:rest rest) | |
399 | "Return a derivation that unpacks SOURCE into STORE and compiles Scheme | |
400 | files." | |
f0527ce3 LC |
401 | ;; Build the build program and then use it as a trampoline to build from |
402 | ;; SOURCE. | |
8a0d9bc8 | 403 | (mlet %store-monad ((build (build-program source version guile-version |
316fc2ac | 404 | #:channel-metadata channel-metadata |
8a0d9bc8 | 405 | #:pull-version pull-version)) |
790c3e01 | 406 | (system (if system (return system) (current-system))) |
e0244eb7 | 407 | (home -> (getenv "HOME")) |
04fa9c62 LC |
408 | |
409 | ;; Note: Use the deprecated names here because the | |
410 | ;; caller might be Guix <= 0.16.0. | |
ffc8ab75 LC |
411 | (port ((store-lift nix-server-socket))) |
412 | (major ((store-lift nix-server-major-version))) | |
413 | (minor ((store-lift nix-server-minor-version)))) | |
f0527ce3 | 414 | (mbegin %store-monad |
11dee1bb LC |
415 | ;; Before 'with-build-handler' was implemented and used, we had to |
416 | ;; explicitly call 'show-what-to-build*'. | |
417 | (munless (module-defined? (resolve-module '(guix store)) | |
418 | 'with-build-handler) | |
419 | (show-what-to-build* (list build))) | |
f0527ce3 | 420 | (built-derivations (list build)) |
790c3e01 LC |
421 | |
422 | ;; Use the port beneath the current store as the stdin of BUILD. This | |
423 | ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is | |
424 | ;; not a file port (e.g., it's an SSH channel), then the subprocess's | |
425 | ;; stdin will actually be /dev/null. | |
426 | (let* ((pipe (with-input-from-port port | |
427 | (lambda () | |
e9dfa4d8 LC |
428 | ;; Make sure BUILD is not influenced by |
429 | ;; $GUILE_LOAD_PATH & co. | |
430 | (with-clean-environment | |
431 | (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive | |
7ff86eca | 432 | (setenv "COLUMNS" "120") ;show wider backtraces |
e0244eb7 LC |
433 | (when home |
434 | ;; Inherit HOME so that 'xdg-directory' works. | |
435 | (setenv "HOME" home)) | |
e9dfa4d8 LC |
436 | (open-pipe* OPEN_READ |
437 | (derivation->output-path build) | |
438 | source system version | |
439 | (if (file-port? port) | |
440 | (number->string | |
441 | (logior major minor)) | |
442 | "none")))))) | |
f27a7128 LC |
443 | (str (get-string-all pipe)) |
444 | (status (close-pipe pipe))) | |
445 | (match str | |
f0527ce3 | 446 | ((? eof-object?) |
f27a7128 | 447 | (error "build program failed" (list build status))) |
f0527ce3 LC |
448 | ((? derivation-path? drv) |
449 | (mbegin %store-monad | |
afb82831 | 450 | (return (newline (current-error-port))) |
f0527ce3 LC |
451 | ((store-lift add-temp-root) drv) |
452 | (return (read-derivation-from-file drv)))) | |
8a0d9bc8 LC |
453 | ("#f" |
454 | ;; Unsupported PULL-VERSION. | |
455 | (return #f)) | |
f0527ce3 | 456 | ((? string? str) |
ac4d2ec8 LC |
457 | (raise (condition |
458 | (&message | |
459 | (message (format #f "You found a bug: the program '~a' | |
460 | failed to compute the derivation for Guix (version: ~s; system: ~s; | |
461 | host version: ~s; pull-version: ~s). | |
462 | Please report it by email to <~a>.~%" | |
463 | (derivation->output-path build) | |
464 | version system %guix-version pull-version | |
465 | %guix-bug-report-address))))))))))) | |
f81ac34d LC |
466 | |
467 | ;; This file is loaded by 'guix pull'; return it the build procedure. | |
468 | build | |
469 | ||
cd295fbe LC |
470 | ;; Local Variables: |
471 | ;; eval: (put 'with-load-path 'scheme-indent-function 1) | |
472 | ;; End: | |
473 | ||
f81ac34d | 474 | ;;; build-self.scm ends here |