guix/status.scm

   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 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))
  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-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)
  39   #:autoload   (ice-9 rdelim) (read-string)
  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             build?
  54             build
  55             build-derivation
  56             build-system
  57
  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
  72             with-status-report
  73             with-status-verbosity))
  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?
  93   (building     build-status-building             ;list of <build>
  94                 (default '()))
  95   (downloading  build-status-downloading          ;list of <download>
  96                 (default '()))
  97   (builds-completed build-status-builds-completed ;list of <build>
  98                     (default '()))
  99   (downloads-completed build-status-downloads-completed ;list of <download>
 100                        (default '())))
 101
 102 ;; On-going or completed build.
 103 (define-record-type <build>
 104   (%build derivation id system log-file completion)
 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   (completion  build-completion))               ;#f | integer (percentage)
 111
 112 (define* (build derivation system #:key id log-file completion)
 113   "Return a new build."
 114   (%build derivation id system log-file completion))
 115
 116 ;; On-going or completed downloads.  Downloads can be stem from substitutes
 117 ;; and from "builtin:download" fixed-output derivations.
 118 (define-record-type <download>
 119   (%download item uri size start end transferred)
 120   download?
 121   (item         download-item)            ;store item
 122   (uri          download-uri)             ;string | #f
 123   (size         download-size)            ;integer | #f
 124   (start        download-start)           ;<time>
 125   (end          download-end)             ;#f | <time>
 126   (transferred  download-transferred))    ;integer
 127
 128 (define* (download item uri
 129                    #:key size
 130                    (start (current-time time-monotonic)) end
 131                    (transferred 0))
 132   "Return a new download."
 133   (%download item uri size start end transferred))
 134
 135 (define (matching-build drv)
 136   "Return a predicate that matches builds of DRV."
 137   (lambda (build)
 138     (string=? drv (build-derivation build))))
 139
 140 (define (matching-download item)
 141   "Return a predicate that matches downloads of ITEM."
 142   (lambda (download)
 143     (string=? item (download-item download))))
 144
 145 (define %percentage-line-rx
 146   ;; Things like CMake write lines like "[ 10%] gcc -c …".  This regexp
 147   ;; matches them.
 148   (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]"))
 149
 150 (define %fraction-line-rx
 151   ;; The 'compiled-modules' derivations and Ninja produce reports like
 152   ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]".
 153   ;; This regexp matches these.
 154   (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]"))
 155
 156 (define (update-build status id line)
 157   "Update STATUS based on LINE, a build output line for ID that might contain
 158 a completion indication."
 159   (define (set-completion b %)
 160     (build (build-derivation b)
 161            (build-system b)
 162            #:id (build-id b)
 163            #:log-file (build-log-file b)
 164            #:completion %))
 165
 166   (define (find-build)
 167     (find (lambda (build)
 168             (and (build-id build)
 169                  (= (build-id build) id)))
 170           (build-status-building status)))
 171
 172   (define (update %)
 173     (let ((build (find-build)))
 174       (build-status
 175        (inherit status)
 176        (building (cons (set-completion build %)
 177                        (delq build (build-status-building status)))))))
 178
 179   (cond ((string-any #\nul line)
 180          ;; Don't try to match a regexp here.
 181          status)
 182         ((regexp-exec %percentage-line-rx line)
 183          =>
 184          (lambda (match)
 185            (let ((% (string->number (match:substring match 1))))
 186              (update %))))
 187         ((regexp-exec %fraction-line-rx line)
 188          =>
 189          (lambda (match)
 190            (let ((done  (string->number (match:substring match 1)))
 191                  (total (string->number (match:substring match 3))))
 192              (update (* 100. (/ done total))))))
 193         (else
 194          status)))
 195
 196 (define* (compute-status event status
 197                          #:key
 198                          (current-time current-time)
 199                          (derivation-path->output-path
 200                           derivation-path->output-path))
 201   "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
 202 compute a new status based on STATUS."
 203   (match event
 204     (('build-started drv "-" system log-file . rest)
 205      (let ((build (build drv system
 206                          #:id (match rest
 207                                 ((pid . _) (string->number pid))
 208                                 (_ #f))
 209                          #:log-file (if (string-null? log-file)
 210                                         #f
 211                                         log-file))))
 212        (build-status
 213         (inherit status)
 214         (building (cons build (build-status-building status))))))
 215     (((or 'build-succeeded 'build-failed) drv _ ...)
 216      (let ((build (find (matching-build drv)
 217                         (build-status-building status))))
 218        ;; If BUILD is #f, this may be because DRV corresponds to a
 219        ;; fixed-output derivation that is listed as a download.
 220        (if build
 221            (build-status
 222             (inherit status)
 223             (building (delq build (build-status-building status)))
 224             (builds-completed
 225              (cons build (build-status-builds-completed status))))
 226            status)))
 227
 228     ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
 229     ;; they're not as informative as 'download-started' and
 230     ;; 'download-succeeded'.
 231
 232     (('download-started item uri (= string->number size))
 233      ;; This is presumably a fixed-output derivation so move it from
 234      ;; 'building' to 'downloading'.  XXX: This doesn't work in 'check' mode
 235      ;; because ITEM is different from DRV's output.
 236      (build-status
 237       (inherit status)
 238       (building (remove (lambda (build)
 239                           (let ((drv (build-derivation build)))
 240                             (equal? (false-if-exception
 241                                      (derivation-path->output-path drv))
 242                                     item)))
 243                         (build-status-building status)))
 244       (downloading (cons (download item uri #:size size
 245                                    #:start (current-time time-monotonic))
 246                          (build-status-downloading status)))))
 247     (('download-succeeded item uri (= string->number size))
 248      (let ((current (find (matching-download item)
 249                           (build-status-downloading status))))
 250        (build-status
 251         (inherit status)
 252         (downloading (delq current (build-status-downloading status)))
 253         (downloads-completed
 254          (cons (download item uri
 255                          #:size size
 256                          #:start (download-start current)
 257                          #:transferred size
 258                          #:end (current-time time-monotonic))
 259                (build-status-downloads-completed status))))))
 260     (('substituter-succeeded item _ ...)
 261      (match (find (matching-download item)
 262                   (build-status-downloading status))
 263        (#f
 264         ;; Presumably we already got a 'download-succeeded' event for ITEM,
 265         ;; everything is fine.
 266         status)
 267        (current
 268         ;; Maybe the build process didn't emit a 'download-succeeded' event
 269         ;; for ITEM, so remove CURRENT from the queue now.
 270         (build-status
 271          (inherit status)
 272          (downloading (delq current (build-status-downloading status)))
 273          (downloads-completed
 274           (cons (download item (download-uri current)
 275                           #:size (download-size current)
 276                           #:start (download-start current)
 277                           #:transferred (download-size current)
 278                           #:end (current-time time-monotonic))
 279                 (build-status-downloads-completed status)))))))
 280     (('download-progress item uri
 281                          (= string->number size)
 282                          (= string->number transferred))
 283      (let ((downloads (remove (matching-download item)
 284                               (build-status-downloading status)))
 285            (current   (find (matching-download item)
 286                             (build-status-downloading status))))
 287        (build-status
 288         (inherit status)
 289         (downloading (cons (download item uri
 290                                      #:size size
 291                                      #:start
 292                                      (or (and current
 293                                               (download-start current))
 294                                          (current-time time-monotonic))
 295                                      #:transferred transferred)
 296                            downloads)))))
 297     (('build-log (? integer? pid) line)
 298      (update-build status pid line))
 299     (_
 300      status)))
 301
 302 (define (simultaneous-jobs status)
 303   "Return the number of on-going builds and downloads for STATUS."
 304   (+ (length (build-status-building status))
 305      (length (build-status-downloading status))))
 306
 307 \f
 308 ;;;
 309 ;;; Rendering.
 310 ;;;
 311
 312 (define (extended-build-trace-supported?)
 313   "Return true if the currently used store is known to support \"extended
 314 build traces\" such as \"@ download-progress\" traces."
 315   ;; Support for extended build traces was added in protocol version #x162.
 316   (and (current-store-protocol-version)
 317        (>= (current-store-protocol-version) #x162)))
 318
 319 (define (multiplexed-output-supported?)
 320   "Return true if the daemon supports \"multiplexed output\"--i.e., \"@
 321 build-log\" traces."
 322   (and (current-store-protocol-version)
 323        (>= (current-store-protocol-version) #x163)))
 324
 325 (define isatty?*
 326   (mlambdaq (port)
 327     (isatty? port)))
 328
 329 (define spin!
 330   (let ((steps (circular-list "\\" "|" "/" "-")))
 331     (lambda (port)
 332       "Display a spinner on PORT."
 333       (when (isatty?* port)
 334         (match steps
 335           ((first . rest)
 336            (set! steps rest)
 337            (display "\r\x1b[K" port)
 338            (display first port)
 339            (force-output port)))))))
 340
 341 (define (color-output? port)
 342   "Return true if we should write colored output to PORT."
 343   (and (not (getenv "INSIDE_EMACS"))
 344        (not (getenv "NO_COLOR"))
 345        (isatty?* port)))
 346
 347 (define-syntax color-rules
 348   (syntax-rules ()
 349     "Return a procedure that colorizes the string it is passed according to
 350 the given rules.  Each rule has the form:
 351
 352   (REGEXP COLOR1 COLOR2 ...)
 353
 354 where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
 355 on."
 356     ((_ (regexp colors ...) rest ...)
 357      (let ((next (color-rules rest ...))
 358            (rx   (make-regexp regexp)))
 359        (lambda (str)
 360          (if (string-index str #\nul)
 361              str
 362              (match (regexp-exec rx str)
 363                (#f (next str))
 364                (m  (let loop ((n 1)
 365                               (c '(colors ...))
 366                               (result '()))
 367                      (match c
 368                        (()
 369                         (string-concatenate-reverse result))
 370                        ((first . tail)
 371                         (loop (+ n 1) tail
 372                               (cons (colorize-string (match:substring m n)
 373                                                      first)
 374                                     result)))))))))))
 375     ((_)
 376      (lambda (str)
 377        str))))
 378
 379 (define colorize-log-line
 380   ;; Take a string and return a possibly colorized string according to the
 381   ;; rules below.
 382   (color-rules
 383    ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
 384     GREEN    BOLD GREEN          RESET  GREEN  BLUE)
 385    ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
 386     RED BLUE RED BLUE RED BLUE)
 387    ("^(.*)(error|fail|failed|\\<FAIL|FAILED)([[:blank:]]*)(:)(.*)"
 388     RESET  RED                           BOLD         BOLD BOLD)
 389    ("^(.*)(warning)([[:blank:]]*)(:)(.*)"
 390     RESET  MAGENTA   BOLD        BOLD BOLD)))
 391
 392 (define (hook-message hook-type)
 393   "Return a human-readable string for the profile hook type HOOK-TYPE."
 394   (match hook-type
 395     ('info-dir
 396      (G_ "building directory of Info manuals..."))
 397     ('ghc-package-cache
 398      (G_ "building GHC package cache..."))
 399     ('ca-certificate-bundle
 400      (G_ "building CA certificate bundle..."))
 401     ('glib-schemas
 402      (G_ "generating GLib schema cache..."))
 403     ('gtk-icon-themes
 404      (G_ "creating GTK+ icon theme cache..."))
 405     ('gtk-im-modules
 406      (G_ "building cache files for GTK+ input methods..."))
 407     ('xdg-desktop-database
 408      (G_ "building XDG desktop file cache..."))
 409     ('xdg-mime-database
 410      (G_ "building XDG MIME database..."))
 411     ('fonts-dir
 412      (G_ "building fonts directory..."))
 413     ('texlive-configuration
 414      (G_ "building TeX Live configuration..."))
 415     ('manual-database
 416      (G_ "building database for manual pages..."))
 417     ('package-cache                    ;package cache generated by 'guix pull'
 418      (G_ "building package cache..."))
 419     (_ #f)))
 420
 421 (define* (print-build-event event old-status status
 422                             #:optional (port (current-error-port))
 423                             #:key
 424                             (colorize? (color-output? port))
 425                             (print-log? #t))
 426   "Print information about EVENT and STATUS to PORT.  When COLORIZE? is true,
 427 produce colorful output.  When PRINT-LOG? is true, display the build log in
 428 addition to build events."
 429   (define info
 430     (if colorize?
 431         (cut colorize-string <> 'BOLD)
 432         identity))
 433
 434   (define success
 435     (if colorize?
 436         (cut colorize-string <> 'GREEN 'BOLD)
 437         identity))
 438
 439   (define failure
 440     (if colorize?
 441         (cut colorize-string <> 'RED 'BOLD)
 442         identity))
 443
 444   (define (report-build-progress %)
 445     (let ((% (min (max % 0) 100)))                ;sanitize
 446       (erase-current-line port)
 447       (format port "~3d% " (inexact->exact (round %)))
 448       (display (progress-bar % (- (current-terminal-columns) 5))
 449                port)
 450       (force-output port)))
 451
 452   (define print-log-line
 453     (if print-log?
 454         (if colorize?
 455             (lambda (id line)
 456               (display (colorize-log-line line) port))
 457             (lambda (id line)
 458               (display line port)))
 459         (lambda (id line)
 460           (match (build-status-building status)
 461             ((build)                              ;single job
 462              (match (build-completion build)
 463                ((? number? %) (report-build-progress %))
 464                (_ (spin! port))))
 465             (_
 466              (spin! port))))))
 467
 468   (unless print-log?
 469     (display "\r" port))                          ;erase the spinner
 470   (match event
 471     (('build-started drv . _)
 472      (let ((properties (derivation-properties
 473                         (read-derivation-from-file drv))))
 474        (match (assq-ref properties 'type)
 475          ('graft
 476            (let ((count (match (assq-ref properties 'graft)
 477                           (#f  0)
 478                           (lst (or (assq-ref lst 'count) 0)))))
 479              (format port (info (N_ "applying ~a graft for ~a..."
 480                                     "applying ~a grafts for ~a..."
 481                                     count))
 482                      count drv)))
 483          ('profile-hook
 484           (let ((hook-type (assq-ref properties 'hook)))
 485             (or (and=> (hook-message hook-type)
 486                        (lambda (msg)
 487                          (format port (info msg))))
 488                 (format port (info (G_ "running profile hook of type '~a'..."))
 489                         hook-type))))
 490          (_
 491           (format port (info (G_ "building ~a...")) drv))))
 492      (newline port))
 493     (('build-succeeded drv . _)
 494      (when (or print-log? (not (extended-build-trace-supported?)))
 495        (format port (success (G_ "successfully built ~a")) drv)
 496        (newline port))
 497      (match (build-status-building status)
 498        (() #t)
 499        (ongoing                                   ;when max-jobs > 1
 500         (format port
 501                 (N_ "The following build is still in progress:~%~{  ~a~%~}~%"
 502                     "The following builds are still in progress:~%~{  ~a~%~}~%"
 503                     (length ongoing))
 504                 (map build-derivation ongoing)))))
 505     (('build-failed drv . _)
 506      (format port (failure (G_ "build of ~a failed")) drv)
 507      (newline port)
 508      (match (derivation-log-file drv)
 509        (#f
 510         (format port (failure (G_ "Could not find build log for '~a'."))
 511                 drv))
 512        (log
 513         (format port (info (G_ "View build log at '~a'.")) log)))
 514      (newline port))
 515     (('substituter-started item _ ...)
 516      (when (or print-log? (not (extended-build-trace-supported?)))
 517        (format port (info (G_ "substituting ~a...")) item)
 518        (newline port)))
 519     (('download-started item uri _ ...)
 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 ...)))