projects/guix·blob master · refs

352 lines · 15.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014, 2016-2021, 2025 Ludovic Courtès <[email protected]>
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;;; Commentary:
20;;;
21;;; When loaded, this module returns a monadic procedure of at least one
22;;; argument: the source tree to build. It returns a derivation that
23;;; builds it.
24;;;
25;;; This file uses modules provided by the already-installed Guix. Those
26;;; modules may be arbitrarily old compared to the version we want to
27;;; build. Because of that, it must rely on the smallest set of features
28;;; that are likely to be provided by the (guix) and (gnu) modules, and by
29;;; Guile itself, forever and ever.
30;;;
31;;; Code:
32
33(define-module (build-self)
34 #:use-module (gnu)
35 #:use-module (guix)
36 #:use-module (guix ui)
37 #:use-module (guix config)
38 #:use-module (guix modules)
39 #:use-module ((guix self) #:select (make-config.scm))
40 #:use-module (srfi srfi-1)
41 #:use-module (srfi srfi-19)
42 #:use-module (srfi srfi-34)
43 #:use-module (srfi srfi-35)
44 #:use-module (rnrs io ports)
45 #:use-module (ice-9 match)
46 #:use-module (ice-9 popen)
47 #:export (build))
48
49(define (date-version-string)
50 "Return the current date and hour in UTC timezone, for use as a poor
51person's version identifier."
52 ;; XXX: Replace with a Git commit id.
53 (date->string (current-date 0) "~Y~m~d.~H"))
54
55(define guile-gcrypt
56 ;; The 'guile-gcrypt' package from the host Guix.
57 (match (find-best-packages-by-name "guile-gcrypt" #f)
58 ((package . _)
59 package)))
60
61(define* (build-program source version
62 #:optional (guile-version (effective-version))
63 #:key (pull-version 0) (channel-metadata #f)
64 built-in-builders)
65 "Return a program that computes the derivation to build Guix from SOURCE.
66If BUILT-IN-BUILDERS is provided, it should be a list of
67strings and this will be used instead of the builtin builders provided by the
68build daemon, from within the generated build program."
69 (define select?
70 ;; Select every module but (guix config) and non-Guix modules.
71 ;; Also exclude (guix channels): it is autoloaded by (guix describe), but
72 ;; only for peripheral functionality.
73 (match-lambda
74 (('guix 'config) #f)
75 (('guix 'channels) #f)
76 (('guix 'build 'download) #f) ;autoloaded by (guix download)
77 (('guix _ ...) #t)
78 (('gnu _ ...) #t)
79 (_ #f)))
80
81 (define fake-gcrypt-hash
82 ;; Fake (gcrypt hash) module; see below.
83 (scheme-file "hash.scm"
84 #~(define-module (gcrypt hash)
85 #:export (sha1 sha256))))
86
87 (define fake-git
88 (scheme-file "git.scm" #~(define-module (git))))
89
90 (with-imported-modules `(((guix config)
91 => ,(make-config.scm))
92
93 ;; To avoid relying on 'with-extensions', which was
94 ;; introduced in 0.15.0, provide a fake (gcrypt
95 ;; hash) just so that we can build modules, and
96 ;; adjust %LOAD-PATH later on.
97 ((gcrypt hash) => ,fake-gcrypt-hash)
98
99 ;; (guix git-download) depends on (git) but only
100 ;; for peripheral functionality. Provide a dummy
101 ;; (git) to placate it.
102 ((git) => ,fake-git)
103
104 ,@(source-module-closure `((guix store)
105 (guix self)
106 (guix derivations)
107 (gnu packages bootstrap))
108 (list source)
109 #:select? select?))
110 (gexp->script "compute-guix-derivation"
111 #~(begin
112 (use-modules (ice-9 match))
113
114 ;; To avoid lots of readlink calls
115 (fluid-set! %file-port-name-canonicalization #f)
116
117 (eval-when (expand load eval)
118 ;; (gnu packages …) modules are going to be looked up
119 ;; under SOURCE. (guix config) is looked up in FRONT.
120 (match (command-line)
121 ((_ source _ ...)
122 (match %load-path
123 ((front _ ...)
124 (unless (string=? front source) ;already done?
125 (set! %load-path
126 (list source
127 (string-append #$guile-gcrypt
128 "/share/guile/site/"
129 (effective-version))
130 front)))))))
131
132 ;; Only load Guile-Gcrypt, our own modules, or those
133 ;; of Guile.
134 (set! %load-compiled-path
135 (cons (string-append #$guile-gcrypt "/lib/guile/"
136 (effective-version)
137 "/site-ccache")
138 %load-compiled-path))
139
140 ;; Disable position recording to save time and space
141 ;; when loading the package modules.
142 (read-disable 'positions))
143
144 (use-modules (guix store)
145 (guix self)
146 (guix derivations)
147 (srfi srfi-1))
148
149 (match (command-line)
150 ((_ source system version protocol-version
151 build-output)
152 ;; The current input port normally wraps a file
153 ;; descriptor connected to the daemon, or it is
154 ;; connected to /dev/null. In the former case, reuse
155 ;; the connection such that we inherit build options
156 ;; such as substitute URLs and so on; in the latter
157 ;; case, attempt to open a new connection.
158 (let* ((proto (string->number protocol-version))
159 (store (if (integer? proto)
160 (port->connection
161 (duplicate-port
162 (current-input-port)
163 "w+0")
164 #:version proto
165 #:built-in-builders
166 '#$built-in-builders)
167 (open-connection
168 #:built-in-builders
169 '#$built-in-builders)))
170 (sock (socket AF_UNIX SOCK_STREAM 0)))
171 ;; Connect to BUILD-OUTPUT and send it the raw
172 ;; build output.
173 (connect sock AF_UNIX build-output)
174
175 (when (integer? proto)
176 ;; port->connection doesn't setup buffering, so
177 ;; do this here
178 (setvbuf (store-connection-socket store)
179 'block
180 %default-store-connection-buffer-size))
181
182 (display
183 (and=>
184 ;; Silence autoload warnings and the likes.
185 (parameterize ((current-warning-port
186 (%make-void-port "w"))
187 (current-build-output-port sock))
188 (run-with-store store
189 (guix-derivation source version
190 #$guile-version
191 #:channel-metadata
192 '#$channel-metadata
193 #:pull-version
194 #$pull-version)
195 #:system system))
196 derivation-file-name))))))
197 #:module-path (list source))))
198
199(define (proxy input output)
200 "Dump the contents of INPUT to OUTPUT until EOF is reached on INPUT.
201Display a spinner when nothing happens."
202 (define spin
203 (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
204
205 (setvbuf input 'block 16384)
206 (let loop ((spin spin))
207 (match (select (list input) '() '() 1)
208 ((() () ())
209 (when (isatty? (current-error-port))
210 (display (string-append "\b" (car spin))
211 (current-error-port))
212 (force-output (current-error-port)))
213 (loop (cdr spin)))
214 (((_) () ())
215 ;; Read from INPUT as much as can be read without blocking.
216 (let ((bv (get-bytevector-some input)))
217 (unless (eof-object? bv)
218 (put-bytevector output bv)
219 (loop spin)))))))
220
221(define (call-with-clean-environment thunk)
222 (let ((env (environ)))
223 (dynamic-wind
224 (lambda ()
225 (environ '()))
226 thunk
227 (lambda ()
228 (environ env)))))
229
230(define-syntax-rule (with-clean-environment exp ...)
231 "Evaluate EXP in a context where zero environment variables are defined."
232 (call-with-clean-environment (lambda () exp ...)))
233
234;; The procedure below is our return value.
235(define* (build source
236 #:key verbose?
237 (version (date-version-string)) channel-metadata
238 system
239 (pull-version 0)
240
241 ;; For the standalone Guix, default to Guile 3.0. For old
242 ;; versions of 'guix pull' (pre-0.15.0), we have to use the
243 ;; same Guile as the current one.
244 (guile-version (if (> pull-version 0)
245 "3.0"
246 (effective-version)))
247 built-in-builders
248 #:allow-other-keys
249 #:rest rest)
250 "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
251files."
252 ;; Avoid lots of readlink calls
253 (fluid-set! %file-port-name-canonicalization #f)
254
255 ;; Build the build program and then use it as a trampoline to build from
256 ;; SOURCE.
257 (mlet %store-monad ((build (build-program source version guile-version
258 #:channel-metadata channel-metadata
259 #:pull-version pull-version
260 #:built-in-builders
261 built-in-builders))
262 (system (if system (return system) (current-system)))
263 (home -> (getenv "HOME"))
264
265 ;; Note: Use the deprecated names here because the
266 ;; caller might be Guix <= 0.16.0.
267 (port ((store-lift nix-server-socket)))
268 (major ((store-lift nix-server-major-version)))
269 (minor ((store-lift nix-server-minor-version))))
270 (mbegin %store-monad
271 ;; Before 'with-build-handler' was implemented and used, we had to
272 ;; explicitly call 'show-what-to-build*'.
273 (munless (module-defined? (resolve-module '(guix store))
274 'with-build-handler)
275 (show-what-to-build* (list build)))
276 (built-derivations (list build))
277
278 ;; Use the port beneath the current store as the stdin of BUILD. This
279 ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is
280 ;; not a file port (e.g., it's an SSH channel), then the subprocess's
281 ;; stdin will actually be /dev/null.
282 (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
283 (node (let ((file (string-append (or (getenv "TMPDIR") "/tmp")
284 "/guix-build-output-"
285 (number->string (getpid)))))
286 (bind sock AF_UNIX file)
287 (listen sock 1)
288 file))
289 (pipe (with-input-from-port port
290 (lambda ()
291 ;; Make sure BUILD is not influenced by
292 ;; $GUILE_LOAD_PATH & co.
293 (with-clean-environment
294 (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
295 (setenv "COLUMNS" "120") ;show wider backtraces
296 (when home
297 ;; Inherit HOME so that 'xdg-directory' works.
298 (setenv "HOME" home))
299 (open-pipe* OPEN_READ
300 (derivation->output-path build)
301 source system version
302 (if (file-port? port)
303 (number->string
304 (logior major minor))
305 "none")
306 node))))))
307 (format (current-error-port) "Computing Guix derivation for '~a'... "
308 system)
309
310 ;; Wait for a connection on SOCK and proxy build output so it can be
311 ;; processed according to the settings currently in effect (build
312 ;; traces, verbosity level, and so on).
313 (match (accept sock)
314 ((port . _)
315 (close-port sock)
316 (delete-file node)
317 (proxy port (current-build-output-port))))
318
319 ;; Now that the build output connection was closed, read the result, a
320 ;; derivation file name, from PIPE.
321 (let ((str (get-string-all pipe))
322 (status (close-pipe pipe)))
323 (match str
324 ((? eof-object?)
325 (error "build program failed" (list build status)))
326 ((? derivation-path? drv)
327 (mbegin %store-monad
328 (return (newline (current-error-port)))
329 ((store-lift add-temp-root) drv)
330 (return (read-derivation-from-file drv))))
331 ("#f"
332 ;; Unsupported PULL-VERSION.
333 (return #f))
334 ((? string? str)
335 (raise (condition
336 (&message
337 (message (format #f "You found a bug: the program '~a'
338failed to compute the derivation for Guix (version: ~s; system: ~s;
339host version: ~s; pull-version: ~s).
340Please report the COMPLETE output above to <~a>.~%"
341 (derivation->output-path build)
342 version system %guix-version pull-version
343 %guix-bug-report-address))))))))))))
344
345;; This file is loaded by 'guix pull'; return it the build procedure.
346build
347
348;; Local Variables:
349;; eval: (put 'with-load-path 'scheme-indent-function 1)
350;; End:
351
352;;; build-self.scm ends here