| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> |
| 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 colors) |
| 24 | #:use-module (guix progress) |
| 25 | #:autoload (guix build syscalls) (terminal-columns) |
| 26 | #:use-module ((guix build download) |
| 27 | #:select (nar-uri-abbreviation)) |
| 28 | #:use-module (guix store) |
| 29 | #:use-module (guix derivations) |
| 30 | #:use-module (guix memoization) |
| 31 | #:use-module (srfi srfi-1) |
| 32 | #:use-module (srfi srfi-9) |
| 33 | #:use-module (srfi srfi-9 gnu) |
| 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 | #:autoload (ice-9 rdelim) (read-string) |
| 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 | |
| 54 | build? |
| 55 | build |
| 56 | build-derivation |
| 57 | build-system |
| 58 | build-log-file |
| 59 | build-phase |
| 60 | build-completion |
| 61 | |
| 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 | |
| 76 | with-status-report |
| 77 | with-status-verbosity)) |
| 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? |
| 97 | (building build-status-building ;list of <build> |
| 98 | (default '())) |
| 99 | (downloading build-status-downloading ;list of <download> |
| 100 | (default '())) |
| 101 | (builds-completed build-status-builds-completed ;list of <build> |
| 102 | (default '())) |
| 103 | (downloads-completed build-status-downloads-completed ;list of <download> |
| 104 | (default '()))) |
| 105 | |
| 106 | ;; On-going or completed build. |
| 107 | (define-immutable-record-type <build> |
| 108 | (%build derivation id system log-file phase completion) |
| 109 | build? |
| 110 | (derivation build-derivation) ;string (.drv file name) |
| 111 | (id build-id) ;#f | integer |
| 112 | (system build-system) ;string |
| 113 | (log-file build-log-file) ;#f | string |
| 114 | (phase build-phase ;#f | symbol |
| 115 | set-build-phase) |
| 116 | (completion build-completion ;#f | integer (percentage) |
| 117 | set-build-completion)) |
| 118 | |
| 119 | (define* (build derivation system #:key id log-file phase completion) |
| 120 | "Return a new build." |
| 121 | (%build derivation id system log-file phase completion)) |
| 122 | |
| 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 | |
| 142 | (define (matching-build drv) |
| 143 | "Return a predicate that matches builds of DRV." |
| 144 | (lambda (build) |
| 145 | (string=? drv (build-derivation build)))) |
| 146 | |
| 147 | (define (matching-download item) |
| 148 | "Return a predicate that matches downloads of ITEM." |
| 149 | (lambda (download) |
| 150 | (string=? item (download-item download)))) |
| 151 | |
| 152 | (define %phase-start-rx |
| 153 | ;; Match the "starting phase" message emitted by 'gnu-build-system'. |
| 154 | (make-regexp "^starting phase [`']([^']+)'")) |
| 155 | |
| 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." |
| 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) |
| 180 | (building (cons (set-build-completion build %) |
| 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)))))) |
| 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)))) |
| 210 | (else |
| 211 | status))) |
| 212 | |
| 213 | (define* (compute-status event status |
| 214 | #:key |
| 215 | (current-time current-time) |
| 216 | (derivation-path->output-path |
| 217 | derivation-path->output-path)) |
| 218 | "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), |
| 219 | compute a new status based on STATUS." |
| 220 | (match event |
| 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)))))) |
| 232 | (((or 'build-succeeded 'build-failed) drv _ ...) |
| 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))) |
| 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) |
| 255 | (building (remove (lambda (build) |
| 256 | (let ((drv (build-derivation build))) |
| 257 | (equal? (false-if-exception |
| 258 | (derivation-path->output-path drv)) |
| 259 | item))) |
| 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))))) |
| 314 | (('build-log (? integer? pid) line) |
| 315 | (update-build status pid line)) |
| 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 | |
| 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 | |
| 342 | (define spin! |
| 343 | (let ((steps (circular-list "\\" "|" "/" "-"))) |
| 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." |
| 347 | (when (isatty?* port) |
| 348 | (match steps |
| 349 | ((first . rest) |
| 350 | (set! steps rest) |
| 351 | (display "\r\x1b[K" port) |
| 352 | (display first port) |
| 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)) |
| 359 | (force-output port))))))) |
| 360 | |
| 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) |
| 369 | ("^(.*)(error|fail|failed|\\<FAIL|FAILED)([[:blank:]]*)(:)(.*)" |
| 370 | RESET RED BOLD BOLD BOLD) |
| 371 | ("^(.*)(warning)([[:blank:]]*)(:)(.*)" |
| 372 | RESET MAGENTA BOLD BOLD BOLD))) |
| 373 | |
| 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...")) |
| 395 | ('texlive-configuration |
| 396 | (G_ "building TeX Live configuration...")) |
| 397 | ('manual-database |
| 398 | (G_ "building database for manual pages...")) |
| 399 | ('package-cache ;package cache generated by 'guix pull' |
| 400 | (G_ "building package cache...")) |
| 401 | (_ #f))) |
| 402 | |
| 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? |
| 413 | (cute colorize-string <> (color BOLD)) |
| 414 | identity)) |
| 415 | |
| 416 | (define success |
| 417 | (if colorize? |
| 418 | (cute colorize-string <> (color GREEN BOLD)) |
| 419 | identity)) |
| 420 | |
| 421 | (define failure |
| 422 | (if colorize? |
| 423 | (cute colorize-string <> (color RED BOLD)) |
| 424 | identity)) |
| 425 | |
| 426 | (define (report-build-progress phase %) |
| 427 | (let ((% (min (max % 0) 100))) ;sanitize |
| 428 | (erase-current-line port) |
| 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)) |
| 438 | (force-output port))) |
| 439 | |
| 440 | (define print-log-line |
| 441 | (if print-log? |
| 442 | (if colorize? |
| 443 | (lambda (id line) |
| 444 | (display (colorize-log-line line) port)) |
| 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) |
| 451 | ((? number? %) |
| 452 | (report-build-progress (build-phase build) %)) |
| 453 | (_ |
| 454 | (spin! (build-phase build) port)))) |
| 455 | (_ |
| 456 | (spin! #f port)))))) |
| 457 | |
| 458 | (define erase-current-line* |
| 459 | (if (and (not print-log?) (isatty?* port)) |
| 460 | (lambda () |
| 461 | (erase-current-line port) |
| 462 | (force-output port)) |
| 463 | (const #t))) |
| 464 | |
| 465 | (match event |
| 466 | (('build-started drv . _) |
| 467 | (erase-current-line*) |
| 468 | (let ((properties (derivation-properties |
| 469 | (read-derivation-from-file drv)))) |
| 470 | (match (assq-ref properties 'type) |
| 471 | ('graft |
| 472 | (let ((count (match (assq-ref properties 'graft) |
| 473 | (#f 0) |
| 474 | (lst (or (assq-ref lst 'count) 0))))) |
| 475 | (format port (info (N_ "applying ~a graft for ~a..." |
| 476 | "applying ~a grafts for ~a..." |
| 477 | count)) |
| 478 | count drv))) |
| 479 | ('profile-hook |
| 480 | (let ((hook-type (assq-ref properties 'hook))) |
| 481 | (or (and=> (hook-message hook-type) |
| 482 | (lambda (msg) |
| 483 | (format port (info msg)))) |
| 484 | (format port (info (G_ "running profile hook of type '~a'...")) |
| 485 | hook-type)))) |
| 486 | (_ |
| 487 | (format port (info (G_ "building ~a...")) drv)))) |
| 488 | (newline port)) |
| 489 | (('build-succeeded drv . _) |
| 490 | (erase-current-line*) ;erase spinner or progress bar |
| 491 | (when (or print-log? (not (extended-build-trace-supported?))) |
| 492 | (format port (success (G_ "successfully built ~a")) drv) |
| 493 | (newline port)) |
| 494 | (match (build-status-building status) |
| 495 | (() #t) |
| 496 | (ongoing ;when max-jobs > 1 |
| 497 | (format port |
| 498 | (N_ "The following build is still in progress:~%~{ ~a~%~}~%" |
| 499 | "The following builds are still in progress:~%~{ ~a~%~}~%" |
| 500 | (length ongoing)) |
| 501 | (map build-derivation ongoing))))) |
| 502 | (('build-failed drv . _) |
| 503 | (erase-current-line*) ;erase spinner or progress bar |
| 504 | (format port (failure (G_ "build of ~a failed")) drv) |
| 505 | (newline port) |
| 506 | (match (derivation-log-file drv) |
| 507 | (#f |
| 508 | (format port (failure (G_ "Could not find build log for '~a'.")) |
| 509 | drv)) |
| 510 | (log |
| 511 | (format port (info (G_ "View build log at '~a'.")) log))) |
| 512 | (newline port)) |
| 513 | (('substituter-started item _ ...) |
| 514 | (erase-current-line*) |
| 515 | (when (or print-log? (not (extended-build-trace-supported?))) |
| 516 | (format port (info (G_ "substituting ~a...")) item) |
| 517 | (newline port))) |
| 518 | (('download-started item uri _ ...) |
| 519 | (erase-current-line*) |
| 520 | (format port (info (G_ "downloading from ~a...")) uri) |
| 521 | (newline port)) |
| 522 | (('download-progress item uri |
| 523 | (= string->number size) |
| 524 | (= string->number transferred)) |
| 525 | ;; Print a progress bar, but only if there's only one on-going |
| 526 | ;; job--otherwise the output would be intermingled. |
| 527 | (when (= 1 (simultaneous-jobs status)) |
| 528 | (match (find (matching-download item) |
| 529 | (build-status-downloading status)) |
| 530 | (#f #f) ;shouldn't happen! |
| 531 | (download |
| 532 | ;; XXX: It would be nice to memoize the abbreviation. |
| 533 | (let ((uri (if (string-contains uri "/nar/") |
| 534 | (nar-uri-abbreviation uri) |
| 535 | (basename uri)))) |
| 536 | (display-download-progress uri size |
| 537 | #:start-time |
| 538 | (download-start download) |
| 539 | #:transferred transferred)))))) |
| 540 | (('substituter-succeeded item _ ...) |
| 541 | ;; If there are no jobs running, we already reported download completion |
| 542 | ;; so there's nothing left to do. |
| 543 | (unless (and (zero? (simultaneous-jobs status)) |
| 544 | (extended-build-trace-supported?)) |
| 545 | (format port (success (G_ "substitution of ~a complete")) item) |
| 546 | (newline port))) |
| 547 | (('substituter-failed item _ ...) |
| 548 | (format port (failure (G_ "substitution of ~a failed")) item) |
| 549 | (newline port)) |
| 550 | (('hash-mismatch item algo expected actual _ ...) |
| 551 | ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for |
| 552 | ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. |
| 553 | (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) |
| 554 | (newline port) |
| 555 | (format port (info (G_ "\ |
| 556 | expected hash: ~a |
| 557 | actual hash: ~a~%")) |
| 558 | expected actual)) |
| 559 | (('build-remote drv host _ ...) |
| 560 | (format port (info (G_ "offloading build of ~a to '~a'")) drv host) |
| 561 | (newline port)) |
| 562 | (('build-log pid line) |
| 563 | (if (multiplexed-output-supported?) |
| 564 | (if (not pid) |
| 565 | (begin |
| 566 | ;; LINE comes from the daemon, not from builders. Let it |
| 567 | ;; through. |
| 568 | (display line port) |
| 569 | (force-output port)) |
| 570 | (print-log-line pid line)) |
| 571 | (cond ((string-prefix? "substitute: " line) |
| 572 | ;; The daemon prefixes early messages coming with 'guix |
| 573 | ;; substitute' with "substitute:". These are useful ("updating |
| 574 | ;; substitutes from URL"), so let them through. |
| 575 | (display line port) |
| 576 | (force-output port)) |
| 577 | ((string-prefix? "waiting for locks" line) |
| 578 | ;; This is when a derivation is already being built and we're just |
| 579 | ;; waiting for the build to complete. |
| 580 | (display (info (string-trim-right line)) port) |
| 581 | (newline)) |
| 582 | (else |
| 583 | (print-log-line pid line))))) |
| 584 | (_ |
| 585 | event))) |
| 586 | |
| 587 | (define* (print-build-event/quiet event old-status status |
| 588 | #:optional |
| 589 | (port (current-error-port)) |
| 590 | #:key |
| 591 | (colorize? (color-output? port))) |
| 592 | (print-build-event event old-status status port |
| 593 | #:colorize? colorize? |
| 594 | #:print-log? #f)) |
| 595 | |
| 596 | (define* (build-status-updater #:optional (on-change (const #t))) |
| 597 | "Return a procedure that can be passed to 'build-event-output-port'. That |
| 598 | procedure computes the new build status upon each event and calls ON-CHANGE: |
| 599 | |
| 600 | (ON-CHANGE event status new-status) |
| 601 | |
| 602 | ON-CHANGE can display the build status, build events, etc." |
| 603 | (lambda (event status) |
| 604 | (let ((new (compute-status event status))) |
| 605 | (on-change event status new) |
| 606 | new))) |
| 607 | |
| 608 | \f |
| 609 | ;;; |
| 610 | ;;; Build port. |
| 611 | ;;; |
| 612 | |
| 613 | (define (maybe-utf8->string bv) |
| 614 | "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the |
| 615 | case where BV does not contain only valid UTF-8." |
| 616 | (catch 'decoding-error |
| 617 | (lambda () |
| 618 | (utf8->string bv)) |
| 619 | (lambda _ |
| 620 | ;; This is the sledgehammer but it's the only safe way we have to |
| 621 | ;; properly handle this. It's expensive but it's rarely needed. |
| 622 | (let ((port (open-bytevector-input-port bv))) |
| 623 | (set-port-encoding! port "UTF-8") |
| 624 | (set-port-conversion-strategy! port 'substitute) |
| 625 | (let ((str (read-string port))) |
| 626 | (close-port port) |
| 627 | str))))) |
| 628 | |
| 629 | (define (bytevector-index bv number offset count) |
| 630 | "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes; |
| 631 | return the offset where NUMBER first occurs or #f if it could not be found." |
| 632 | (let loop ((offset offset) |
| 633 | (count count)) |
| 634 | (cond ((zero? count) #f) |
| 635 | ((= (bytevector-u8-ref bv offset) number) offset) |
| 636 | (else (loop (+ 1 offset) (- count 1)))))) |
| 637 | |
| 638 | (define (split-lines str) |
| 639 | "Split STR into lines in a way that preserves newline characters." |
| 640 | (let loop ((str str) |
| 641 | (result '())) |
| 642 | (if (string-null? str) |
| 643 | (reverse result) |
| 644 | (match (string-index str #\newline) |
| 645 | (#f |
| 646 | (loop "" (cons str result))) |
| 647 | (index |
| 648 | (loop (string-drop str (+ index 1)) |
| 649 | (cons (string-take str (+ index 1)) result))))))) |
| 650 | |
| 651 | (define* (build-event-output-port proc #:optional (seed (build-status))) |
| 652 | "Return an output port for use as 'current-build-output-port' that calls |
| 653 | PROC with its current state value, initialized with SEED, on every build |
| 654 | event. Build events passed to PROC are tuples corresponding to the \"build |
| 655 | traces\" produced by the daemon: |
| 656 | |
| 657 | (build-started \"/gnu/store/...-foo.drv\" ...) |
| 658 | (substituter-started \"/gnu/store/...-foo\" ...) |
| 659 | |
| 660 | and so on. |
| 661 | |
| 662 | The second return value is a thunk to retrieve the current state." |
| 663 | (define %fragments |
| 664 | ;; Line fragments received so far. |
| 665 | '()) |
| 666 | |
| 667 | (define %state |
| 668 | ;; Current state for PROC. |
| 669 | seed) |
| 670 | |
| 671 | ;; When true, this represents the current state while reading a |
| 672 | ;; "@ build-log" trace: the current builder PID, the previously-read |
| 673 | ;; bytevectors, and the number of bytes that remain to be read. |
| 674 | (define %build-output-pid #f) |
| 675 | (define %build-output '()) |
| 676 | (define %build-output-left #f) |
| 677 | |
| 678 | (define (process-line line) |
| 679 | (cond ((string-prefix? "@ " line) |
| 680 | ;; Note: Drop the trailing \n, and use 'string-split' to preserve |
| 681 | ;; spaces (the log file part of 'build-started' events can be the |
| 682 | ;; empty string.) |
| 683 | (match (string-split (string-drop (string-drop-right line 1) 2) |
| 684 | #\space) |
| 685 | (("build-log" (= string->number pid) (= string->number len)) |
| 686 | (set! %build-output-pid pid) |
| 687 | (set! %build-output '()) |
| 688 | (set! %build-output-left len)) |
| 689 | (((= string->symbol event-name) args ...) |
| 690 | (set! %state |
| 691 | (proc (cons event-name args) |
| 692 | %state))))) |
| 693 | (else |
| 694 | (set! %state (proc (list 'build-log #f line) |
| 695 | %state))))) |
| 696 | |
| 697 | (define (process-build-output pid output) |
| 698 | ;; Transform OUTPUT in 'build-log' events or download events as generated |
| 699 | ;; by extended build traces. |
| 700 | (define (line->event line) |
| 701 | (match (and (string-prefix? "@ " line) |
| 702 | (string-tokenize (string-drop line 2))) |
| 703 | ((type . args) |
| 704 | (if (or (string-prefix? "download-" type) |
| 705 | (string=? "build-remote" type)) |
| 706 | (cons (string->symbol type) args) |
| 707 | `(build-log ,pid ,line))) |
| 708 | (_ |
| 709 | `(build-log ,pid ,line)))) |
| 710 | |
| 711 | (let* ((lines (split-lines output)) |
| 712 | (events (map line->event lines))) |
| 713 | (set! %state (fold proc %state events)))) |
| 714 | |
| 715 | (define (bytevector-range bv offset count) |
| 716 | (let ((ptr (bytevector->pointer bv offset))) |
| 717 | (pointer->bytevector ptr count))) |
| 718 | |
| 719 | (define (write! bv offset count) |
| 720 | (if %build-output-pid |
| 721 | (let ((keep (min count %build-output-left))) |
| 722 | (set! %build-output |
| 723 | (let ((bv* (make-bytevector keep))) |
| 724 | (bytevector-copy! bv offset bv* 0 keep) |
| 725 | (cons bv* %build-output))) |
| 726 | (set! %build-output-left |
| 727 | (- %build-output-left keep)) |
| 728 | |
| 729 | (when (zero? %build-output-left) |
| 730 | (process-build-output %build-output-pid |
| 731 | (string-concatenate-reverse |
| 732 | (map maybe-utf8->string %build-output))) ;XXX |
| 733 | (set! %build-output '()) |
| 734 | (set! %build-output-pid #f)) |
| 735 | keep) |
| 736 | (match (bytevector-index bv (char->integer #\newline) |
| 737 | offset count) |
| 738 | ((? integer? cr) |
| 739 | (let* ((tail (maybe-utf8->string |
| 740 | (bytevector-range bv offset (- cr -1 offset)))) |
| 741 | (line (string-concatenate-reverse |
| 742 | (cons tail %fragments)))) |
| 743 | (process-line line) |
| 744 | (set! %fragments '()) |
| 745 | (- cr -1 offset))) |
| 746 | (#f |
| 747 | (unless (zero? count) |
| 748 | (let ((str (maybe-utf8->string |
| 749 | (bytevector-range bv offset count)))) |
| 750 | (set! %fragments (cons str %fragments)))) |
| 751 | count)))) |
| 752 | |
| 753 | (define port |
| 754 | (make-custom-binary-output-port "filtering-input-port" |
| 755 | write! |
| 756 | #f #f |
| 757 | #f)) |
| 758 | |
| 759 | ;; The build port actually receives Unicode strings. |
| 760 | (set-port-encoding! port "UTF-8") |
| 761 | (setvbuf port 'line) |
| 762 | (values port (lambda () %state))) |
| 763 | |
| 764 | (define (call-with-status-report on-event thunk) |
| 765 | (parameterize ((current-terminal-columns (terminal-columns)) |
| 766 | (current-build-output-port |
| 767 | (build-event-output-port (build-status-updater on-event)))) |
| 768 | (thunk))) |
| 769 | |
| 770 | (define-syntax-rule (with-status-report on-event exp ...) |
| 771 | "Set up build status reporting to the user using the ON-EVENT procedure; |
| 772 | evaluate EXP... in that context." |
| 773 | (call-with-status-report on-event (lambda () exp ...))) |
| 774 | |
| 775 | (define (logger-for-level level) |
| 776 | "Return the logging procedure that corresponds to LEVEL." |
| 777 | (cond ((<= level 0) (const #t)) |
| 778 | ((= level 1) print-build-event/quiet) |
| 779 | (else print-build-event))) |
| 780 | |
| 781 | (define (call-with-status-verbosity level thunk) |
| 782 | (call-with-status-report (logger-for-level level) thunk)) |
| 783 | |
| 784 | (define-syntax-rule (with-status-verbosity level exp ...) |
| 785 | "Set up build status reporting to the user at the given LEVEL: 0 means |
| 786 | silent, 1 means quiet, 2 means verbose. Evaluate EXP... in that context." |
| 787 | (call-with-status-verbosity level (lambda () exp ...))) |