1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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)
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)
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
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.
51 ;;; Generating (guix config).
53 ;;; This is copied from (guix self) because we cannot assume (guix self) is
54 ;;; available at this point.
57 (define %dependency-variables
58 ;; (guix config) variables corresponding to dependencies.
59 '(%libgcrypt %libz %xz %gzip %bzip2))
61 (define %persona-variables
62 ;; (guix config) variables that define Guix's persona.
65 %guix-bug-report-address
68 (define %config-variables
69 ;; (guix config) variables corresponding to Guix configuration.
70 (letrec-syntax ((variables (syntax-rules ()
73 ((_ variable rest ...)
74 (cons `(variable . ,variable)
75 (variables rest ...))))))
76 (variables %localstatedir %storedir %sysconfdir %system)))
78 (define* (make-config.scm #:key zlib gzip xz bzip2
79 (package-name "GNU Guix")
81 (bug-report-address "bug-guix@gnu.org")
82 (home-page-url "https://gnu.org/s/guix"))
84 ;; Hack so that Geiser is not confused.
85 (define defmod 'define-module)
87 (scheme-file "config.scm"
89 (#$defmod (guix config)
90 #:export (%guix-package-name
92 %guix-bug-report-address
96 %store-database-directory
103 ;; XXX: Work around <http://bugs.gnu.org/15602>.
104 (eval-when (expand load eval)
105 #$@(map (match-lambda
107 #~(define-public #$name #$value)))
110 (define %store-directory
111 (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
114 (define %state-directory
115 ;; This must match `NIX_STATE_DIR' as defined in
117 (or (getenv "NIX_STATE_DIR")
118 (string-append %localstatedir "/guix")))
120 (define %store-database-directory
121 (or (getenv "NIX_DB_DIR")
122 (string-append %state-directory "/db")))
124 (define %config-directory
125 ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
126 ;; defined in `nix/local.mk'.
127 (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
128 (string-append %sysconfdir "/guix")))
130 (define %guix-package-name #$package-name)
131 (define %guix-version #$package-version)
132 (define %guix-bug-report-address #$bug-report-address)
133 (define %guix-home-page-url #$home-page-url)
136 #+(and gzip (file-append gzip "/bin/gzip")))
138 #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
140 #+(and xz (file-append xz "/bin/xz")))
144 (file-append zlib "/lib/libz")))))))
150 ;;; This is our own variant of 'gexp->script' with an extra #:module-path
151 ;;; parameter, which was unavailable in (guix gexp) until commit
152 ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
155 (define (load-path-expression modules path)
156 "Return as a monadic value a gexp that sets '%load-path' and
157 '%load-compiled-path' to point to MODULES, a list of module names. MODULES
158 are searched for in PATH."
159 (mlet %store-monad ((modules (imported-modules modules
161 (compiled (compiled-modules modules
162 #:module-path path)))
163 (return (gexp (eval-when (expand load eval)
165 (cons (ungexp modules) %load-path))
166 (set! %load-compiled-path
167 (cons (ungexp compiled)
168 %load-compiled-path)))))))
170 (define* (gexp->script name exp
171 #:key (guile (default-guile))
172 (module-path %load-path))
173 "Return an executable script NAME that runs EXP using GUILE, with EXP's
174 imported modules in its search path."
175 (mlet %store-monad ((set-load-path
176 (load-path-expression (gexp-modules exp)
178 (gexp->derivation name
180 (call-with-output-file (ungexp output)
182 ;; Note: that makes a long shebang. When the store
183 ;; is /gnu/store, that fits within the 128-byte
184 ;; limit imposed by Linux, but that may go beyond
185 ;; when running tests.
187 "#!~a/bin/guile --no-auto-compile~%!#~%"
190 (write '(ungexp set-load-path) port)
191 (write '(ungexp exp) port)
192 (chmod port #o555))))
193 #:module-path module-path)))
196 (define (date-version-string)
197 "Return the current date and hour in UTC timezone, for use as a poor
198 person's version identifier."
199 ;; XXX: Replace with a Git commit id.
200 (date->string (current-date 0) "~Y~m~d.~H"))
203 ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
204 ;; August 2018. If it has it, it's at least version 0.1.0, which is good
205 ;; enough. If it doesn't, specify our own package because the target Guix
207 (match (find-best-packages-by-name "guile-gcrypt" #f)
210 (name "guile-gcrypt")
212 (home-page "https://notabug.org/cwebber/guile-gcrypt")
215 (uri (string-append home-page "/archive/v" version ".tar.gz"))
218 "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
219 (file-name (string-append name "-" version ".tar.gz"))))
220 (build-system gnu-build-system)
222 ;; The 'bootstrap' phase appeared in 'core-updates', which was merged
223 ;; into 'master' ca. June 2018.
224 '(#:phases (modify-phases %standard-phases
226 (add-before 'configure 'bootstrap
228 (unless (zero? (system* "autoreconf" "-vfi"))
229 (error "autoreconf failed"))
232 `(("pkg-config" ,(specification->package "pkg-config"))
233 ("autoconf" ,(specification->package "autoconf"))
234 ("automake" ,(specification->package "automake"))
235 ("texinfo" ,(specification->package "texinfo"))))
237 `(("guile" ,(specification->package "guile"))
238 ("libgcrypt" ,(specification->package "libgcrypt"))))
239 (synopsis "Cryptography library for Guile using Libgcrypt")
241 "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
242 GNU Libgcrypt crytographic library. It provides modules for cryptographic
243 hash functions, message authentication codes (MAC), public-key cryptography,
244 strong randomness, and more. It is implemented using the foreign function
245 interface (FFI) of Guile.")
246 (license #f))) ;license:gpl3+
250 (define* (build-program source version
251 #:optional (guile-version (effective-version))
252 #:key (pull-version 0))
253 "Return a program that computes the derivation to build Guix from SOURCE."
255 ;; Select every module but (guix config) and non-Guix modules.
262 (define fake-gcrypt-hash
263 ;; Fake (gcrypt hash) module; see below.
264 (scheme-file "hash.scm"
265 #~(define-module (gcrypt hash)
266 #:export (sha1 sha256))))
269 (scheme-file "git.scm" #~(define-module (git))))
271 (with-imported-modules `(((guix config)
272 => ,(make-config.scm))
274 ;; To avoid relying on 'with-extensions', which was
275 ;; introduced in 0.15.0, provide a fake (gcrypt
276 ;; hash) just so that we can build modules, and
277 ;; adjust %LOAD-PATH later on.
278 ((gcrypt hash) => ,fake-gcrypt-hash)
280 ;; (guix git-download) depends on (git) but only
281 ;; for peripheral functionality. Provide a dummy
282 ;; (git) to placate it.
285 ,@(source-module-closure `((guix store)
288 (gnu packages bootstrap))
291 (gexp->script "compute-guix-derivation"
293 (use-modules (ice-9 match))
295 (eval-when (expand load eval)
296 ;; Don't augment '%load-path'.
297 (unsetenv "GUIX_PACKAGE_PATH")
299 ;; (gnu packages …) modules are going to be looked up
300 ;; under SOURCE. (guix config) is looked up in FRONT.
301 (match (command-line)
305 (unless (string=? front source) ;already done?
308 (string-append #$guile-gcrypt
313 ;; Only load Guile-Gcrypt, our own modules, or those
315 (match %load-compiled-path
316 ((front _ ... sys1 sys2)
317 (unless (string-prefix? #$guile-gcrypt front)
318 (set! %load-compiled-path
319 (list (string-append #$guile-gcrypt
323 front sys1 sys2))))))
325 (use-modules (guix store)
330 (define (spin system)
332 (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
334 (format (current-error-port)
335 "Computing Guix derivation for '~a'... "
337 (let loop ((spin spin))
338 (display (string-append "\b" (car spin))
339 (current-error-port))
340 (force-output (current-error-port))
344 (match (command-line)
345 ((_ source system version protocol-version)
346 ;; The current input port normally wraps a file
347 ;; descriptor connected to the daemon, or it is
348 ;; connected to /dev/null. In the former case, reuse
349 ;; the connection such that we inherit build options
350 ;; such as substitute URLs and so on; in the latter
351 ;; case, attempt to open a new connection.
352 (let* ((proto (string->number protocol-version))
353 (store (if (integer? proto)
354 (port->connection (duplicate-port
359 (call-with-new-thread
365 (run-with-store store
366 (guix-derivation source version
371 derivation-file-name))))))
372 #:module-path (list source))))
374 ;; The procedure below is our return value.
375 (define* (build source
376 #:key verbose? (version (date-version-string)) system
379 ;; For the standalone Guix, default to Guile 2.2. For old
380 ;; versions of 'guix pull' (pre-0.15.0), we have to use the
381 ;; same Guile as the current one.
382 (guile-version (if (> pull-version 0)
384 (effective-version)))
388 "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
390 ;; Build the build program and then use it as a trampoline to build from
392 (mlet %store-monad ((build (build-program source version guile-version
393 #:pull-version pull-version))
394 (system (if system (return system) (current-system)))
395 (port ((store-lift nix-server-socket)))
396 (major ((store-lift nix-server-major-version)))
397 (minor ((store-lift nix-server-minor-version))))
399 (show-what-to-build* (list build))
400 (built-derivations (list build))
402 ;; Use the port beneath the current store as the stdin of BUILD. This
403 ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is
404 ;; not a file port (e.g., it's an SSH channel), then the subprocess's
405 ;; stdin will actually be /dev/null.
406 (let* ((pipe (with-input-from-port port
408 (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
409 (open-pipe* OPEN_READ
410 (derivation->output-path build)
411 source system version
412 (if (file-port? port)
414 (logior major minor))
416 (str (get-string-all pipe))
417 (status (close-pipe pipe)))
420 (error "build program failed" (list build status)))
421 ((? derivation-path? drv)
423 (return (newline (current-error-port)))
424 ((store-lift add-temp-root) drv)
425 (return (read-derivation-from-file drv))))
427 ;; Unsupported PULL-VERSION.
432 (message (format #f "You found a bug: the program '~a'
433 failed to compute the derivation for Guix (version: ~s; system: ~s;
434 host version: ~s; pull-version: ~s).
435 Please report it by email to <~a>.~%"
436 (derivation->output-path build)
437 version system %guix-version pull-version
438 %guix-bug-report-address)))))))))))
440 ;; This file is loaded by 'guix pull'; return it the build procedure.
444 ;; eval: (put 'with-load-path 'scheme-indent-function 1)
447 ;;; build-self.scm ends here