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) | |
5d9f9ad6 | 23 | #:use-module (guix colors) |
dc0f74e5 LC |
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) | |
c7465dcb | 33 | #:use-module (srfi srfi-9 gnu) |
dc0f74e5 LC |
34 | #:use-module (srfi srfi-19) |
35 | #:use-module (srfi srfi-26) | |
36 | #:use-module (ice-9 regex) | |
37 | #:use-module (ice-9 match) | |
38 | #:use-module (ice-9 format) | |
39 | #:use-module (ice-9 binary-ports) | |
fe17037b | 40 | #:autoload (ice-9 rdelim) (read-string) |
dc0f74e5 LC |
41 | #:use-module (rnrs bytevectors) |
42 | #:use-module ((system foreign) | |
43 | #:select (bytevector->pointer pointer->bytevector)) | |
44 | #:export (build-event-output-port | |
45 | compute-status | |
46 | ||
47 | build-status | |
48 | build-status? | |
49 | build-status-building | |
50 | build-status-downloading | |
51 | build-status-builds-completed | |
52 | build-status-downloads-completed | |
53 | ||
976ef2d9 LC |
54 | build? |
55 | build | |
56 | build-derivation | |
57 | build-system | |
ba514b60 LC |
58 | build-log-file |
59 | build-phase | |
60 | build-completion | |
976ef2d9 | 61 | |
dc0f74e5 LC |
62 | download? |
63 | download | |
64 | download-item | |
65 | download-uri | |
66 | download-size | |
67 | download-start | |
68 | download-end | |
69 | download-transferred | |
70 | ||
71 | build-status-updater | |
72 | print-build-event | |
73 | print-build-event/quiet | |
74 | print-build-status | |
75 | ||
7804c45b LC |
76 | with-status-report |
77 | with-status-verbosity)) | |
dc0f74e5 LC |
78 | |
79 | ;;; Commentary: | |
80 | ;;; | |
81 | ;;; This module provides facilities to track the status of ongoing builds and | |
82 | ;;; downloads in a given session, as well as tools to report about the current | |
83 | ;;; status to user interfaces. It does so by analyzing the output of | |
84 | ;;; 'current-build-output-port'. The build status is maintained in a | |
85 | ;;; <build-status> record. | |
86 | ;;; | |
87 | ;;; Code: | |
88 | ||
89 | \f | |
90 | ;;; | |
91 | ;;; Build status tracking. | |
92 | ;;; | |
93 | ||
94 | ;; Builds and substitutions performed by the daemon. | |
95 | (define-record-type* <build-status> build-status make-build-status | |
96 | build-status? | |
976ef2d9 | 97 | (building build-status-building ;list of <build> |
dc0f74e5 LC |
98 | (default '())) |
99 | (downloading build-status-downloading ;list of <download> | |
100 | (default '())) | |
976ef2d9 | 101 | (builds-completed build-status-builds-completed ;list of <build> |
dc0f74e5 | 102 | (default '())) |
976ef2d9 | 103 | (downloads-completed build-status-downloads-completed ;list of <download> |
dc0f74e5 LC |
104 | (default '()))) |
105 | ||
976ef2d9 | 106 | ;; On-going or completed build. |
c7465dcb | 107 | (define-immutable-record-type <build> |
ba514b60 | 108 | (%build derivation id system log-file phase completion) |
976ef2d9 LC |
109 | build? |
110 | (derivation build-derivation) ;string (.drv file name) | |
111 | (id build-id) ;#f | integer | |
112 | (system build-system) ;string | |
73a8681a | 113 | (log-file build-log-file) ;#f | string |
ba514b60 LC |
114 | (phase build-phase ;#f | symbol |
115 | set-build-phase) | |
c7465dcb LC |
116 | (completion build-completion ;#f | integer (percentage) |
117 | set-build-completion)) | |
976ef2d9 | 118 | |
ba514b60 | 119 | (define* (build derivation system #:key id log-file phase completion) |
976ef2d9 | 120 | "Return a new build." |
ba514b60 | 121 | (%build derivation id system log-file phase completion)) |
976ef2d9 | 122 | |
dc0f74e5 LC |
123 | ;; On-going or completed downloads. Downloads can be stem from substitutes |
124 | ;; and from "builtin:download" fixed-output derivations. | |
125 | (define-record-type <download> | |
126 | (%download item uri size start end transferred) | |
127 | download? | |
128 | (item download-item) ;store item | |
129 | (uri download-uri) ;string | #f | |
130 | (size download-size) ;integer | #f | |
131 | (start download-start) ;<time> | |
132 | (end download-end) ;#f | <time> | |
133 | (transferred download-transferred)) ;integer | |
134 | ||
135 | (define* (download item uri | |
136 | #:key size | |
137 | (start (current-time time-monotonic)) end | |
138 | (transferred 0)) | |
139 | "Return a new download." | |
140 | (%download item uri size start end transferred)) | |
141 | ||
976ef2d9 LC |
142 | (define (matching-build drv) |
143 | "Return a predicate that matches builds of DRV." | |
144 | (lambda (build) | |
145 | (string=? drv (build-derivation build)))) | |
146 | ||
dc0f74e5 LC |
147 | (define (matching-download item) |
148 | "Return a predicate that matches downloads of ITEM." | |
149 | (lambda (download) | |
150 | (string=? item (download-item download)))) | |
151 | ||
ba514b60 LC |
152 | (define %phase-start-rx |
153 | ;; Match the "starting phase" message emitted by 'gnu-build-system'. | |
154 | (make-regexp "^starting phase [`']([^']+)'")) | |
155 | ||
73a8681a LC |
156 | (define %percentage-line-rx |
157 | ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp | |
158 | ;; matches them. | |
159 | (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]")) | |
160 | ||
161 | (define %fraction-line-rx | |
162 | ;; The 'compiled-modules' derivations and Ninja produce reports like | |
163 | ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]". | |
164 | ;; This regexp matches these. | |
165 | (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]")) | |
166 | ||
167 | (define (update-build status id line) | |
168 | "Update STATUS based on LINE, a build output line for ID that might contain | |
169 | a completion indication." | |
73a8681a LC |
170 | (define (find-build) |
171 | (find (lambda (build) | |
172 | (and (build-id build) | |
173 | (= (build-id build) id))) | |
174 | (build-status-building status))) | |
175 | ||
176 | (define (update %) | |
177 | (let ((build (find-build))) | |
178 | (build-status | |
179 | (inherit status) | |
c7465dcb | 180 | (building (cons (set-build-completion build %) |
73a8681a LC |
181 | (delq build (build-status-building status))))))) |
182 | ||
183 | (cond ((string-any #\nul line) | |
184 | ;; Don't try to match a regexp here. | |
185 | status) | |
186 | ((regexp-exec %percentage-line-rx line) | |
187 | => | |
188 | (lambda (match) | |
189 | (let ((% (string->number (match:substring match 1)))) | |
190 | (update %)))) | |
191 | ((regexp-exec %fraction-line-rx line) | |
192 | => | |
193 | (lambda (match) | |
194 | (let ((done (string->number (match:substring match 1))) | |
195 | (total (string->number (match:substring match 3)))) | |
196 | (update (* 100. (/ done total)))))) | |
ba514b60 LC |
197 | ((regexp-exec %phase-start-rx line) |
198 | => | |
199 | (lambda (match) | |
200 | (let ((phase (match:substring match 1)) | |
201 | (build (find-build))) | |
202 | (if build | |
203 | (build-status | |
204 | (inherit status) | |
205 | (building | |
206 | (cons (set-build-phase (set-build-completion build #f) | |
207 | (string->symbol phase)) | |
208 | (delq build (build-status-building status))))) | |
209 | status)))) | |
73a8681a LC |
210 | (else |
211 | status))) | |
212 | ||
dc0f74e5 | 213 | (define* (compute-status event status |
f9a8fce1 LC |
214 | #:key |
215 | (current-time current-time) | |
216 | (derivation-path->output-path | |
217 | derivation-path->output-path)) | |
dc0f74e5 LC |
218 | "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), |
219 | compute a new status based on STATUS." | |
220 | (match event | |
976ef2d9 LC |
221 | (('build-started drv "-" system log-file . rest) |
222 | (let ((build (build drv system | |
223 | #:id (match rest | |
224 | ((pid . _) (string->number pid)) | |
225 | (_ #f)) | |
226 | #:log-file (if (string-null? log-file) | |
227 | #f | |
228 | log-file)))) | |
229 | (build-status | |
230 | (inherit status) | |
231 | (building (cons build (build-status-building status)))))) | |
dc0f74e5 | 232 | (((or 'build-succeeded 'build-failed) drv _ ...) |
976ef2d9 LC |
233 | (let ((build (find (matching-build drv) |
234 | (build-status-building status)))) | |
235 | ;; If BUILD is #f, this may be because DRV corresponds to a | |
236 | ;; fixed-output derivation that is listed as a download. | |
237 | (if build | |
238 | (build-status | |
239 | (inherit status) | |
240 | (building (delq build (build-status-building status))) | |
241 | (builds-completed | |
242 | (cons build (build-status-builds-completed status)))) | |
243 | status))) | |
dc0f74e5 LC |
244 | |
245 | ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because | |
246 | ;; they're not as informative as 'download-started' and | |
247 | ;; 'download-succeeded'. | |
248 | ||
249 | (('download-started item uri (= string->number size)) | |
250 | ;; This is presumably a fixed-output derivation so move it from | |
251 | ;; 'building' to 'downloading'. XXX: This doesn't work in 'check' mode | |
252 | ;; because ITEM is different from DRV's output. | |
253 | (build-status | |
254 | (inherit status) | |
976ef2d9 LC |
255 | (building (remove (lambda (build) |
256 | (let ((drv (build-derivation build))) | |
257 | (equal? (false-if-exception | |
258 | (derivation-path->output-path drv)) | |
259 | item))) | |
dc0f74e5 LC |
260 | (build-status-building status))) |
261 | (downloading (cons (download item uri #:size size | |
262 | #:start (current-time time-monotonic)) | |
263 | (build-status-downloading status))))) | |
264 | (('download-succeeded item uri (= string->number size)) | |
265 | (let ((current (find (matching-download item) | |
266 | (build-status-downloading status)))) | |
267 | (build-status | |
268 | (inherit status) | |
269 | (downloading (delq current (build-status-downloading status))) | |
270 | (downloads-completed | |
271 | (cons (download item uri | |
272 | #:size size | |
273 | #:start (download-start current) | |
274 | #:transferred size | |
275 | #:end (current-time time-monotonic)) | |
276 | (build-status-downloads-completed status)))))) | |
277 | (('substituter-succeeded item _ ...) | |
278 | (match (find (matching-download item) | |
279 | (build-status-downloading status)) | |
280 | (#f | |
281 | ;; Presumably we already got a 'download-succeeded' event for ITEM, | |
282 | ;; everything is fine. | |
283 | status) | |
284 | (current | |
285 | ;; Maybe the build process didn't emit a 'download-succeeded' event | |
286 | ;; for ITEM, so remove CURRENT from the queue now. | |
287 | (build-status | |
288 | (inherit status) | |
289 | (downloading (delq current (build-status-downloading status))) | |
290 | (downloads-completed | |
291 | (cons (download item (download-uri current) | |
292 | #:size (download-size current) | |
293 | #:start (download-start current) | |
294 | #:transferred (download-size current) | |
295 | #:end (current-time time-monotonic)) | |
296 | (build-status-downloads-completed status))))))) | |
297 | (('download-progress item uri | |
298 | (= string->number size) | |
299 | (= string->number transferred)) | |
300 | (let ((downloads (remove (matching-download item) | |
301 | (build-status-downloading status))) | |
302 | (current (find (matching-download item) | |
303 | (build-status-downloading status)))) | |
304 | (build-status | |
305 | (inherit status) | |
306 | (downloading (cons (download item uri | |
307 | #:size size | |
308 | #:start | |
309 | (or (and current | |
310 | (download-start current)) | |
311 | (current-time time-monotonic)) | |
312 | #:transferred transferred) | |
313 | downloads))))) | |
73a8681a LC |
314 | (('build-log (? integer? pid) line) |
315 | (update-build status pid line)) | |
dc0f74e5 LC |
316 | (_ |
317 | status))) | |
318 | ||
319 | (define (simultaneous-jobs status) | |
320 | "Return the number of on-going builds and downloads for STATUS." | |
321 | (+ (length (build-status-building status)) | |
322 | (length (build-status-downloading status)))) | |
323 | ||
324 | \f | |
325 | ;;; | |
326 | ;;; Rendering. | |
327 | ;;; | |
328 | ||
329 | (define (extended-build-trace-supported?) | |
330 | "Return true if the currently used store is known to support \"extended | |
331 | build traces\" such as \"@ download-progress\" traces." | |
332 | ;; Support for extended build traces was added in protocol version #x162. | |
333 | (and (current-store-protocol-version) | |
334 | (>= (current-store-protocol-version) #x162))) | |
335 | ||
f9a8fce1 LC |
336 | (define (multiplexed-output-supported?) |
337 | "Return true if the daemon supports \"multiplexed output\"--i.e., \"@ | |
338 | build-log\" traces." | |
339 | (and (current-store-protocol-version) | |
340 | (>= (current-store-protocol-version) #x163))) | |
341 | ||
dc0f74e5 LC |
342 | (define spin! |
343 | (let ((steps (circular-list "\\" "|" "/" "-"))) | |
596fb4ba LC |
344 | (lambda (phase port) |
345 | "Display a spinner on PORT. If PHASE is true, display it as a hint of | |
346 | the current build phase." | |
0c1bc5ec LC |
347 | (when (isatty?* port) |
348 | (match steps | |
349 | ((first . rest) | |
350 | (set! steps rest) | |
351 | (display "\r\x1b[K" port) | |
352 | (display first port) | |
596fb4ba LC |
353 | (when phase |
354 | (display " " port) | |
355 | ;; TRANSLATORS: The word "phase" here denotes a "build phase"; | |
356 | ;; "~a" is a placeholder for the untranslated name of the current | |
357 | ;; build phase--e.g., 'configure' or 'build'. | |
358 | (format port (G_ "'~a' phase") phase)) | |
0c1bc5ec | 359 | (force-output port))))))) |
dc0f74e5 | 360 | |
dc0f74e5 LC |
361 | (define colorize-log-line |
362 | ;; Take a string and return a possibly colorized string according to the | |
363 | ;; rules below. | |
364 | (color-rules | |
365 | ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)" | |
366 | GREEN BOLD GREEN RESET GREEN BLUE) | |
367 | ("^(phase)(.*)(failed after)(.*)(seconds)(.*)" | |
368 | RED BLUE RED BLUE RED BLUE) | |
1dc876a3 | 369 | ("^(.*)(error|fail|failed|\\<FAIL|FAILED)([[:blank:]]*)(:)(.*)" |
dc0f74e5 LC |
370 | RESET RED BOLD BOLD BOLD) |
371 | ("^(.*)(warning)([[:blank:]]*)(:)(.*)" | |
1dc876a3 | 372 | RESET MAGENTA BOLD BOLD BOLD))) |
dc0f74e5 | 373 | |
80eebee9 RW |
374 | (define (hook-message hook-type) |
375 | "Return a human-readable string for the profile hook type HOOK-TYPE." | |
376 | (match hook-type | |
377 | ('info-dir | |
378 | (G_ "building directory of Info manuals...")) | |
379 | ('ghc-package-cache | |
380 | (G_ "building GHC package cache...")) | |
381 | ('ca-certificate-bundle | |
382 | (G_ "building CA certificate bundle...")) | |
383 | ('glib-schemas | |
384 | (G_ "generating GLib schema cache...")) | |
385 | ('gtk-icon-themes | |
386 | (G_ "creating GTK+ icon theme cache...")) | |
387 | ('gtk-im-modules | |
388 | (G_ "building cache files for GTK+ input methods...")) | |
389 | ('xdg-desktop-database | |
390 | (G_ "building XDG desktop file cache...")) | |
391 | ('xdg-mime-database | |
392 | (G_ "building XDG MIME database...")) | |
393 | ('fonts-dir | |
394 | (G_ "building fonts directory...")) | |
743497b5 RW |
395 | ('texlive-configuration |
396 | (G_ "building TeX Live configuration...")) | |
80eebee9 RW |
397 | ('manual-database |
398 | (G_ "building database for manual pages...")) | |
b9da4b93 LC |
399 | ('package-cache ;package cache generated by 'guix pull' |
400 | (G_ "building package cache...")) | |
80eebee9 RW |
401 | (_ #f))) |
402 | ||
dc0f74e5 LC |
403 | (define* (print-build-event event old-status status |
404 | #:optional (port (current-error-port)) | |
405 | #:key | |
406 | (colorize? (color-output? port)) | |
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 | |
410 | addition to build events." | |
411 | (define info | |
412 | (if colorize? | |
2569ef9d | 413 | (cute colorize-string <> (color BOLD)) |
dc0f74e5 LC |
414 | identity)) |
415 | ||
416 | (define success | |
417 | (if colorize? | |
2569ef9d | 418 | (cute colorize-string <> (color GREEN BOLD)) |
dc0f74e5 LC |
419 | identity)) |
420 | ||
421 | (define failure | |
422 | (if colorize? | |
2569ef9d | 423 | (cute colorize-string <> (color RED BOLD)) |
dc0f74e5 LC |
424 | identity)) |
425 | ||
596fb4ba | 426 | (define (report-build-progress phase %) |
3854c642 LC |
427 | (let ((% (min (max % 0) 100))) ;sanitize |
428 | (erase-current-line port) | |
596fb4ba LC |
429 | (let* ((prefix (format #f "~3d% ~@['~a' ~]" |
430 | (inexact->exact (round %)) | |
431 | (case phase | |
432 | ((build) #f) ;not useful to display it | |
433 | (else phase)))) | |
434 | (length (string-length prefix))) | |
435 | (display prefix port) | |
436 | (display (progress-bar % (- (current-terminal-columns) length)) | |
437 | port)) | |
3854c642 LC |
438 | (force-output port))) |
439 | ||
dc0f74e5 LC |
440 | (define print-log-line |
441 | (if print-log? | |
442 | (if colorize? | |
3854c642 | 443 | (lambda (id line) |
dc0f74e5 | 444 | (display (colorize-log-line line) port)) |
3854c642 LC |
445 | (lambda (id line) |
446 | (display line port))) | |
447 | (lambda (id line) | |
448 | (match (build-status-building status) | |
449 | ((build) ;single job | |
450 | (match (build-completion build) | |
596fb4ba LC |
451 | ((? number? %) |
452 | (report-build-progress (build-phase build) %)) | |
453 | (_ | |
454 | (spin! (build-phase build) port)))) | |
3854c642 | 455 | (_ |
596fb4ba | 456 | (spin! #f port)))))) |
dc0f74e5 | 457 | |
7473bce2 | 458 | (define erase-current-line* |
024d5275 LC |
459 | (if (and (not print-log?) (isatty?* port)) |
460 | (lambda () | |
7473bce2 LC |
461 | (erase-current-line port) |
462 | (force-output port)) | |
463 | (const #t))) | |
464 | ||
dc0f74e5 LC |
465 | (match event |
466 | (('build-started drv . _) | |
5ea206a8 | 467 | (erase-current-line*) |
af1f1c38 LC |
468 | (let ((properties (derivation-properties |
469 | (read-derivation-from-file drv)))) | |
470 | (match (assq-ref properties 'type) | |
471 | ('graft | |
472 | (let ((count (match (assq-ref properties 'graft) | |
473 | (#f 0) | |
474 | (lst (or (assq-ref lst 'count) 0))))) | |
475 | (format port (info (N_ "applying ~a graft for ~a..." | |
476 | "applying ~a grafts for ~a..." | |
477 | count)) | |
478 | count drv))) | |
80eebee9 RW |
479 | ('profile-hook |
480 | (let ((hook-type (assq-ref properties 'hook))) | |
481 | (or (and=> (hook-message hook-type) | |
482 | (lambda (msg) | |
483 | (format port (info msg)))) | |
484 | (format port (info (G_ "running profile hook of type '~a'...")) | |
485 | hook-type)))) | |
af1f1c38 LC |
486 | (_ |
487 | (format port (info (G_ "building ~a...")) drv)))) | |
dc0f74e5 LC |
488 | (newline port)) |
489 | (('build-succeeded drv . _) | |
024d5275 | 490 | (erase-current-line*) ;erase spinner or progress bar |
38a2f5ea LC |
491 | (when (or print-log? (not (extended-build-trace-supported?))) |
492 | (format port (success (G_ "successfully built ~a")) drv) | |
493 | (newline port)) | |
dc0f74e5 LC |
494 | (match (build-status-building status) |
495 | (() #t) | |
496 | (ongoing ;when max-jobs > 1 | |
497 | (format port | |
498 | (N_ "The following build is still in progress:~%~{ ~a~%~}~%" | |
499 | "The following builds are still in progress:~%~{ ~a~%~}~%" | |
500 | (length ongoing)) | |
976ef2d9 | 501 | (map build-derivation ongoing))))) |
dc0f74e5 | 502 | (('build-failed drv . _) |
024d5275 | 503 | (erase-current-line*) ;erase spinner or progress bar |
dc0f74e5 LC |
504 | (format port (failure (G_ "build of ~a failed")) drv) |
505 | (newline port) | |
fb94d82b LC |
506 | (match (derivation-log-file drv) |
507 | (#f | |
508 | (format port (failure (G_ "Could not find build log for '~a'.")) | |
509 | drv)) | |
510 | (log | |
511 | (format port (info (G_ "View build log at '~a'.")) log))) | |
512 | (newline port)) | |
dc0f74e5 | 513 | (('substituter-started item _ ...) |
5ea206a8 | 514 | (erase-current-line*) |
dc0f74e5 LC |
515 | (when (or print-log? (not (extended-build-trace-supported?))) |
516 | (format port (info (G_ "substituting ~a...")) item) | |
517 | (newline port))) | |
518 | (('download-started item uri _ ...) | |
5ea206a8 | 519 | (erase-current-line*) |
dc0f74e5 LC |
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 ...))) |