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