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 (srfi srfi-1)
26 #:use-module (srfi srfi-19)
27 #:use-module (rnrs io ports)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 popen)
34 ;;; When loaded, this module returns a monadic procedure of at least one
35 ;;; argument: the source tree to build. It returns a derivation that
38 ;;; This file uses modules provided by the already-installed Guix. Those
39 ;;; modules may be arbitrarily old compared to the version we want to
40 ;;; build. Because of that, it must rely on the smallest set of features
41 ;;; that are likely to be provided by the (guix) and (gnu) modules, and by
42 ;;; Guile itself, forever and ever.
48 ;;; Generating (guix config).
50 ;;; This is copied from (guix self) because we cannot assume (guix self) is
51 ;;; available at this point.
54 (define %dependency-variables
55 ;; (guix config) variables corresponding to dependencies.
56 '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
58 (define %persona-variables
59 ;; (guix config) variables that define Guix's persona.
62 %guix-bug-report-address
65 (define %config-variables
66 ;; (guix config) variables corresponding to Guix configuration.
67 (letrec-syntax ((variables (syntax-rules ()
70 ((_ variable rest ...)
71 (cons `(variable . ,variable)
72 (variables rest ...))))))
73 (variables %config-directory %localstatedir %state-directory
74 %store-database-directory %store-directory
75 %storedir %sysconfdir %system)))
77 (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
78 (package-name "GNU Guix")
80 (bug-report-address "bug-guix@gnu.org")
81 (home-page-url "https://gnu.org/s/guix"))
83 ;; Hack so that Geiser is not confused.
84 (define defmod 'define-module)
86 (scheme-file "config.scm"
88 (#$defmod (guix config)
89 #:export (%guix-package-name
91 %guix-bug-report-address
100 ;; XXX: Work around <http://bugs.gnu.org/15602>.
101 (eval-when (expand load eval)
102 #$@(map (match-lambda
104 #~(define-public #$name #$value)))
107 (define %guix-package-name #$package-name)
108 (define %guix-version #$package-version)
109 (define %guix-bug-report-address #$bug-report-address)
110 (define %guix-home-page-url #$home-page-url)
113 #+(and gzip (file-append gzip "/bin/gzip")))
115 #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
117 #+(and xz (file-append xz "/bin/xz")))
121 (file-append libgcrypt "/lib/libgcrypt")))
124 (file-append zlib "/lib/libz")))
126 (define %nix-instantiate ;for (guix import snix)
127 "nix-instantiate")))))
133 ;;; This is our own variant of 'gexp->script' with an extra #:module-path
134 ;;; parameter, which was unavailable in (guix gexp) until commit
135 ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
138 (define (load-path-expression modules path)
139 "Return as a monadic value a gexp that sets '%load-path' and
140 '%load-compiled-path' to point to MODULES, a list of module names. MODULES
141 are searched for in PATH."
142 (mlet %store-monad ((modules (imported-modules modules
144 (compiled (compiled-modules modules
145 #:module-path path)))
146 (return (gexp (eval-when (expand load eval)
148 (cons (ungexp modules) %load-path))
149 (set! %load-compiled-path
150 (cons (ungexp compiled)
151 %load-compiled-path)))))))
153 (define* (gexp->script name exp
154 #:key (guile (default-guile))
155 (module-path %load-path))
156 "Return an executable script NAME that runs EXP using GUILE, with EXP's
157 imported modules in its search path."
158 (mlet %store-monad ((set-load-path
159 (load-path-expression (gexp-modules exp)
161 (gexp->derivation name
163 (call-with-output-file (ungexp output)
165 ;; Note: that makes a long shebang. When the store
166 ;; is /gnu/store, that fits within the 128-byte
167 ;; limit imposed by Linux, but that may go beyond
168 ;; when running tests.
170 "#!~a/bin/guile --no-auto-compile~%!#~%"
173 (write '(ungexp set-load-path) port)
174 (write '(ungexp exp) port)
175 (chmod port #o555))))
176 #:module-path module-path)))
179 (define (date-version-string)
180 "Return the current date and hour in UTC timezone, for use as a poor
181 person's version identifier."
182 ;; XXX: Replace with a Git commit id.
183 (date->string (current-date 0) "~Y~m~d.~H"))
185 (define* (build-program source version
186 #:optional (guile-version (effective-version))
187 #:key (pull-version 0))
188 "Return a program that computes the derivation to build Guix from SOURCE."
190 ;; Select every module but (guix config) and non-Guix modules.
197 (with-imported-modules `(((guix config)
200 (specification->package "libgcrypt")))
201 ,@(source-module-closure `((guix store)
204 (gnu packages bootstrap))
207 (gexp->script "compute-guix-derivation"
209 (use-modules (ice-9 match))
211 (eval-when (expand load eval)
212 ;; Don't augment '%load-path'.
213 (unsetenv "GUIX_PACKAGE_PATH")
215 ;; (gnu packages …) modules are going to be looked up
216 ;; under SOURCE. (guix config) is looked up in FRONT.
221 (set! %load-path (list #$source front))))
223 ;; Only load our own modules or those of Guile.
224 (match %load-compiled-path
225 ((front _ ... sys1 sys2)
226 (set! %load-compiled-path
227 (list front sys1 sys2)))))
229 (use-modules (guix store)
234 (define (spin system)
236 (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
238 (format (current-error-port)
239 "Computing Guix derivation for '~a'... "
241 (let loop ((spin spin))
242 (display (string-append "\b" (car spin))
243 (current-error-port))
244 (force-output (current-error-port))
248 (match (command-line)
251 (call-with-new-thread
257 (run-with-store store
258 (guix-derivation #$source #$version
263 derivation-file-name))))))
264 #:module-path (list source))))
266 ;; The procedure below is our return value.
267 (define* (build source
268 #:key verbose? (version (date-version-string)) system
269 (guile-version (match ((@ (guile) version))
271 (_ (effective-version))))
275 "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
277 ;; Build the build program and then use it as a trampoline to build from
279 (mlet %store-monad ((build (build-program source version guile-version
280 #:pull-version pull-version))
281 (system (if system (return system) (current-system))))
283 (show-what-to-build* (list build))
284 (built-derivations (list build))
286 (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
287 (open-pipe* OPEN_READ
288 (derivation->output-path build)
290 (str (get-string-all pipe))
291 (status (close-pipe pipe)))
294 (error "build program failed" (list build status)))
295 ((? derivation-path? drv)
297 (return (newline (current-output-port)))
298 ((store-lift add-temp-root) drv)
299 (return (read-derivation-from-file drv))))
301 ;; Unsupported PULL-VERSION.
304 (error "invalid build result" (list build str))))))))
306 ;; This file is loaded by 'guix pull'; return it the build procedure.
310 ;; eval: (put 'with-load-path 'scheme-indent-function 1)
313 ;;; build-self.scm ends here