Commit | Line | Data |
---|---|---|
dc0f74e5 | 1 | ;;; GNU Guix --- Functional package management for GNU |
f7008ca7 | 2 | ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
743497b5 | 3 | ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> |
dc0f74e5 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix status) | |
21 | #:use-module (guix records) | |
22 | #:use-module (guix i18n) | |
5d9f9ad6 | 23 | #:use-module (guix colors) |
dc0f74e5 LC |
24 | #:use-module (guix progress) |
25 | #:autoload (guix build syscalls) (terminal-columns) | |
f7008ca7 | 26 | #:autoload (guix build download) (nar-uri-abbreviation) |
fb94d82b | 27 | #:use-module (guix store) |
dc0f74e5 | 28 | #:use-module (guix derivations) |
0c1bc5ec | 29 | #:use-module (guix memoization) |
dc0f74e5 LC |
30 | #:use-module (srfi srfi-1) |
31 | #:use-module (srfi srfi-9) | |
c7465dcb | 32 | #:use-module (srfi srfi-9 gnu) |
dc0f74e5 LC |
33 | #:use-module (srfi srfi-19) |
34 | #:use-module (srfi srfi-26) | |
35 | #:use-module (ice-9 regex) | |
36 | #:use-module (ice-9 match) | |
37 | #:use-module (ice-9 format) | |
38 | #:use-module (ice-9 binary-ports) | |
fe17037b | 39 | #:autoload (ice-9 rdelim) (read-string) |
dc0f74e5 LC |
40 | #:use-module (rnrs bytevectors) |
41 | #:use-module ((system foreign) | |
42 | #:select (bytevector->pointer pointer->bytevector)) | |
43 | #:export (build-event-output-port | |
44 | compute-status | |
45 | ||
46 | build-status | |
47 | build-status? | |
48 | build-status-building | |
49 | build-status-downloading | |
50 | build-status-builds-completed | |
51 | build-status-downloads-completed | |
52 | ||
976ef2d9 LC |
53 | build? |
54 | build | |
55 | build-derivation | |
56 | build-system | |
ba514b60 LC |
57 | build-log-file |
58 | build-phase | |
59 | build-completion | |
976ef2d9 | 60 | |
dc0f74e5 LC |
61 | download? |
62 | download | |
63 | download-item | |
64 | download-uri | |
65 | download-size | |
66 | download-start | |
67 | download-end | |
68 | download-transferred | |
69 | ||
70 | build-status-updater | |
71 | print-build-event | |
72 | print-build-event/quiet | |
73 | print-build-status | |
74 | ||
7804c45b LC |
75 | with-status-report |
76 | with-status-verbosity)) | |
dc0f74e5 LC |
77 | |
78 | ;;; Commentary: | |
79 | ;;; | |
80 | ;;; This module provides facilities to track the status of ongoing builds and | |
81 | ;;; downloads in a given session, as well as tools to report about the current | |
82 | ;;; status to user interfaces. It does so by analyzing the output of | |
83 | ;;; 'current-build-output-port'. The build status is maintained in a | |
84 | ;;; <build-status> record. | |
85 | ;;; | |
86 | ;;; Code: | |
87 | ||
88 | \f | |
89 | ;;; | |
90 | ;;; Build status tracking. | |
91 | ;;; | |
92 | ||
93 | ;; Builds and substitutions performed by the daemon. | |
94 | (define-record-type* <build-status> build-status make-build-status | |
95 | build-status? | |
976ef2d9 | 96 | (building build-status-building ;list of <build> |
dc0f74e5 LC |
97 | (default '())) |
98 | (downloading build-status-downloading ;list of <download> | |
99 | (default '())) | |
976ef2d9 | 100 | (builds-completed build-status-builds-completed ;list of <build> |
dc0f74e5 | 101 | (default '())) |
976ef2d9 | 102 | (downloads-completed build-status-downloads-completed ;list of <download> |
dc0f74e5 LC |
103 | (default '()))) |
104 | ||
976ef2d9 | 105 | ;; On-going or completed build. |
c7465dcb | 106 | (define-immutable-record-type <build> |
ba514b60 | 107 | (%build derivation id system log-file phase completion) |
976ef2d9 LC |
108 | build? |
109 | (derivation build-derivation) ;string (.drv file name) | |
110 | (id build-id) ;#f | integer | |
111 | (system build-system) ;string | |
73a8681a | 112 | (log-file build-log-file) ;#f | string |
ba514b60 LC |
113 | (phase build-phase ;#f | symbol |
114 | set-build-phase) | |
c7465dcb LC |
115 | (completion build-completion ;#f | integer (percentage) |
116 | set-build-completion)) | |
976ef2d9 | 117 | |
ba514b60 | 118 | (define* (build derivation system #:key id log-file phase completion) |
976ef2d9 | 119 | "Return a new build." |
ba514b60 | 120 | (%build derivation id system log-file phase completion)) |
976ef2d9 | 121 | |
dc0f74e5 LC |
122 | ;; On-going or completed downloads. Downloads can be stem from substitutes |
123 | ;; and from "builtin:download" fixed-output derivations. | |
124 | (define-record-type <download> | |
125 | (%download item uri size start end transferred) | |
126 | download? | |
127 | (item download-item) ;store item | |
128 | (uri download-uri) ;string | #f | |
129 | (size download-size) ;integer | #f | |
130 | (start download-start) ;<time> | |
131 | (end download-end) ;#f | <time> | |
132 | (transferred download-transferred)) ;integer | |
133 | ||
134 | (define* (download item uri | |
135 | #:key size | |
136 | (start (current-time time-monotonic)) end | |
137 | (transferred 0)) | |
138 | "Return a new download." | |
139 | (%download item uri size start end transferred)) | |
140 | ||
976ef2d9 LC |
141 | (define (matching-build drv) |
142 | "Return a predicate that matches builds of DRV." | |
143 | (lambda (build) | |
144 | (string=? drv (build-derivation build)))) | |
145 | ||
dc0f74e5 LC |
146 | (define (matching-download item) |
147 | "Return a predicate that matches downloads of ITEM." | |
148 | (lambda (download) | |
149 | (string=? item (download-item download)))) | |
150 | ||
ba514b60 LC |
151 | (define %phase-start-rx |
152 | ;; Match the "starting phase" message emitted by 'gnu-build-system'. | |
153 | (make-regexp "^starting phase [`']([^']+)'")) | |
154 | ||
73a8681a LC |
155 | (define %percentage-line-rx |
156 | ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp | |
157 | ;; matches them. | |
158 | (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]")) | |
159 | ||
160 | (define %fraction-line-rx | |
161 | ;; The 'compiled-modules' derivations and Ninja produce reports like | |
162 | ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]". | |
163 | ;; This regexp matches these. | |
164 | (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]")) | |
165 | ||
166 | (define (update-build status id line) | |
167 | "Update STATUS based on LINE, a build output line for ID that might contain | |
168 | a completion indication." | |
73a8681a LC |
169 | (define (find-build) |
170 | (find (lambda (build) | |
171 | (and (build-id build) | |
172 | (= (build-id build) id))) | |
173 | (build-status-building status))) | |
174 | ||
175 | (define (update %) | |
176 | (let ((build (find-build))) | |
177 | (build-status | |
178 | (inherit status) | |
c7465dcb | 179 | (building (cons (set-build-completion build %) |
73a8681a LC |
180 | (delq build (build-status-building status))))))) |
181 | ||
182 | (cond ((string-any #\nul line) | |
183 | ;; Don't try to match a regexp here. | |
184 | status) | |
185 | ((regexp-exec %percentage-line-rx line) | |
186 | => | |
187 | (lambda (match) | |
188 | (let ((% (string->number (match:substring match 1)))) | |
189 | (update %)))) | |
190 | ((regexp-exec %fraction-line-rx line) | |
191 | => | |
192 | (lambda (match) | |
193 | (let ((done (string->number (match:substring match 1))) | |
194 | (total (string->number (match:substring match 3)))) | |
195 | (update (* 100. (/ done total)))))) | |
ba514b60 LC |
196 | ((regexp-exec %phase-start-rx line) |
197 | => | |
198 | (lambda (match) | |
199 | (let ((phase (match:substring match 1)) | |
200 | (build (find-build))) | |
201 | (if build | |
202 | (build-status | |
203 | (inherit status) | |
204 | (building | |
205 | (cons (set-build-phase (set-build-completion build #f) | |
206 | (string->symbol phase)) | |
207 | (delq build (build-status-building status))))) | |
208 | status)))) | |
73a8681a LC |
209 | (else |
210 | status))) | |
211 | ||
dc0f74e5 | 212 | (define* (compute-status event status |
f9a8fce1 LC |
213 | #:key |
214 | (current-time current-time) | |
215 | (derivation-path->output-path | |
216 | derivation-path->output-path)) | |
dc0f74e5 LC |
217 | "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), |
218 | compute a new status based on STATUS." | |
219 | (match event | |
976ef2d9 LC |
220 | (('build-started drv "-" system log-file . rest) |
221 | (let ((build (build drv system | |
222 | #:id (match rest | |
223 | ((pid . _) (string->number pid)) | |
224 | (_ #f)) | |
225 | #:log-file (if (string-null? log-file) | |
226 | #f | |
227 | log-file)))) | |
228 | (build-status | |
229 | (inherit status) | |
230 | (building (cons build (build-status-building status)))))) | |
dc0f74e5 | 231 | (((or 'build-succeeded 'build-failed) drv _ ...) |
976ef2d9 LC |
232 | (let ((build (find (matching-build drv) |
233 | (build-status-building status)))) | |
234 | ;; If BUILD is #f, this may be because DRV corresponds to a | |
235 | ;; fixed-output derivation that is listed as a download. | |
236 | (if build | |
237 | (build-status | |
238 | (inherit status) | |
239 | (building (delq build (build-status-building status))) | |
240 | (builds-completed | |
241 | (cons build (build-status-builds-completed status)))) | |
242 | status))) | |
dc0f74e5 LC |
243 | |
244 | ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because | |
245 | ;; they're not as informative as 'download-started' and | |
246 | ;; 'download-succeeded'. | |
247 | ||
248 | (('download-started item uri (= string->number size)) | |
249 | ;; This is presumably a fixed-output derivation so move it from | |
250 | ;; 'building' to 'downloading'. XXX: This doesn't work in 'check' mode | |
251 | ;; because ITEM is different from DRV's output. | |
252 | (build-status | |
253 | (inherit status) | |
976ef2d9 LC |
254 | (building (remove (lambda (build) |
255 | (let ((drv (build-derivation build))) | |
256 | (equal? (false-if-exception | |
257 | (derivation-path->output-path drv)) | |
258 | item))) | |
dc0f74e5 LC |
259 | (build-status-building status))) |
260 | (downloading (cons (download item uri #:size size | |
261 | #:start (current-time time-monotonic)) | |
262 | (build-status-downloading status))))) | |
263 | (('download-succeeded item uri (= string->number size)) | |
264 | (let ((current (find (matching-download item) | |
265 | (build-status-downloading status)))) | |
266 | (build-status | |
267 | (inherit status) | |
268 | (downloading (delq current (build-status-downloading status))) | |
269 | (downloads-completed | |
270 | (cons (download item uri | |
271 | #:size size | |
272 | #:start (download-start current) | |
273 | #:transferred size | |
274 | #:end (current-time time-monotonic)) | |
275 | (build-status-downloads-completed status)))))) | |
276 | (('substituter-succeeded item _ ...) | |
277 | (match (find (matching-download item) | |
278 | (build-status-downloading status)) | |
279 | (#f | |
280 | ;; Presumably we already got a 'download-succeeded' event for ITEM, | |
281 | ;; everything is fine. | |
282 | status) | |
283 | (current | |
284 | ;; Maybe the build process didn't emit a 'download-succeeded' event | |
285 | ;; for ITEM, so remove CURRENT from the queue now. | |
286 | (build-status | |
287 | (inherit status) | |
288 | (downloading (delq current (build-status-downloading status))) | |
289 | (downloads-completed | |
290 | (cons (download item (download-uri current) | |
291 | #:size (download-size current) | |
292 | #:start (download-start current) | |
293 | #:transferred (download-size current) | |
294 | #:end (current-time time-monotonic)) | |
295 | (build-status-downloads-completed status))))))) | |
296 | (('download-progress item uri | |
297 | (= string->number size) | |
298 | (= string->number transferred)) | |
299 | (let ((downloads (remove (matching-download item) | |
300 | (build-status-downloading status))) | |
301 | (current (find (matching-download item) | |
302 | (build-status-downloading status)))) | |
303 | (build-status | |
304 | (inherit status) | |
305 | (downloading (cons (download item uri | |
306 | #:size size | |
307 | #:start | |
308 | (or (and current | |
309 | (download-start current)) | |
310 | (current-time time-monotonic)) | |
311 | #:transferred transferred) | |
312 | downloads))))) | |
73a8681a LC |
313 | (('build-log (? integer? pid) line) |
314 | (update-build status pid line)) | |
dc0f74e5 LC |
315 | (_ |
316 | status))) | |
317 | ||
318 | (define (simultaneous-jobs status) | |
319 | "Return the number of on-going builds and downloads for STATUS." | |
320 | (+ (length (build-status-building status)) | |
321 | (length (build-status-downloading status)))) | |
322 | ||
323 | \f | |
324 | ;;; | |
325 | ;;; Rendering. | |
326 | ;;; | |
327 | ||
328 | (define (extended-build-trace-supported?) | |
329 | "Return true if the currently used store is known to support \"extended | |
330 | build traces\" such as \"@ download-progress\" traces." | |
331 | ;; Support for extended build traces was added in protocol version #x162. | |
332 | (and (current-store-protocol-version) | |
333 | (>= (current-store-protocol-version) #x162))) | |
334 | ||
f9a8fce1 LC |
335 | (define (multiplexed-output-supported?) |
336 | "Return true if the daemon supports \"multiplexed output\"--i.e., \"@ | |
337 | build-log\" traces." | |
338 | (and (current-store-protocol-version) | |
339 | (>= (current-store-protocol-version) #x163))) | |
340 | ||
dc0f74e5 LC |
341 | (define spin! |
342 | (let ((steps (circular-list "\\" "|" "/" "-"))) | |
596fb4ba LC |
343 | (lambda (phase port) |
344 | "Display a spinner on PORT. If PHASE is true, display it as a hint of | |
345 | the current build phase." | |
0c1bc5ec LC |
346 | (when (isatty?* port) |
347 | (match steps | |
348 | ((first . rest) | |
349 | (set! steps rest) | |
350 | (display "\r\x1b[K" port) | |
351 | (display first port) | |
596fb4ba LC |
352 | (when phase |
353 | (display " " port) | |
354 | ;; TRANSLATORS: The word "phase" here denotes a "build phase"; | |
355 | ;; "~a" is a placeholder for the untranslated name of the current | |
356 | ;; build phase--e.g., 'configure' or 'build'. | |
357 | (format port (G_ "'~a' phase") phase)) | |
0c1bc5ec | 358 | (force-output port))))))) |
dc0f74e5 | 359 | |
dc0f74e5 LC |
360 | (define colorize-log-line |
361 | ;; Take a string and return a possibly colorized string according to the | |
362 | ;; rules below. | |
363 | (color-rules | |
364 | ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)" | |
365 | GREEN BOLD GREEN RESET GREEN BLUE) | |
366 | ("^(phase)(.*)(failed after)(.*)(seconds)(.*)" | |
367 | RED BLUE RED BLUE RED BLUE) | |
1dc876a3 | 368 | ("^(.*)(error|fail|failed|\\<FAIL|FAILED)([[:blank:]]*)(:)(.*)" |
dc0f74e5 LC |
369 | RESET RED BOLD BOLD BOLD) |
370 | ("^(.*)(warning)([[:blank:]]*)(:)(.*)" | |
1dc876a3 | 371 | RESET MAGENTA BOLD BOLD BOLD))) |
dc0f74e5 | 372 | |
80eebee9 RW |
373 | (define (hook-message hook-type) |
374 | "Return a human-readable string for the profile hook type HOOK-TYPE." | |
375 | (match hook-type | |
376 | ('info-dir | |
377 | (G_ "building directory of Info manuals...")) | |
378 | ('ghc-package-cache | |
379 | (G_ "building GHC package cache...")) | |
380 | ('ca-certificate-bundle | |
381 | (G_ "building CA certificate bundle...")) | |
382 | ('glib-schemas | |
383 | (G_ "generating GLib schema cache...")) | |
384 | ('gtk-icon-themes | |
385 | (G_ "creating GTK+ icon theme cache...")) | |
386 | ('gtk-im-modules | |
387 | (G_ "building cache files for GTK+ input methods...")) | |
388 | ('xdg-desktop-database | |
389 | (G_ "building XDG desktop file cache...")) | |
390 | ('xdg-mime-database | |
391 | (G_ "building XDG MIME database...")) | |
392 | ('fonts-dir | |
393 | (G_ "building fonts directory...")) | |
743497b5 RW |
394 | ('texlive-configuration |
395 | (G_ "building TeX Live configuration...")) | |
80eebee9 RW |
396 | ('manual-database |
397 | (G_ "building database for manual pages...")) | |
b9da4b93 LC |
398 | ('package-cache ;package cache generated by 'guix pull' |
399 | (G_ "building package cache...")) | |
80eebee9 RW |
400 | (_ #f))) |
401 | ||
dc0f74e5 LC |
402 | (define* (print-build-event event old-status status |
403 | #:optional (port (current-error-port)) | |
404 | #:key | |
405 | (colorize? (color-output? port)) | |
e45ef9a6 | 406 | (print-urls? #t) |
dc0f74e5 LC |
407 | (print-log? #t)) |
408 | "Print information about EVENT and STATUS to PORT. When COLORIZE? is true, | |
409 | produce colorful output. When PRINT-LOG? is true, display the build log in | |
e45ef9a6 LC |
410 | addition to build events. When PRINT-URLS? is true, display the URL of |
411 | substitutes being downloaded." | |
dc0f74e5 LC |
412 | (define info |
413 | (if colorize? | |
2569ef9d | 414 | (cute colorize-string <> (color BOLD)) |
dc0f74e5 LC |
415 | identity)) |
416 | ||
417 | (define success | |
418 | (if colorize? | |
2569ef9d | 419 | (cute colorize-string <> (color GREEN BOLD)) |
dc0f74e5 LC |
420 | identity)) |
421 | ||
422 | (define failure | |
423 | (if colorize? | |
2569ef9d | 424 | (cute colorize-string <> (color RED BOLD)) |
dc0f74e5 LC |
425 | identity)) |
426 | ||
d613c177 LC |
427 | (define tty? |
428 | (isatty?* port)) | |
429 | ||
596fb4ba | 430 | (define (report-build-progress phase %) |
3854c642 LC |
431 | (let ((% (min (max % 0) 100))) ;sanitize |
432 | (erase-current-line port) | |
596fb4ba LC |
433 | (let* ((prefix (format #f "~3d% ~@['~a' ~]" |
434 | (inexact->exact (round %)) | |
435 | (case phase | |
436 | ((build) #f) ;not useful to display it | |
437 | (else phase)))) | |
438 | (length (string-length prefix))) | |
439 | (display prefix port) | |
440 | (display (progress-bar % (- (current-terminal-columns) length)) | |
441 | port)) | |
3854c642 LC |
442 | (force-output port))) |
443 | ||
dc0f74e5 LC |
444 | (define print-log-line |
445 | (if print-log? | |
446 | (if colorize? | |
3854c642 | 447 | (lambda (id line) |
dc0f74e5 | 448 | (display (colorize-log-line line) port)) |
3854c642 LC |
449 | (lambda (id line) |
450 | (display line port))) | |
451 | (lambda (id line) | |
452 | (match (build-status-building status) | |
453 | ((build) ;single job | |
454 | (match (build-completion build) | |
596fb4ba LC |
455 | ((? number? %) |
456 | (report-build-progress (build-phase build) %)) | |
457 | (_ | |
458 | (spin! (build-phase build) port)))) | |
3854c642 | 459 | (_ |
596fb4ba | 460 | (spin! #f port)))))) |
dc0f74e5 | 461 | |
7473bce2 | 462 | (define erase-current-line* |
024d5275 LC |
463 | (if (and (not print-log?) (isatty?* port)) |
464 | (lambda () | |
7473bce2 LC |
465 | (erase-current-line port) |
466 | (force-output port)) | |
467 | (const #t))) | |
468 | ||
dc0f74e5 LC |
469 | (match event |
470 | (('build-started drv . _) | |
5ea206a8 | 471 | (erase-current-line*) |
af1f1c38 LC |
472 | (let ((properties (derivation-properties |
473 | (read-derivation-from-file drv)))) | |
474 | (match (assq-ref properties 'type) | |
475 | ('graft | |
476 | (let ((count (match (assq-ref properties 'graft) | |
477 | (#f 0) | |
478 | (lst (or (assq-ref lst 'count) 0))))) | |
8fa4ac5b T |
479 | (format port (info (N_ "applying ~a graft for ~a ..." |
480 | "applying ~a grafts for ~a ..." | |
af1f1c38 LC |
481 | count)) |
482 | count drv))) | |
260eae78 LC |
483 | ('profile |
484 | (let ((count (match (assq-ref properties 'profile) | |
485 | (#f 0) | |
486 | (lst (or (assq-ref lst 'count) 0))))) | |
04594054 LC |
487 | (format port (info (N_ "building profile with ~a package..." |
488 | "building profile with ~a packages..." | |
260eae78 LC |
489 | count)) |
490 | count))) | |
80eebee9 RW |
491 | ('profile-hook |
492 | (let ((hook-type (assq-ref properties 'hook))) | |
493 | (or (and=> (hook-message hook-type) | |
494 | (lambda (msg) | |
495 | (format port (info msg)))) | |
496 | (format port (info (G_ "running profile hook of type '~a'...")) | |
497 | hook-type)))) | |
af1f1c38 LC |
498 | (_ |
499 | (format port (info (G_ "building ~a...")) drv)))) | |
dc0f74e5 LC |
500 | (newline port)) |
501 | (('build-succeeded drv . _) | |
024d5275 | 502 | (erase-current-line*) ;erase spinner or progress bar |
38a2f5ea LC |
503 | (when (or print-log? (not (extended-build-trace-supported?))) |
504 | (format port (success (G_ "successfully built ~a")) drv) | |
505 | (newline port)) | |
dc0f74e5 LC |
506 | (match (build-status-building status) |
507 | (() #t) | |
508 | (ongoing ;when max-jobs > 1 | |
509 | (format port | |
510 | (N_ "The following build is still in progress:~%~{ ~a~%~}~%" | |
511 | "The following builds are still in progress:~%~{ ~a~%~}~%" | |
512 | (length ongoing)) | |
976ef2d9 | 513 | (map build-derivation ongoing))))) |
dc0f74e5 | 514 | (('build-failed drv . _) |
024d5275 | 515 | (erase-current-line*) ;erase spinner or progress bar |
dc0f74e5 LC |
516 | (format port (failure (G_ "build of ~a failed")) drv) |
517 | (newline port) | |
fb94d82b LC |
518 | (match (derivation-log-file drv) |
519 | (#f | |
520 | (format port (failure (G_ "Could not find build log for '~a'.")) | |
521 | drv)) | |
522 | (log | |
523 | (format port (info (G_ "View build log at '~a'.")) log))) | |
524 | (newline port)) | |
dc0f74e5 | 525 | (('substituter-started item _ ...) |
5ea206a8 | 526 | (erase-current-line*) |
dc0f74e5 LC |
527 | (when (or print-log? (not (extended-build-trace-supported?))) |
528 | (format port (info (G_ "substituting ~a...")) item) | |
529 | (newline port))) | |
530 | (('download-started item uri _ ...) | |
e45ef9a6 LC |
531 | (when print-urls? |
532 | (erase-current-line*) | |
533 | (format port (info (G_ "downloading from ~a ...")) uri) | |
534 | (newline port))) | |
dc0f74e5 LC |
535 | (('download-progress item uri |
536 | (= string->number size) | |
537 | (= string->number transferred)) | |
538 | ;; Print a progress bar, but only if there's only one on-going | |
539 | ;; job--otherwise the output would be intermingled. | |
540 | (when (= 1 (simultaneous-jobs status)) | |
541 | (match (find (matching-download item) | |
542 | (build-status-downloading status)) | |
543 | (#f #f) ;shouldn't happen! | |
544 | (download | |
545 | ;; XXX: It would be nice to memoize the abbreviation. | |
546 | (let ((uri (if (string-contains uri "/nar/") | |
547 | (nar-uri-abbreviation uri) | |
548 | (basename uri)))) | |
549 | (display-download-progress uri size | |
d613c177 | 550 | #:tty? tty? |
dc0f74e5 LC |
551 | #:start-time |
552 | (download-start download) | |
553 | #:transferred transferred)))))) | |
554 | (('substituter-succeeded item _ ...) | |
555 | ;; If there are no jobs running, we already reported download completion | |
556 | ;; so there's nothing left to do. | |
557 | (unless (and (zero? (simultaneous-jobs status)) | |
558 | (extended-build-trace-supported?)) | |
559 | (format port (success (G_ "substitution of ~a complete")) item) | |
560 | (newline port))) | |
561 | (('substituter-failed item _ ...) | |
562 | (format port (failure (G_ "substitution of ~a failed")) item) | |
563 | (newline port)) | |
564 | (('hash-mismatch item algo expected actual _ ...) | |
565 | ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for | |
566 | ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. | |
567 | (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) | |
568 | (newline port) | |
569 | (format port (info (G_ "\ | |
570 | expected hash: ~a | |
571 | actual hash: ~a~%")) | |
572 | expected actual)) | |
694e638e LC |
573 | (('build-remote drv host _ ...) |
574 | (format port (info (G_ "offloading build of ~a to '~a'")) drv host) | |
575 | (newline port)) | |
f9a8fce1 LC |
576 | (('build-log pid line) |
577 | (if (multiplexed-output-supported?) | |
578 | (if (not pid) | |
579 | (begin | |
580 | ;; LINE comes from the daemon, not from builders. Let it | |
581 | ;; through. | |
582 | (display line port) | |
583 | (force-output port)) | |
3854c642 | 584 | (print-log-line pid line)) |
f9a8fce1 LC |
585 | (cond ((string-prefix? "substitute: " line) |
586 | ;; The daemon prefixes early messages coming with 'guix | |
587 | ;; substitute' with "substitute:". These are useful ("updating | |
588 | ;; substitutes from URL"), so let them through. | |
589 | (display line port) | |
590 | (force-output port)) | |
591 | ((string-prefix? "waiting for locks" line) | |
592 | ;; This is when a derivation is already being built and we're just | |
593 | ;; waiting for the build to complete. | |
594 | (display (info (string-trim-right line)) port) | |
595 | (newline)) | |
596 | (else | |
3854c642 | 597 | (print-log-line pid line))))) |
dc0f74e5 LC |
598 | (_ |
599 | event))) | |
600 | ||
601 | (define* (print-build-event/quiet event old-status status | |
602 | #:optional | |
603 | (port (current-error-port)) | |
604 | #:key | |
605 | (colorize? (color-output? port))) | |
606 | (print-build-event event old-status status port | |
607 | #:colorize? colorize? | |
e45ef9a6 LC |
608 | #:print-urls? #f |
609 | #:print-log? #f)) | |
610 | ||
611 | (define* (print-build-event/quiet-with-urls event old-status status | |
612 | #:optional | |
613 | (port (current-error-port)) | |
614 | #:key | |
615 | (colorize? (color-output? port))) | |
616 | (print-build-event event old-status status port | |
617 | #:colorize? colorize? | |
618 | #:print-urls? #t ;show download URLs | |
dc0f74e5 LC |
619 | #:print-log? #f)) |
620 | ||
621 | (define* (build-status-updater #:optional (on-change (const #t))) | |
622 | "Return a procedure that can be passed to 'build-event-output-port'. That | |
623 | procedure computes the new build status upon each event and calls ON-CHANGE: | |
624 | ||
625 | (ON-CHANGE event status new-status) | |
626 | ||
627 | ON-CHANGE can display the build status, build events, etc." | |
628 | (lambda (event status) | |
629 | (let ((new (compute-status event status))) | |
630 | (on-change event status new) | |
631 | new))) | |
632 | ||
633 | \f | |
634 | ;;; | |
635 | ;;; Build port. | |
636 | ;;; | |
637 | ||
fe17037b LC |
638 | (define (maybe-utf8->string bv) |
639 | "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the | |
640 | case where BV does not contain only valid UTF-8." | |
641 | (catch 'decoding-error | |
642 | (lambda () | |
643 | (utf8->string bv)) | |
644 | (lambda _ | |
645 | ;; This is the sledgehammer but it's the only safe way we have to | |
646 | ;; properly handle this. It's expensive but it's rarely needed. | |
647 | (let ((port (open-bytevector-input-port bv))) | |
648 | (set-port-encoding! port "UTF-8") | |
649 | (set-port-conversion-strategy! port 'substitute) | |
650 | (let ((str (read-string port))) | |
651 | (close-port port) | |
652 | str))))) | |
653 | ||
f9a8fce1 LC |
654 | (define (bytevector-index bv number offset count) |
655 | "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes; | |
656 | return the offset where NUMBER first occurs or #f if it could not be found." | |
657 | (let loop ((offset offset) | |
658 | (count count)) | |
659 | (cond ((zero? count) #f) | |
660 | ((= (bytevector-u8-ref bv offset) number) offset) | |
661 | (else (loop (+ 1 offset) (- count 1)))))) | |
662 | ||
663 | (define (split-lines str) | |
664 | "Split STR into lines in a way that preserves newline characters." | |
665 | (let loop ((str str) | |
666 | (result '())) | |
667 | (if (string-null? str) | |
668 | (reverse result) | |
669 | (match (string-index str #\newline) | |
670 | (#f | |
671 | (loop "" (cons str result))) | |
672 | (index | |
673 | (loop (string-drop str (+ index 1)) | |
674 | (cons (string-take str (+ index 1)) result))))))) | |
675 | ||
dc0f74e5 LC |
676 | (define* (build-event-output-port proc #:optional (seed (build-status))) |
677 | "Return an output port for use as 'current-build-output-port' that calls | |
678 | PROC with its current state value, initialized with SEED, on every build | |
679 | event. Build events passed to PROC are tuples corresponding to the \"build | |
680 | traces\" produced by the daemon: | |
681 | ||
682 | (build-started \"/gnu/store/...-foo.drv\" ...) | |
683 | (substituter-started \"/gnu/store/...-foo\" ...) | |
684 | ||
685 | and so on. | |
686 | ||
687 | The second return value is a thunk to retrieve the current state." | |
688 | (define %fragments | |
689 | ;; Line fragments received so far. | |
690 | '()) | |
691 | ||
692 | (define %state | |
693 | ;; Current state for PROC. | |
694 | seed) | |
695 | ||
f9a8fce1 LC |
696 | ;; When true, this represents the current state while reading a |
697 | ;; "@ build-log" trace: the current builder PID, the previously-read | |
698 | ;; bytevectors, and the number of bytes that remain to be read. | |
699 | (define %build-output-pid #f) | |
700 | (define %build-output '()) | |
701 | (define %build-output-left #f) | |
702 | ||
dc0f74e5 | 703 | (define (process-line line) |
f9a8fce1 | 704 | (cond ((string-prefix? "@ " line) |
976ef2d9 LC |
705 | ;; Note: Drop the trailing \n, and use 'string-split' to preserve |
706 | ;; spaces (the log file part of 'build-started' events can be the | |
707 | ;; empty string.) | |
708 | (match (string-split (string-drop (string-drop-right line 1) 2) | |
709 | #\space) | |
f9a8fce1 LC |
710 | (("build-log" (= string->number pid) (= string->number len)) |
711 | (set! %build-output-pid pid) | |
712 | (set! %build-output '()) | |
713 | (set! %build-output-left len)) | |
714 | (((= string->symbol event-name) args ...) | |
715 | (set! %state | |
716 | (proc (cons event-name args) | |
717 | %state))))) | |
718 | (else | |
719 | (set! %state (proc (list 'build-log #f line) | |
720 | %state))))) | |
721 | ||
722 | (define (process-build-output pid output) | |
723 | ;; Transform OUTPUT in 'build-log' events or download events as generated | |
724 | ;; by extended build traces. | |
725 | (define (line->event line) | |
726 | (match (and (string-prefix? "@ " line) | |
727 | (string-tokenize (string-drop line 2))) | |
728 | ((type . args) | |
729 | (if (or (string-prefix? "download-" type) | |
730 | (string=? "build-remote" type)) | |
731 | (cons (string->symbol type) args) | |
732 | `(build-log ,pid ,line))) | |
733 | (_ | |
734 | `(build-log ,pid ,line)))) | |
735 | ||
736 | (let* ((lines (split-lines output)) | |
737 | (events (map line->event lines))) | |
738 | (set! %state (fold proc %state events)))) | |
dc0f74e5 LC |
739 | |
740 | (define (bytevector-range bv offset count) | |
741 | (let ((ptr (bytevector->pointer bv offset))) | |
742 | (pointer->bytevector ptr count))) | |
743 | ||
744 | (define (write! bv offset count) | |
f9a8fce1 LC |
745 | (if %build-output-pid |
746 | (let ((keep (min count %build-output-left))) | |
747 | (set! %build-output | |
748 | (let ((bv* (make-bytevector keep))) | |
749 | (bytevector-copy! bv offset bv* 0 keep) | |
750 | (cons bv* %build-output))) | |
751 | (set! %build-output-left | |
752 | (- %build-output-left keep)) | |
753 | ||
754 | (when (zero? %build-output-left) | |
755 | (process-build-output %build-output-pid | |
756 | (string-concatenate-reverse | |
757 | (map maybe-utf8->string %build-output))) ;XXX | |
758 | (set! %build-output '()) | |
759 | (set! %build-output-pid #f)) | |
760 | keep) | |
761 | (match (bytevector-index bv (char->integer #\newline) | |
762 | offset count) | |
763 | ((? integer? cr) | |
764 | (let* ((tail (maybe-utf8->string | |
765 | (bytevector-range bv offset (- cr -1 offset)))) | |
766 | (line (string-concatenate-reverse | |
767 | (cons tail %fragments)))) | |
768 | (process-line line) | |
769 | (set! %fragments '()) | |
770 | (- cr -1 offset))) | |
771 | (#f | |
772 | (unless (zero? count) | |
773 | (let ((str (maybe-utf8->string | |
774 | (bytevector-range bv offset count)))) | |
775 | (set! %fragments (cons str %fragments)))) | |
776 | count)))) | |
dc0f74e5 LC |
777 | |
778 | (define port | |
779 | (make-custom-binary-output-port "filtering-input-port" | |
780 | write! | |
781 | #f #f | |
782 | #f)) | |
783 | ||
784 | ;; The build port actually receives Unicode strings. | |
785 | (set-port-encoding! port "UTF-8") | |
a65177a6 | 786 | (setvbuf port 'line) |
dc0f74e5 LC |
787 | (values port (lambda () %state))) |
788 | ||
789 | (define (call-with-status-report on-event thunk) | |
790 | (parameterize ((current-terminal-columns (terminal-columns)) | |
791 | (current-build-output-port | |
792 | (build-event-output-port (build-status-updater on-event)))) | |
793 | (thunk))) | |
794 | ||
795 | (define-syntax-rule (with-status-report on-event exp ...) | |
796 | "Set up build status reporting to the user using the ON-EVENT procedure; | |
797 | evaluate EXP... in that context." | |
798 | (call-with-status-report on-event (lambda () exp ...))) | |
7804c45b LC |
799 | |
800 | (define (logger-for-level level) | |
801 | "Return the logging procedure that corresponds to LEVEL." | |
802 | (cond ((<= level 0) (const #t)) | |
803 | ((= level 1) print-build-event/quiet) | |
e45ef9a6 | 804 | ((= level 2) print-build-event/quiet-with-urls) |
7804c45b LC |
805 | (else print-build-event))) |
806 | ||
807 | (define (call-with-status-verbosity level thunk) | |
808 | (call-with-status-report (logger-for-level level) thunk)) | |
809 | ||
810 | (define-syntax-rule (with-status-verbosity level exp ...) | |
811 | "Set up build status reporting to the user at the given LEVEL: 0 means | |
812 | silent, 1 means quiet, 2 means verbose. Evaluate EXP... in that context." | |
813 | (call-with-status-verbosity level (lambda () exp ...))) |