| blob | 8eb61623f4383f2376bced9bbcb90ef013f1e3e9 |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
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/>.
19 (define-module (build-self)
20 #:use-module (gnu)
21 #:use-module (guix)
22 #:use-module (guix ui)
23 #:use-module (guix config)
24 #:use-module (guix modules)
25 #:use-module (guix build-system gnu)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-19)
28 #:use-module (srfi srfi-34)
29 #:use-module (srfi srfi-35)
30 #:use-module (rnrs io ports)
31 #:use-module (ice-9 match)
32 #:use-module (ice-9 popen)
33 #:export (build))
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 ;;;
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 ;;;
47 ;;; Code:
49 \f
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 ;;;
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))
64 (define %config-variables
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 ...))))))
72 (variables %localstatedir %storedir %sysconfdir %system)))
74 (define* (make-config.scm #:key zlib gzip xz bzip2
75 (package-name "GNU Guix")
76 (package-version "0")
77 (bug-report-address "bug-guix@gnu.org")
78 (home-page-url "https://gnu.org/s/guix"))
80 ;; Hack so that Geiser is not confused.
81 (define defmod 'define-module)
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
90 %store-directory
91 %state-directory
92 %store-database-directory
93 %config-directory
94 %libz
95 %gzip
96 %bzip2
97 %xz))
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)
106 (define %store-directory
107 (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
108 %storedir))
110 (define %state-directory
111 ;; This must match `NIX_STATE_DIR' as defined in
112 ;; `nix/local.mk'.
113 (or (getenv "GUIX_STATE_DIRECTORY")
114 (string-append %localstatedir "/guix")))
116 (define %store-database-directory
117 (or (getenv "GUIX_DATABASE_DIRECTORY")
118 (string-append %state-directory "/db")))
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")))
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)
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
136 #+(and xz (file-append xz "/bin/xz")))
138 (define %libz
139 #+(and zlib
140 (file-append zlib "/lib/libz")))))))
142 \f
143 ;;;
144 ;;; 'gexp->script'.
145 ;;;
146 ;;; This is our own variant of 'gexp->script' with an extra #:module-path
147 ;;; parameter, which was unavailable in (guix gexp) until commit
148 ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
149 ;;;
151 (define (load-path-expression modules path)
152 "Return as a monadic value a gexp that sets '%load-path' and
153 '%load-compiled-path' to point to MODULES, a list of module names. MODULES
154 are searched for in PATH."
155 (mlet %store-monad ((modules (imported-modules modules
156 #:module-path path))
157 (compiled (compiled-modules modules
158 #:module-path path)))
159 (return (gexp (eval-when (expand load eval)
160 (set! %load-path
161 (cons (ungexp modules) %load-path))
162 (set! %load-compiled-path
163 (cons (ungexp compiled)
164 %load-compiled-path)))))))
166 (define* (gexp->script name exp
167 #:key (guile (default-guile))
168 (module-path %load-path))
169 "Return an executable script NAME that runs EXP using GUILE, with EXP's
170 imported modules in its search path."
171 (mlet %store-monad ((set-load-path
172 (load-path-expression (gexp-modules exp)
173 module-path)))
174 (gexp->derivation name
175 (gexp
176 (call-with-output-file (ungexp output)
177 (lambda (port)
178 ;; Note: that makes a long shebang. When the store
179 ;; is /gnu/store, that fits within the 128-byte
180 ;; limit imposed by Linux, but that may go beyond
181 ;; when running tests.
182 (format port
183 "#!~a/bin/guile --no-auto-compile~%!#~%"
184 (ungexp guile))
186 (write '(ungexp set-load-path) port)
187 (write '(ungexp exp) port)
188 (chmod port #o555))))
189 #:module-path module-path)))
191 \f
192 (define (date-version-string)
193 "Return the current date and hour in UTC timezone, for use as a poor
194 person's version identifier."
195 ;; XXX: Replace with a Git commit id.
196 (date->string (current-date 0) "~Y~m~d.~H"))
198 (define guile-gcrypt
199 ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
200 ;; August 2018. If it has it, it's at least version 0.1.0, which is good
201 ;; enough. If it doesn't, specify our own package because the target Guix
202 ;; requires it.
203 (match (find-best-packages-by-name "guile-gcrypt" #f)
204 (()
205 (package
206 (name "guile-gcrypt")
207 (version "0.1.0")
208 (home-page "https://notabug.org/cwebber/guile-gcrypt")
209 (source (origin
210 (method url-fetch)
211 (uri (string-append home-page "/archive/v" version ".tar.gz"))
212 (sha256
213 (base32
214 "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
215 (file-name (string-append name "-" version ".tar.gz"))))
216 (build-system gnu-build-system)
217 (arguments
218 ;; The 'bootstrap' phase appeared in 'core-updates', which was merged
219 ;; into 'master' ca. June 2018.
220 '(#:phases (modify-phases %standard-phases
221 (delete 'bootstrap)
222 (add-before 'configure 'bootstrap
223 (lambda _
224 (unless (zero? (system* "autoreconf" "-vfi"))
225 (error "autoreconf failed"))
226 #t)))))
227 (native-inputs
228 `(("pkg-config" ,(specification->package "pkg-config"))
229 ("autoconf" ,(specification->package "autoconf"))
230 ("automake" ,(specification->package "automake"))
231 ("texinfo" ,(specification->package "texinfo"))))
232 (inputs
233 `(("guile" ,(specification->package "guile"))
234 ("libgcrypt" ,(specification->package "libgcrypt"))))
235 (synopsis "Cryptography library for Guile using Libgcrypt")
236 (description
237 "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
238 GNU Libgcrypt crytographic library. It provides modules for cryptographic
239 hash functions, message authentication codes (MAC), public-key cryptography,
240 strong randomness, and more. It is implemented using the foreign function
241 interface (FFI) of Guile.")
242 (license #f))) ;license:gpl3+
243 ((package . _)
244 package)))
246 (define* (build-program source version
247 #:optional (guile-version (effective-version))
248 #:key (pull-version 0))
249 "Return a program that computes the derivation to build Guix from SOURCE."
250 (define select?
251 ;; Select every module but (guix config) and non-Guix modules.
252 (match-lambda
253 (('guix 'config) #f)
254 (('guix _ ...) #t)
255 (('gnu _ ...) #t)
256 (_ #f)))
258 (define fake-gcrypt-hash
259 ;; Fake (gcrypt hash) module; see below.
260 (scheme-file "hash.scm"
261 #~(define-module (gcrypt hash)
262 #:export (sha1 sha256))))
264 (define fake-git
265 (scheme-file "git.scm" #~(define-module (git))))
267 (with-imported-modules `(((guix config)
268 => ,(make-config.scm))
270 ;; To avoid relying on 'with-extensions', which was
271 ;; introduced in 0.15.0, provide a fake (gcrypt
272 ;; hash) just so that we can build modules, and
273 ;; adjust %LOAD-PATH later on.
274 ((gcrypt hash) => ,fake-gcrypt-hash)
276 ;; (guix git-download) depends on (git) but only
277 ;; for peripheral functionality. Provide a dummy
278 ;; (git) to placate it.
279 ((git) => ,fake-git)
281 ,@(source-module-closure `((guix store)
282 (guix self)
283 (guix derivations)
284 (gnu packages bootstrap))
285 (list source)
286 #:select? select?))
287 (gexp->script "compute-guix-derivation"
288 #~(begin
289 (use-modules (ice-9 match))
291 (eval-when (expand load eval)
292 ;; (gnu packages …) modules are going to be looked up
293 ;; under SOURCE. (guix config) is looked up in FRONT.
294 (match (command-line)
295 ((_ source _ ...)
296 (match %load-path
297 ((front _ ...)
298 (unless (string=? front source) ;already done?
299 (set! %load-path
300 (list source
301 (string-append #$guile-gcrypt
302 "/share/guile/site/"
303 (effective-version))
304 front)))))))
306 ;; Only load Guile-Gcrypt, our own modules, or those
307 ;; of Guile.
308 (set! %load-compiled-path
309 (cons (string-append #$guile-gcrypt "/lib/guile/"
310 (effective-version)
311 "/site-ccache")
312 %load-compiled-path))
314 ;; Disable position recording to save time and space
315 ;; when loading the package modules.
316 (read-disable 'positions))
318 (use-modules (guix store)
319 (guix self)
320 (guix derivations)
321 (srfi srfi-1))
323 (define (spin system)
324 (define spin
325 (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
327 (format (current-error-port)
328 "Computing Guix derivation for '~a'... "
329 system)
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)))))
338 (match (command-line)
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))))
353 (call-with-new-thread
354 (lambda ()
355 (spin system)))
357 (display
358 (and=>
359 (run-with-store store
360 (guix-derivation source version
361 #$guile-version
362 #:pull-version
363 #$pull-version)
364 #:system system)
365 derivation-file-name))))))
366 #:module-path (list source))))
368 (define (call-with-clean-environment thunk)
369 (let ((env (environ)))
370 (dynamic-wind
371 (lambda ()
372 (environ '()))
373 thunk
374 (lambda ()
375 (environ env)))))
377 (define-syntax-rule (with-clean-environment exp ...)
378 "Evaluate EXP in a context where zero environment variables are defined."
379 (call-with-clean-environment (lambda () exp ...)))
381 ;; The procedure below is our return value.
382 (define* (build source
383 #:key verbose? (version (date-version-string)) system
384 (pull-version 0)
386 ;; For the standalone Guix, default to Guile 2.2. For old
387 ;; versions of 'guix pull' (pre-0.15.0), we have to use the
388 ;; same Guile as the current one.
389 (guile-version (if (> pull-version 0)
390 "2.2"
391 (effective-version)))
393 #:allow-other-keys
394 #:rest rest)
395 "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
396 files."
397 ;; Build the build program and then use it as a trampoline to build from
398 ;; SOURCE.
399 (mlet %store-monad ((build (build-program source version guile-version
400 #:pull-version pull-version))
401 (system (if system (return system) (current-system)))
402 (home (getenv "HOME"))
404 ;; Note: Use the deprecated names here because the
405 ;; caller might be Guix <= 0.16.0.
406 (port ((store-lift nix-server-socket)))
407 (major ((store-lift nix-server-major-version)))
408 (minor ((store-lift nix-server-minor-version))))
409 (mbegin %store-monad
410 (show-what-to-build* (list build))
411 (built-derivations (list build))
413 ;; Use the port beneath the current store as the stdin of BUILD. This
414 ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is
415 ;; not a file port (e.g., it's an SSH channel), then the subprocess's
416 ;; stdin will actually be /dev/null.
417 (let* ((pipe (with-input-from-port port
418 (lambda ()
419 ;; Make sure BUILD is not influenced by
420 ;; $GUILE_LOAD_PATH & co.
421 (with-clean-environment
422 (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
423 (when home
424 ;; Inherit HOME so that 'xdg-directory' works.
425 (setenv "HOME" home))
426 (open-pipe* OPEN_READ
427 (derivation->output-path build)
428 source system version
429 (if (file-port? port)
430 (number->string
431 (logior major minor))
432 "none"))))))
433 (str (get-string-all pipe))
434 (status (close-pipe pipe)))
435 (match str
436 ((? eof-object?)
437 (error "build program failed" (list build status)))
438 ((? derivation-path? drv)
439 (mbegin %store-monad
440 (return (newline (current-error-port)))
441 ((store-lift add-temp-root) drv)
442 (return (read-derivation-from-file drv))))
443 ("#f"
444 ;; Unsupported PULL-VERSION.
445 (return #f))
446 ((? string? str)
447 (raise (condition
448 (&message
449 (message (format #f "You found a bug: the program '~a'
450 failed to compute the derivation for Guix (version: ~s; system: ~s;
451 host version: ~s; pull-version: ~s).
452 Please report it by email to <~a>.~%"
453 (derivation->output-path build)
454 version system %guix-version pull-version
455 %guix-bug-report-address)))))))))))
457 ;; This file is loaded by 'guix pull'; return it the build procedure.
458 build
460 ;; Local Variables:
461 ;; eval: (put 'with-load-path 'scheme-indent-function 1)
462 ;; End:
464 ;;; build-self.scm ends here