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))
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 %localstatedir %storedir %sysconfdir %system)))
75 (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
76 (package-name "GNU Guix")
78 (bug-report-address "bug-guix@gnu.org")
79 (home-page-url "https://gnu.org/s/guix"))
81 ;; Hack so that Geiser is not confused.
82 (define defmod 'define-module)
84 (scheme-file "config.scm"
86 (#$defmod (guix config)
87 #:export (%guix-package-name
89 %guix-bug-report-address
93 %store-database-directory
101 ;; XXX: Work around <http://bugs.gnu.org/15602>.
102 (eval-when (expand load eval)
103 #$@(map (match-lambda
105 #~(define-public #$name #$value)))
108 (define %store-directory
109 (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
112 (define %state-directory
113 ;; This must match `NIX_STATE_DIR' as defined in
115 (or (getenv "NIX_STATE_DIR")
116 (string-append %localstatedir "/guix")))
118 (define %store-database-directory
119 (or (getenv "NIX_DB_DIR")
120 (string-append %state-directory "/db")))
122 (define %config-directory
123 ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
124 ;; defined in `nix/local.mk'.
125 (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
126 (string-append %sysconfdir "/guix")))
128 (define %guix-package-name #$package-name)
129 (define %guix-version #$package-version)
130 (define %guix-bug-report-address #$bug-report-address)
131 (define %guix-home-page-url #$home-page-url)
134 #+(and gzip (file-append gzip "/bin/gzip")))
136 #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
138 #+(and xz (file-append xz "/bin/xz")))
142 (file-append libgcrypt "/lib/libgcrypt")))
145 (file-append zlib "/lib/libz")))))))
151 ;;; This is our own variant of 'gexp->script' with an extra #:module-path
152 ;;; parameter, which was unavailable in (guix gexp) until commit
153 ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
156 (define (load-path-expression modules path)
157 "Return as a monadic value a gexp that sets '%load-path' and
158 '%load-compiled-path' to point to MODULES, a list of module names. MODULES
159 are searched for in PATH."
160 (mlet %store-monad ((modules (imported-modules modules
162 (compiled (compiled-modules modules
163 #:module-path path)))
164 (return (gexp (eval-when (expand load eval)
166 (cons (ungexp modules) %load-path))
167 (set! %load-compiled-path
168 (cons (ungexp compiled)
169 %load-compiled-path)))))))
171 (define* (gexp->script name exp
172 #:key (guile (default-guile))
173 (module-path %load-path))
174 "Return an executable script NAME that runs EXP using GUILE, with EXP's
175 imported modules in its search path."
176 (mlet %store-monad ((set-load-path
177 (load-path-expression (gexp-modules exp)
179 (gexp->derivation name
181 (call-with-output-file (ungexp output)
183 ;; Note: that makes a long shebang. When the store
184 ;; is /gnu/store, that fits within the 128-byte
185 ;; limit imposed by Linux, but that may go beyond
186 ;; when running tests.
188 "#!~a/bin/guile --no-auto-compile~%!#~%"
191 (write '(ungexp set-load-path) port)
192 (write '(ungexp exp) port)
193 (chmod port #o555))))
194 #:module-path module-path)))
197 (define (date-version-string)
198 "Return the current date and hour in UTC timezone, for use as a poor
199 person's version identifier."
200 ;; XXX: Replace with a Git commit id.
201 (date->string (current-date 0) "~Y~m~d.~H"))
203 (define* (build-program source version
204 #:optional (guile-version (effective-version))
205 #:key (pull-version 0))
206 "Return a program that computes the derivation to build Guix from SOURCE."
208 ;; Select every module but (guix config) and non-Guix modules.
215 (with-imported-modules `(((guix config)
218 (specification->package "libgcrypt")))
219 ,@(source-module-closure `((guix store)
222 (gnu packages bootstrap))
225 (gexp->script "compute-guix-derivation"
227 (use-modules (ice-9 match))
229 (eval-when (expand load eval)
230 ;; Don't augment '%load-path'.
231 (unsetenv "GUIX_PACKAGE_PATH")
233 ;; (gnu packages …) modules are going to be looked up
234 ;; under SOURCE. (guix config) is looked up in FRONT.
235 (match (command-line)
239 (unless (string=? front source) ;already done?
240 (set! %load-path (list source front)))))))
242 ;; Only load our own modules or those of Guile.
243 (match %load-compiled-path
244 ((front _ ... sys1 sys2)
245 (set! %load-compiled-path
246 (list front sys1 sys2)))))
248 (use-modules (guix store)
253 (define (spin system)
255 (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
257 (format (current-error-port)
258 "Computing Guix derivation for '~a'... "
260 (let loop ((spin spin))
261 (display (string-append "\b" (car spin))
262 (current-error-port))
263 (force-output (current-error-port))
267 (match (command-line)
268 ((_ source system version)
270 (call-with-new-thread
276 (run-with-store store
277 (guix-derivation source version
282 derivation-file-name))))))
283 #:module-path (list source))))
285 ;; The procedure below is our return value.
286 (define* (build source
287 #:key verbose? (version (date-version-string)) system
288 (guile-version (match ((@ (guile) version))
290 (_ (effective-version))))
294 "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
296 ;; Build the build program and then use it as a trampoline to build from
298 (mlet %store-monad ((build (build-program source version guile-version
299 #:pull-version pull-version))
300 (system (if system (return system) (current-system))))
302 (show-what-to-build* (list build))
303 (built-derivations (list build))
305 (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
306 (open-pipe* OPEN_READ
307 (derivation->output-path build)
308 source system version)))
309 (str (get-string-all pipe))
310 (status (close-pipe pipe)))
313 (error "build program failed" (list build status)))
314 ((? derivation-path? drv)
316 (return (newline (current-output-port)))
317 ((store-lift add-temp-root) drv)
318 (return (read-derivation-from-file drv))))
320 ;; Unsupported PULL-VERSION.
323 (error "invalid build result" (list build str))))))))
325 ;; This file is loaded by 'guix pull'; return it the build procedure.
329 ;; eval: (put 'with-load-path 'scheme-indent-function 1)
332 ;;; build-self.scm ends here