Commit | Line | Data |
---|---|---|
dc0f74e5 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix status) | |
20 | #:use-module (guix records) | |
21 | #:use-module (guix i18n) | |
22 | #:use-module ((guix ui) #:select (colorize-string)) | |
23 | #:use-module (guix progress) | |
24 | #:autoload (guix build syscalls) (terminal-columns) | |
25 | #:use-module ((guix build download) | |
26 | #:select (nar-uri-abbreviation)) | |
27 | #:use-module ((guix store) | |
28 | #:select (current-build-output-port | |
29 | current-store-protocol-version | |
30 | log-file)) | |
31 | #:use-module (guix derivations) | |
32 | #:use-module (srfi srfi-1) | |
33 | #:use-module (srfi srfi-9) | |
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) | |
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 | ||
67 | with-status-report)) | |
68 | ||
69 | ;;; Commentary: | |
70 | ;;; | |
71 | ;;; This module provides facilities to track the status of ongoing builds and | |
72 | ;;; downloads in a given session, as well as tools to report about the current | |
73 | ;;; status to user interfaces. It does so by analyzing the output of | |
74 | ;;; 'current-build-output-port'. The build status is maintained in a | |
75 | ;;; <build-status> record. | |
76 | ;;; | |
77 | ;;; Code: | |
78 | ||
79 | \f | |
80 | ;;; | |
81 | ;;; Build status tracking. | |
82 | ;;; | |
83 | ||
84 | ;; Builds and substitutions performed by the daemon. | |
85 | (define-record-type* <build-status> build-status make-build-status | |
86 | build-status? | |
87 | (building build-status-building ;list of drv | |
88 | (default '())) | |
89 | (downloading build-status-downloading ;list of <download> | |
90 | (default '())) | |
91 | (builds-completed build-status-builds-completed ;list of drv | |
92 | (default '())) | |
93 | (downloads-completed build-status-downloads-completed ;list of store items | |
94 | (default '()))) | |
95 | ||
96 | ;; On-going or completed downloads. Downloads can be stem from substitutes | |
97 | ;; and from "builtin:download" fixed-output derivations. | |
98 | (define-record-type <download> | |
99 | (%download item uri size start end transferred) | |
100 | download? | |
101 | (item download-item) ;store item | |
102 | (uri download-uri) ;string | #f | |
103 | (size download-size) ;integer | #f | |
104 | (start download-start) ;<time> | |
105 | (end download-end) ;#f | <time> | |
106 | (transferred download-transferred)) ;integer | |
107 | ||
108 | (define* (download item uri | |
109 | #:key size | |
110 | (start (current-time time-monotonic)) end | |
111 | (transferred 0)) | |
112 | "Return a new download." | |
113 | (%download item uri size start end transferred)) | |
114 | ||
115 | (define (matching-download item) | |
116 | "Return a predicate that matches downloads of ITEM." | |
117 | (lambda (download) | |
118 | (string=? item (download-item download)))) | |
119 | ||
120 | (define* (compute-status event status | |
121 | #:key (current-time current-time)) | |
122 | "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), | |
123 | compute a new status based on STATUS." | |
124 | (match event | |
125 | (('build-started drv _ ...) | |
126 | (build-status | |
127 | (inherit status) | |
128 | (building (cons drv (build-status-building status))))) | |
129 | (((or 'build-succeeded 'build-failed) drv _ ...) | |
130 | (build-status | |
131 | (inherit status) | |
132 | (building (delete drv (build-status-building status))) | |
133 | (builds-completed (cons drv (build-status-builds-completed status))))) | |
134 | ||
135 | ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because | |
136 | ;; they're not as informative as 'download-started' and | |
137 | ;; 'download-succeeded'. | |
138 | ||
139 | (('download-started item uri (= string->number size)) | |
140 | ;; This is presumably a fixed-output derivation so move it from | |
141 | ;; 'building' to 'downloading'. XXX: This doesn't work in 'check' mode | |
142 | ;; because ITEM is different from DRV's output. | |
143 | (build-status | |
144 | (inherit status) | |
145 | (building (remove (lambda (drv) | |
146 | (equal? (false-if-exception | |
147 | (derivation->output-path | |
148 | (read-derivation-from-file drv))) | |
149 | item)) | |
150 | (build-status-building status))) | |
151 | (downloading (cons (download item uri #:size size | |
152 | #:start (current-time time-monotonic)) | |
153 | (build-status-downloading status))))) | |
154 | (('download-succeeded item uri (= string->number size)) | |
155 | (let ((current (find (matching-download item) | |
156 | (build-status-downloading status)))) | |
157 | (build-status | |
158 | (inherit status) | |
159 | (downloading (delq current (build-status-downloading status))) | |
160 | (downloads-completed | |
161 | (cons (download item uri | |
162 | #:size size | |
163 | #:start (download-start current) | |
164 | #:transferred size | |
165 | #:end (current-time time-monotonic)) | |
166 | (build-status-downloads-completed status)))))) | |
167 | (('substituter-succeeded item _ ...) | |
168 | (match (find (matching-download item) | |
169 | (build-status-downloading status)) | |
170 | (#f | |
171 | ;; Presumably we already got a 'download-succeeded' event for ITEM, | |
172 | ;; everything is fine. | |
173 | status) | |
174 | (current | |
175 | ;; Maybe the build process didn't emit a 'download-succeeded' event | |
176 | ;; for ITEM, so remove CURRENT from the queue now. | |
177 | (build-status | |
178 | (inherit status) | |
179 | (downloading (delq current (build-status-downloading status))) | |
180 | (downloads-completed | |
181 | (cons (download item (download-uri current) | |
182 | #:size (download-size current) | |
183 | #:start (download-start current) | |
184 | #:transferred (download-size current) | |
185 | #:end (current-time time-monotonic)) | |
186 | (build-status-downloads-completed status))))))) | |
187 | (('download-progress item uri | |
188 | (= string->number size) | |
189 | (= string->number transferred)) | |
190 | (let ((downloads (remove (matching-download item) | |
191 | (build-status-downloading status))) | |
192 | (current (find (matching-download item) | |
193 | (build-status-downloading status)))) | |
194 | (build-status | |
195 | (inherit status) | |
196 | (downloading (cons (download item uri | |
197 | #:size size | |
198 | #:start | |
199 | (or (and current | |
200 | (download-start current)) | |
201 | (current-time time-monotonic)) | |
202 | #:transferred transferred) | |
203 | downloads))))) | |
204 | (_ | |
205 | status))) | |
206 | ||
207 | (define (simultaneous-jobs status) | |
208 | "Return the number of on-going builds and downloads for STATUS." | |
209 | (+ (length (build-status-building status)) | |
210 | (length (build-status-downloading status)))) | |
211 | ||
212 | \f | |
213 | ;;; | |
214 | ;;; Rendering. | |
215 | ;;; | |
216 | ||
217 | (define (extended-build-trace-supported?) | |
218 | "Return true if the currently used store is known to support \"extended | |
219 | build traces\" such as \"@ download-progress\" traces." | |
220 | ;; Support for extended build traces was added in protocol version #x162. | |
221 | (and (current-store-protocol-version) | |
222 | (>= (current-store-protocol-version) #x162))) | |
223 | ||
224 | (define spin! | |
225 | (let ((steps (circular-list "\\" "|" "/" "-"))) | |
226 | (lambda (port) | |
227 | "Display a spinner on PORT." | |
228 | (match steps | |
229 | ((first . rest) | |
230 | (set! steps rest) | |
231 | (display "\r\x1b[K" port) | |
232 | (display first port) | |
233 | (force-output port)))))) | |
234 | ||
235 | (define (color-output? port) | |
236 | "Return true if we should write colored output to PORT." | |
237 | (and (not (getenv "INSIDE_EMACS")) | |
238 | (not (getenv "NO_COLOR")) | |
239 | (isatty? port))) | |
240 | ||
241 | (define-syntax color-rules | |
242 | (syntax-rules () | |
243 | "Return a procedure that colorizes the string it is passed according to | |
244 | the given rules. Each rule has the form: | |
245 | ||
246 | (REGEXP COLOR1 COLOR2 ...) | |
247 | ||
248 | where COLOR1 specifies how to colorize the first submatch of REGEXP, and so | |
249 | on." | |
250 | ((_ (regexp colors ...) rest ...) | |
251 | (let ((next (color-rules rest ...)) | |
252 | (rx (make-regexp regexp))) | |
253 | (lambda (str) | |
254 | (if (string-index str #\nul) | |
255 | str | |
256 | (match (regexp-exec rx str) | |
257 | (#f (next str)) | |
258 | (m (let loop ((n 1) | |
259 | (c '(colors ...)) | |
260 | (result '())) | |
261 | (match c | |
262 | (() | |
263 | (string-concatenate-reverse result)) | |
264 | ((first . tail) | |
265 | (loop (+ n 1) tail | |
266 | (cons (colorize-string (match:substring m n) | |
267 | first) | |
268 | result))))))))))) | |
269 | ((_) | |
270 | (lambda (str) | |
271 | str)))) | |
272 | ||
273 | (define colorize-log-line | |
274 | ;; Take a string and return a possibly colorized string according to the | |
275 | ;; rules below. | |
276 | (color-rules | |
277 | ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)" | |
278 | GREEN BOLD GREEN RESET GREEN BLUE) | |
279 | ("^(phase)(.*)(failed after)(.*)(seconds)(.*)" | |
280 | RED BLUE RED BLUE RED BLUE) | |
281 | ("^(.*)(error|fail|failed|FAIL|FAILED)([[:blank:]]*)(:)(.*)" | |
282 | RESET RED BOLD BOLD BOLD) | |
283 | ("^(.*)(warning)([[:blank:]]*)(:)(.*)" | |
284 | RESET ORANGE BOLD BOLD BOLD))) | |
285 | ||
286 | (define* (print-build-event event old-status status | |
287 | #:optional (port (current-error-port)) | |
288 | #:key | |
289 | (colorize? (color-output? port)) | |
290 | (print-log? #t)) | |
291 | "Print information about EVENT and STATUS to PORT. When COLORIZE? is true, | |
292 | produce colorful output. When PRINT-LOG? is true, display the build log in | |
293 | addition to build events." | |
294 | (define info | |
295 | (if colorize? | |
296 | (cut colorize-string <> 'BOLD) | |
297 | identity)) | |
298 | ||
299 | (define success | |
300 | (if colorize? | |
301 | (cut colorize-string <> 'GREEN 'BOLD) | |
302 | identity)) | |
303 | ||
304 | (define failure | |
305 | (if colorize? | |
306 | (cut colorize-string <> 'RED 'BOLD) | |
307 | identity)) | |
308 | ||
309 | (define print-log-line | |
310 | (if print-log? | |
311 | (if colorize? | |
312 | (lambda (line) | |
313 | (display (colorize-log-line line) port)) | |
314 | (cut display <> port)) | |
315 | (lambda (line) | |
316 | (spin! port)))) | |
317 | ||
318 | (display "\r" port) ;erase the spinner | |
319 | (match event | |
320 | (('build-started drv . _) | |
321 | (format port (info (G_ "building ~a...")) drv) | |
322 | (newline port)) | |
323 | (('build-succeeded drv . _) | |
324 | (format port (success (G_ "successfully built ~a")) drv) | |
325 | (newline port) | |
326 | (match (build-status-building status) | |
327 | (() #t) | |
328 | (ongoing ;when max-jobs > 1 | |
329 | (format port | |
330 | (N_ "The following build is still in progress:~%~{ ~a~%~}~%" | |
331 | "The following builds are still in progress:~%~{ ~a~%~}~%" | |
332 | (length ongoing)) | |
333 | ongoing)))) | |
334 | (('build-failed drv . _) | |
335 | (format port (failure (G_ "build of ~a failed")) drv) | |
336 | (newline port) | |
337 | (format port (info (G_ "View build log at '~a'.~%")) | |
338 | (log-file #f drv))) | |
339 | (('substituter-started item _ ...) | |
340 | (when (or print-log? (not (extended-build-trace-supported?))) | |
341 | (format port (info (G_ "substituting ~a...")) item) | |
342 | (newline port))) | |
343 | (('download-started item uri _ ...) | |
344 | (format port (info (G_ "downloading from ~a...")) uri) | |
345 | (newline port)) | |
346 | (('download-progress item uri | |
347 | (= string->number size) | |
348 | (= string->number transferred)) | |
349 | ;; Print a progress bar, but only if there's only one on-going | |
350 | ;; job--otherwise the output would be intermingled. | |
351 | (when (= 1 (simultaneous-jobs status)) | |
352 | (match (find (matching-download item) | |
353 | (build-status-downloading status)) | |
354 | (#f #f) ;shouldn't happen! | |
355 | (download | |
356 | ;; XXX: It would be nice to memoize the abbreviation. | |
357 | (let ((uri (if (string-contains uri "/nar/") | |
358 | (nar-uri-abbreviation uri) | |
359 | (basename uri)))) | |
360 | (display-download-progress uri size | |
361 | #:start-time | |
362 | (download-start download) | |
363 | #:transferred transferred)))))) | |
364 | (('substituter-succeeded item _ ...) | |
365 | ;; If there are no jobs running, we already reported download completion | |
366 | ;; so there's nothing left to do. | |
367 | (unless (and (zero? (simultaneous-jobs status)) | |
368 | (extended-build-trace-supported?)) | |
369 | (format port (success (G_ "substitution of ~a complete")) item) | |
370 | (newline port))) | |
371 | (('substituter-failed item _ ...) | |
372 | (format port (failure (G_ "substitution of ~a failed")) item) | |
373 | (newline port)) | |
374 | (('hash-mismatch item algo expected actual _ ...) | |
375 | ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for | |
376 | ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. | |
377 | (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) | |
378 | (newline port) | |
379 | (format port (info (G_ "\ | |
380 | expected hash: ~a | |
381 | actual hash: ~a~%")) | |
382 | expected actual)) | |
383 | (('build-log line) | |
384 | ;; The daemon prefixes early messages coming with 'guix substitute' with | |
385 | ;; "substitute:". These are useful ("updating substitutes from URL"), so | |
386 | ;; let them through. | |
387 | (if (string-prefix? "substitute: " line) | |
388 | (begin | |
389 | (format port line) | |
390 | (force-output port)) | |
391 | (print-log-line line))) | |
392 | (_ | |
393 | event))) | |
394 | ||
395 | (define* (print-build-event/quiet event old-status status | |
396 | #:optional | |
397 | (port (current-error-port)) | |
398 | #:key | |
399 | (colorize? (color-output? port))) | |
400 | (print-build-event event old-status status port | |
401 | #:colorize? colorize? | |
402 | #:print-log? #f)) | |
403 | ||
404 | (define* (build-status-updater #:optional (on-change (const #t))) | |
405 | "Return a procedure that can be passed to 'build-event-output-port'. That | |
406 | procedure computes the new build status upon each event and calls ON-CHANGE: | |
407 | ||
408 | (ON-CHANGE event status new-status) | |
409 | ||
410 | ON-CHANGE can display the build status, build events, etc." | |
411 | (lambda (event status) | |
412 | (let ((new (compute-status event status))) | |
413 | (on-change event status new) | |
414 | new))) | |
415 | ||
416 | \f | |
417 | ;;; | |
418 | ;;; Build port. | |
419 | ;;; | |
420 | ||
421 | (define %newline | |
422 | (char-set #\return #\newline)) | |
423 | ||
424 | (define* (build-event-output-port proc #:optional (seed (build-status))) | |
425 | "Return an output port for use as 'current-build-output-port' that calls | |
426 | PROC with its current state value, initialized with SEED, on every build | |
427 | event. Build events passed to PROC are tuples corresponding to the \"build | |
428 | traces\" produced by the daemon: | |
429 | ||
430 | (build-started \"/gnu/store/...-foo.drv\" ...) | |
431 | (substituter-started \"/gnu/store/...-foo\" ...) | |
432 | ||
433 | and so on. | |
434 | ||
435 | The second return value is a thunk to retrieve the current state." | |
436 | (define %fragments | |
437 | ;; Line fragments received so far. | |
438 | '()) | |
439 | ||
440 | (define %state | |
441 | ;; Current state for PROC. | |
442 | seed) | |
443 | ||
444 | (define (process-line line) | |
445 | (if (string-prefix? "@ " line) | |
446 | (match (string-tokenize (string-drop line 2)) | |
447 | (((= string->symbol event-name) args ...) | |
448 | (set! %state | |
449 | (proc (cons event-name args) | |
450 | %state)))) | |
451 | (set! %state (proc (list 'build-log line) | |
452 | %state)))) | |
453 | ||
454 | (define (bytevector-range bv offset count) | |
455 | (let ((ptr (bytevector->pointer bv offset))) | |
456 | (pointer->bytevector ptr count))) | |
457 | ||
458 | (define (write! bv offset count) | |
459 | (let loop ((str (utf8->string (bytevector-range bv offset count)))) | |
460 | (match (string-index str %newline) | |
461 | ((? integer? cr) | |
462 | (let ((tail (string-take str (+ 1 cr)))) | |
463 | (process-line (string-concatenate-reverse | |
464 | (cons tail %fragments))) | |
465 | (set! %fragments '()) | |
466 | (loop (string-drop str (+ 1 cr))))) | |
467 | (#f | |
468 | (unless (string-null? str) | |
469 | (set! %fragments (cons str %fragments))) | |
470 | count)))) | |
471 | ||
472 | (define port | |
473 | (make-custom-binary-output-port "filtering-input-port" | |
474 | write! | |
475 | #f #f | |
476 | #f)) | |
477 | ||
478 | ;; The build port actually receives Unicode strings. | |
479 | (set-port-encoding! port "UTF-8") | |
480 | (setvbuf port (cond-expand (guile-2.2 'line) (else _IOLBF))) | |
481 | ||
482 | (values port (lambda () %state))) | |
483 | ||
484 | (define (call-with-status-report on-event thunk) | |
485 | (parameterize ((current-terminal-columns (terminal-columns)) | |
486 | (current-build-output-port | |
487 | (build-event-output-port (build-status-updater on-event)))) | |
488 | (thunk))) | |
489 | ||
490 | (define-syntax-rule (with-status-report on-event exp ...) | |
491 | "Set up build status reporting to the user using the ON-EVENT procedure; | |
492 | evaluate EXP... in that context." | |
493 | (call-with-status-report on-event (lambda () exp ...))) |