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