Commit | Line | Data |
---|---|---|
dc0f74e5 | 1 | ;;; GNU Guix --- Functional package management for GNU |
260eae78 | 2 | ;;; Copyright © 2017, 2018, 2019, 2020 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))))) | |
8fa4ac5b T |
475 | (format port (info (N_ "applying ~a graft for ~a ..." |
476 | "applying ~a grafts for ~a ..." | |
af1f1c38 LC |
477 | count)) |
478 | count drv))) | |
260eae78 LC |
479 | ('profile |
480 | (let ((count (match (assq-ref properties 'profile) | |
481 | (#f 0) | |
482 | (lst (or (assq-ref lst 'count) 0))))) | |
04594054 LC |
483 | (format port (info (N_ "building profile with ~a package..." |
484 | "building profile with ~a packages..." | |
260eae78 LC |
485 | count)) |
486 | count))) | |
80eebee9 RW |
487 | ('profile-hook |
488 | (let ((hook-type (assq-ref properties 'hook))) | |
489 | (or (and=> (hook-message hook-type) | |
490 | (lambda (msg) | |
491 | (format port (info msg)))) | |
492 | (format port (info (G_ "running profile hook of type '~a'...")) | |
493 | hook-type)))) | |
af1f1c38 LC |
494 | (_ |
495 | (format port (info (G_ "building ~a...")) drv)))) | |
dc0f74e5 LC |
496 | (newline port)) |
497 | (('build-succeeded drv . _) | |
024d5275 | 498 | (erase-current-line*) ;erase spinner or progress bar |
38a2f5ea LC |
499 | (when (or print-log? (not (extended-build-trace-supported?))) |
500 | (format port (success (G_ "successfully built ~a")) drv) | |
501 | (newline port)) | |
dc0f74e5 LC |
502 | (match (build-status-building status) |
503 | (() #t) | |
504 | (ongoing ;when max-jobs > 1 | |
505 | (format port | |
506 | (N_ "The following build is still in progress:~%~{ ~a~%~}~%" | |
507 | "The following builds are still in progress:~%~{ ~a~%~}~%" | |
508 | (length ongoing)) | |
976ef2d9 | 509 | (map build-derivation ongoing))))) |
dc0f74e5 | 510 | (('build-failed drv . _) |
024d5275 | 511 | (erase-current-line*) ;erase spinner or progress bar |
dc0f74e5 LC |
512 | (format port (failure (G_ "build of ~a failed")) drv) |
513 | (newline port) | |
fb94d82b LC |
514 | (match (derivation-log-file drv) |
515 | (#f | |
516 | (format port (failure (G_ "Could not find build log for '~a'.")) | |
517 | drv)) | |
518 | (log | |
519 | (format port (info (G_ "View build log at '~a'.")) log))) | |
520 | (newline port)) | |
dc0f74e5 | 521 | (('substituter-started item _ ...) |
5ea206a8 | 522 | (erase-current-line*) |
dc0f74e5 LC |
523 | (when (or print-log? (not (extended-build-trace-supported?))) |
524 | (format port (info (G_ "substituting ~a...")) item) | |
525 | (newline port))) | |
526 | (('download-started item uri _ ...) | |
5ea206a8 | 527 | (erase-current-line*) |
8fa4ac5b | 528 | (format port (info (G_ "downloading from ~a ...")) uri) |
dc0f74e5 LC |
529 | (newline port)) |
530 | (('download-progress item uri | |
531 | (= string->number size) | |
532 | (= string->number transferred)) | |
533 | ;; Print a progress bar, but only if there's only one on-going | |
534 | ;; job--otherwise the output would be intermingled. | |
535 | (when (= 1 (simultaneous-jobs status)) | |
536 | (match (find (matching-download item) | |
537 | (build-status-downloading status)) | |
538 | (#f #f) ;shouldn't happen! | |
539 | (download | |
540 | ;; XXX: It would be nice to memoize the abbreviation. | |
541 | (let ((uri (if (string-contains uri "/nar/") | |
542 | (nar-uri-abbreviation uri) | |
543 | (basename uri)))) | |
544 | (display-download-progress uri size | |
545 | #:start-time | |
546 | (download-start download) | |
547 | #:transferred transferred)))))) | |
548 | (('substituter-succeeded item _ ...) | |
549 | ;; If there are no jobs running, we already reported download completion | |
550 | ;; so there's nothing left to do. | |
551 | (unless (and (zero? (simultaneous-jobs status)) | |
552 | (extended-build-trace-supported?)) | |
553 | (format port (success (G_ "substitution of ~a complete")) item) | |
554 | (newline port))) | |
555 | (('substituter-failed item _ ...) | |
556 | (format port (failure (G_ "substitution of ~a failed")) item) | |
557 | (newline port)) | |
558 | (('hash-mismatch item algo expected actual _ ...) | |
559 | ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for | |
560 | ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. | |
561 | (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) | |
562 | (newline port) | |
563 | (format port (info (G_ "\ | |
564 | expected hash: ~a | |
565 | actual hash: ~a~%")) | |
566 | expected actual)) | |
694e638e LC |
567 | (('build-remote drv host _ ...) |
568 | (format port (info (G_ "offloading build of ~a to '~a'")) drv host) | |
569 | (newline port)) | |
f9a8fce1 LC |
570 | (('build-log pid line) |
571 | (if (multiplexed-output-supported?) | |
572 | (if (not pid) | |
573 | (begin | |
574 | ;; LINE comes from the daemon, not from builders. Let it | |
575 | ;; through. | |
576 | (display line port) | |
577 | (force-output port)) | |
3854c642 | 578 | (print-log-line pid line)) |
f9a8fce1 LC |
579 | (cond ((string-prefix? "substitute: " line) |
580 | ;; The daemon prefixes early messages coming with 'guix | |
581 | ;; substitute' with "substitute:". These are useful ("updating | |
582 | ;; substitutes from URL"), so let them through. | |
583 | (display line port) | |
584 | (force-output port)) | |
585 | ((string-prefix? "waiting for locks" line) | |
586 | ;; This is when a derivation is already being built and we're just | |
587 | ;; waiting for the build to complete. | |
588 | (display (info (string-trim-right line)) port) | |
589 | (newline)) | |
590 | (else | |
3854c642 | 591 | (print-log-line pid line))))) |
dc0f74e5 LC |
592 | (_ |
593 | event))) | |
594 | ||
595 | (define* (print-build-event/quiet event old-status status | |
596 | #:optional | |
597 | (port (current-error-port)) | |
598 | #:key | |
599 | (colorize? (color-output? port))) | |
600 | (print-build-event event old-status status port | |
601 | #:colorize? colorize? | |
602 | #:print-log? #f)) | |
603 | ||
604 | (define* (build-status-updater #:optional (on-change (const #t))) | |
605 | "Return a procedure that can be passed to 'build-event-output-port'. That | |
606 | procedure computes the new build status upon each event and calls ON-CHANGE: | |
607 | ||
608 | (ON-CHANGE event status new-status) | |
609 | ||
610 | ON-CHANGE can display the build status, build events, etc." | |
611 | (lambda (event status) | |
612 | (let ((new (compute-status event status))) | |
613 | (on-change event status new) | |
614 | new))) | |
615 | ||
616 | \f | |
617 | ;;; | |
618 | ;;; Build port. | |
619 | ;;; | |
620 | ||
fe17037b LC |
621 | (define (maybe-utf8->string bv) |
622 | "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the | |
623 | case where BV does not contain only valid UTF-8." | |
624 | (catch 'decoding-error | |
625 | (lambda () | |
626 | (utf8->string bv)) | |
627 | (lambda _ | |
628 | ;; This is the sledgehammer but it's the only safe way we have to | |
629 | ;; properly handle this. It's expensive but it's rarely needed. | |
630 | (let ((port (open-bytevector-input-port bv))) | |
631 | (set-port-encoding! port "UTF-8") | |
632 | (set-port-conversion-strategy! port 'substitute) | |
633 | (let ((str (read-string port))) | |
634 | (close-port port) | |
635 | str))))) | |
636 | ||
f9a8fce1 LC |
637 | (define (bytevector-index bv number offset count) |
638 | "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes; | |
639 | return the offset where NUMBER first occurs or #f if it could not be found." | |
640 | (let loop ((offset offset) | |
641 | (count count)) | |
642 | (cond ((zero? count) #f) | |
643 | ((= (bytevector-u8-ref bv offset) number) offset) | |
644 | (else (loop (+ 1 offset) (- count 1)))))) | |
645 | ||
646 | (define (split-lines str) | |
647 | "Split STR into lines in a way that preserves newline characters." | |
648 | (let loop ((str str) | |
649 | (result '())) | |
650 | (if (string-null? str) | |
651 | (reverse result) | |
652 | (match (string-index str #\newline) | |
653 | (#f | |
654 | (loop "" (cons str result))) | |
655 | (index | |
656 | (loop (string-drop str (+ index 1)) | |
657 | (cons (string-take str (+ index 1)) result))))))) | |
658 | ||
dc0f74e5 LC |
659 | (define* (build-event-output-port proc #:optional (seed (build-status))) |
660 | "Return an output port for use as 'current-build-output-port' that calls | |
661 | PROC with its current state value, initialized with SEED, on every build | |
662 | event. Build events passed to PROC are tuples corresponding to the \"build | |
663 | traces\" produced by the daemon: | |
664 | ||
665 | (build-started \"/gnu/store/...-foo.drv\" ...) | |
666 | (substituter-started \"/gnu/store/...-foo\" ...) | |
667 | ||
668 | and so on. | |
669 | ||
670 | The second return value is a thunk to retrieve the current state." | |
671 | (define %fragments | |
672 | ;; Line fragments received so far. | |
673 | '()) | |
674 | ||
675 | (define %state | |
676 | ;; Current state for PROC. | |
677 | seed) | |
678 | ||
f9a8fce1 LC |
679 | ;; When true, this represents the current state while reading a |
680 | ;; "@ build-log" trace: the current builder PID, the previously-read | |
681 | ;; bytevectors, and the number of bytes that remain to be read. | |
682 | (define %build-output-pid #f) | |
683 | (define %build-output '()) | |
684 | (define %build-output-left #f) | |
685 | ||
dc0f74e5 | 686 | (define (process-line line) |
f9a8fce1 | 687 | (cond ((string-prefix? "@ " line) |
976ef2d9 LC |
688 | ;; Note: Drop the trailing \n, and use 'string-split' to preserve |
689 | ;; spaces (the log file part of 'build-started' events can be the | |
690 | ;; empty string.) | |
691 | (match (string-split (string-drop (string-drop-right line 1) 2) | |
692 | #\space) | |
f9a8fce1 LC |
693 | (("build-log" (= string->number pid) (= string->number len)) |
694 | (set! %build-output-pid pid) | |
695 | (set! %build-output '()) | |
696 | (set! %build-output-left len)) | |
697 | (((= string->symbol event-name) args ...) | |
698 | (set! %state | |
699 | (proc (cons event-name args) | |
700 | %state))))) | |
701 | (else | |
702 | (set! %state (proc (list 'build-log #f line) | |
703 | %state))))) | |
704 | ||
705 | (define (process-build-output pid output) | |
706 | ;; Transform OUTPUT in 'build-log' events or download events as generated | |
707 | ;; by extended build traces. | |
708 | (define (line->event line) | |
709 | (match (and (string-prefix? "@ " line) | |
710 | (string-tokenize (string-drop line 2))) | |
711 | ((type . args) | |
712 | (if (or (string-prefix? "download-" type) | |
713 | (string=? "build-remote" type)) | |
714 | (cons (string->symbol type) args) | |
715 | `(build-log ,pid ,line))) | |
716 | (_ | |
717 | `(build-log ,pid ,line)))) | |
718 | ||
719 | (let* ((lines (split-lines output)) | |
720 | (events (map line->event lines))) | |
721 | (set! %state (fold proc %state events)))) | |
dc0f74e5 LC |
722 | |
723 | (define (bytevector-range bv offset count) | |
724 | (let ((ptr (bytevector->pointer bv offset))) | |
725 | (pointer->bytevector ptr count))) | |
726 | ||
727 | (define (write! bv offset count) | |
f9a8fce1 LC |
728 | (if %build-output-pid |
729 | (let ((keep (min count %build-output-left))) | |
730 | (set! %build-output | |
731 | (let ((bv* (make-bytevector keep))) | |
732 | (bytevector-copy! bv offset bv* 0 keep) | |
733 | (cons bv* %build-output))) | |
734 | (set! %build-output-left | |
735 | (- %build-output-left keep)) | |
736 | ||
737 | (when (zero? %build-output-left) | |
738 | (process-build-output %build-output-pid | |
739 | (string-concatenate-reverse | |
740 | (map maybe-utf8->string %build-output))) ;XXX | |
741 | (set! %build-output '()) | |
742 | (set! %build-output-pid #f)) | |
743 | keep) | |
744 | (match (bytevector-index bv (char->integer #\newline) | |
745 | offset count) | |
746 | ((? integer? cr) | |
747 | (let* ((tail (maybe-utf8->string | |
748 | (bytevector-range bv offset (- cr -1 offset)))) | |
749 | (line (string-concatenate-reverse | |
750 | (cons tail %fragments)))) | |
751 | (process-line line) | |
752 | (set! %fragments '()) | |
753 | (- cr -1 offset))) | |
754 | (#f | |
755 | (unless (zero? count) | |
756 | (let ((str (maybe-utf8->string | |
757 | (bytevector-range bv offset count)))) | |
758 | (set! %fragments (cons str %fragments)))) | |
759 | count)))) | |
dc0f74e5 LC |
760 | |
761 | (define port | |
762 | (make-custom-binary-output-port "filtering-input-port" | |
763 | write! | |
764 | #f #f | |
765 | #f)) | |
766 | ||
767 | ;; The build port actually receives Unicode strings. | |
768 | (set-port-encoding! port "UTF-8") | |
a65177a6 | 769 | (setvbuf port 'line) |
dc0f74e5 LC |
770 | (values port (lambda () %state))) |
771 | ||
772 | (define (call-with-status-report on-event thunk) | |
773 | (parameterize ((current-terminal-columns (terminal-columns)) | |
774 | (current-build-output-port | |
775 | (build-event-output-port (build-status-updater on-event)))) | |
776 | (thunk))) | |
777 | ||
778 | (define-syntax-rule (with-status-report on-event exp ...) | |
779 | "Set up build status reporting to the user using the ON-EVENT procedure; | |
780 | evaluate EXP... in that context." | |
781 | (call-with-status-report on-event (lambda () exp ...))) | |
7804c45b LC |
782 | |
783 | (define (logger-for-level level) | |
784 | "Return the logging procedure that corresponds to LEVEL." | |
785 | (cond ((<= level 0) (const #t)) | |
786 | ((= level 1) print-build-event/quiet) | |
787 | (else print-build-event))) | |
788 | ||
789 | (define (call-with-status-verbosity level thunk) | |
790 | (call-with-status-report (logger-for-level level) thunk)) | |
791 | ||
792 | (define-syntax-rule (with-status-verbosity level exp ...) | |
793 | "Set up build status reporting to the user at the given LEVEL: 0 means | |
794 | silent, 1 means quiet, 2 means verbose. Evaluate EXP... in that context." | |
795 | (call-with-status-verbosity level (lambda () exp ...))) |