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