From e54aec7b8e5ef1aa53df043e3c0b06f25d2936a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Oct 2018 10:52:39 +0200 Subject: pull: '-l' now honors '-p'. * guix/scripts/pull.scm (process-query): Add 'profile' parameter and remove 'profile' local variable. (guix-pull): Adjust caller. --- guix/scripts/pull.scm | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'guix/scripts/pull.scm') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 803f7cf14..0d65857be 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -341,11 +341,8 @@ and ALIST2 differ, display HEADING upfront." (display-new/upgraded-packages (package-alist gen1) (package-alist gen2))) -(define (process-query opts) - "Process any query specified by OPTS." - (define profile - (string-append (config-directory) "/current")) - +(define (process-query opts profile) + "Process any query on PROFILE specified by OPTS." (match (assoc-ref opts 'query) (('list-generations pattern) (define (list-generations profile numbers) @@ -445,7 +442,7 @@ Use '~/.config/guix/channels.scm' instead.")) (string-append (config-directory) "/current")))) (cond ((assoc-ref opts 'query) - (process-query opts)) + (process-query opts profile)) ((assoc-ref opts 'dry-run?) #t) ;XXX: not very useful (else -- cgit v1.3 From 795d430d90e41eb172315bfccf79c9f13fc0ebfa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Oct 2018 11:51:44 +0200 Subject: pull: Turn ~/.config/guix/current into a symlink to /var/guix/profiles. This is more consistent with what 'guix package' does, more pleasant for users (we no longer clobber ~/.config/guix), and more cluster-friendly (since /var/guix/profiles is usually an NFS share already.) * guix/scripts/pull.scm (%current-profile, %user-profile-directory): New variables. (migrate-generations, ensure-default-profile): New procedures. (guix-pull): Use %CURRENT-PROFILE by default. Call 'ensure-default-profile'. * doc/guix.texi (Invoking guix pull): Adjust 'guix package -p ~/.config/guix/current' example. * guix/scripts.scm (warn-about-old-distro): Check %PROFILE-DIRECTORY "/current-guix". --- doc/guix.texi | 2 +- guix/scripts.scm | 4 ++-- guix/scripts/pull.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 52 insertions(+), 6 deletions(-) (limited to 'guix/scripts/pull.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 9b37270a8..5ae80917a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2831,7 +2831,7 @@ generation---i.e., the previous Guix---and so on: $ guix package -p ~/.config/guix/current --roll-back switched from generation 3 to 2 $ guix package -p ~/.config/guix/current --delete-generations=1 -deleting /home/charlie/.config/guix/current-1-link +deleting /var/guix/profiles/per-user/charlie/current-guix-1-link @end example The @command{guix pull} command is usually invoked with no arguments, diff --git a/guix/scripts.scm b/guix/scripts.scm index 4cbbbeb96..98751bc81 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -26,6 +26,7 @@ #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module ((guix profiles) #:select (%profile-directory)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-37) @@ -169,8 +170,7 @@ Show what and how will/would be built." (define age (match (false-if-not-found - (lstat (string-append (config-directory #:ensure? #f) - "/current"))) + (lstat (string-append %profile-directory "/current-guix"))) (#f #f) (stat (- (time-second (current-time time-utc)) (stat:mtime stat))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 0d65857be..5fecc11de 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -225,6 +225,53 @@ Download and deploy the latest version of Guix.\n")) (lambda (key err) (report-git-error err)))) + +;;; +;;; Profile. +;;; + +(define %current-profile + ;; The "real" profile under /var/guix. + (string-append %profile-directory "/current-guix")) + +(define %user-profile-directory + ;; The user-friendly name of %CURRENT-PROFILE. + (string-append (config-directory #:ensure? #f) "/current")) + +(define (migrate-generations profile directory) + "Migration the generations of PROFILE to DIRECTORY." + (format (current-error-port) + (G_ "Migrating profile generations to '~a'...~%") + %profile-directory) + (for-each (lambda (generation) + (let ((source (generation-file-name profile generation)) + (target (string-append directory "/current-guix-" + (number->string generation) + "-link"))) + (rename-file source target))) + (profile-generations profile))) + +(define (ensure-default-profile) + (ensure-profile-directory) + + ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move + ;; them to %PROFILE-DIRECTORY. + (unless (string=? %profile-directory + (dirname (canonicalize-profile %user-profile-directory))) + (migrate-generations %user-profile-directory %profile-directory)) + + ;; Make sure ~/.config/guix/current points to /var/guix/profiles/…. + (let ((link %user-profile-directory)) + (unless (equal? (false-if-exception (readlink link)) + %current-profile) + (catch 'system-error + (lambda () + (false-if-exception (delete-file link)) + (symlink %current-profile link)) + (lambda args + (leave (G_ "while creating symlink '~a': ~a~%") + link (strerror (system-error-errno args)))))))) + ;;; ;;; Queries. @@ -438,9 +485,8 @@ Use '~/.config/guix/channels.scm' instead.")) (list %default-options))) (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) - (profile (or (assoc-ref opts 'profile) - (string-append (config-directory) "/current")))) - + (profile (or (assoc-ref opts 'profile) %current-profile))) + (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) ((assoc-ref opts 'dry-run?) -- cgit v1.3 From 8155a209071f981fbf359975f463be4bcf8fa23e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Oct 2018 23:53:18 +0200 Subject: pull: Create /var/guix/profiles/per-user/USER/current-guix. Previously the migration code would fail to create that file, so ~/.config/guix/current would be dangling. * guix/scripts/pull.scm (migrate-generations): Create /var/guix/profiles/per-user/USER/current-guix. --- guix/scripts/pull.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) (limited to 'guix/scripts/pull.scm') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 5fecc11de..8e0595076 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -243,13 +243,17 @@ Download and deploy the latest version of Guix.\n")) (format (current-error-port) (G_ "Migrating profile generations to '~a'...~%") %profile-directory) - (for-each (lambda (generation) - (let ((source (generation-file-name profile generation)) - (target (string-append directory "/current-guix-" - (number->string generation) - "-link"))) - (rename-file source target))) - (profile-generations profile))) + (let ((current (basename + (generation-file-name profile + (generation-number profile))))) + (for-each (lambda (generation) + (let ((source (generation-file-name profile generation)) + (target (string-append directory "/current-guix-" + (number->string generation) + "-link"))) + (rename-file source target))) + (profile-generations profile)) + (symlink current (string-append directory "/current-guix")))) (define (ensure-default-profile) (ensure-profile-directory) -- cgit v1.3 From 8036b0942b89022147aaf9cd9940988fdbcc19ef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Oct 2018 15:11:50 +0200 Subject: pull: Don't use rename(2) across potentially different devices. Reported by Formbi on #guix. * guix/scripts/pull.scm (migrate-generations): Use 'symlink' and 'delete-file' instead of 'rename-file'. The latter could lead to EXDEV when $HOME and /var were different partitions. --- guix/scripts/pull.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix/scripts/pull.scm') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 8e0595076..660a2b911 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -239,7 +239,7 @@ Download and deploy the latest version of Guix.\n")) (string-append (config-directory #:ensure? #f) "/current")) (define (migrate-generations profile directory) - "Migration the generations of PROFILE to DIRECTORY." + "Migrate the generations of PROFILE to DIRECTORY." (format (current-error-port) (G_ "Migrating profile generations to '~a'...~%") %profile-directory) @@ -251,7 +251,10 @@ Download and deploy the latest version of Guix.\n")) (target (string-append directory "/current-guix-" (number->string generation) "-link"))) - (rename-file source target))) + ;; Note: Don't use 'rename-file' as SOURCE and TARGET might + ;; live on different file systems. + (symlink (readlink source) target) + (delete-file source))) (profile-generations profile)) (symlink current (string-append directory "/current-guix")))) -- cgit v1.3 From aa227b3be3d7728331a08dbd139c47c9b271dc23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Oct 2018 16:43:18 +0200 Subject: pull: Fix target of /var/guix/profiles/per-user/USER/current-guix. This is a followup to 8155a209071f981fbf359975f463be4bcf8fa23e. * guix/scripts/pull.scm (migrate-generations): Compute the right target for /var/guix/profiles/per-user/USER/current-guix. Previously we'd return "current-N-link" instead of "current-guix-N-link'. --- guix/scripts/pull.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix/scripts/pull.scm') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 660a2b911..d3fd62422 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -243,9 +243,7 @@ Download and deploy the latest version of Guix.\n")) (format (current-error-port) (G_ "Migrating profile generations to '~a'...~%") %profile-directory) - (let ((current (basename - (generation-file-name profile - (generation-number profile))))) + (let ((current (generation-number profile))) (for-each (lambda (generation) (let ((source (generation-file-name profile generation)) (target (string-append directory "/current-guix-" @@ -256,7 +254,9 @@ Download and deploy the latest version of Guix.\n")) (symlink (readlink source) target) (delete-file source))) (profile-generations profile)) - (symlink current (string-append directory "/current-guix")))) + (symlink (string-append "current-guix-" + (number->string current) "-link") + (string-append directory "/current-guix")))) (define (ensure-default-profile) (ensure-profile-directory) -- cgit v1.3 From f9a8fce10f2d99efec7cb1dd0f6c5f0df9d1b2df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Oct 2018 23:06:55 +0200 Subject: status: Build upon multiplexed build output. This allows for more accurate status tracking and parsing of extended build traces. * guix/status.scm (multiplexed-output-supported?): New procedure. (print-build-event): Don't print \r when PRINT-LOG? is true. Adjust 'build-log' handling for when 'multiplexed-output-supported?' returns true. (bytevector-index, split-lines): New procedures. (build-event-output-port)[%build-output-pid, %build-output] [%build-output-left]: New variables. [process-line]: Handle "@ build-output" traces. [process-build-output]: New procedure. [write!]: Add case for when %BUILD-OUTPUT-PID is true. Use 'bytevector-index' rather than 'string-index'. (compute-status): Add #:derivation-path->output-path. Use it. * tests/status.scm ("compute-status, multiplexed build output"): New test. ("build-output-port, UTF-8") ("current-build-output-port, UTF-8 + garbage"): Adjust to new 'build-log' output. * guix/scripts/build.scm (set-build-options-from-command-line): Pass #:multiplexed-build-output?. (%default-options): Add 'multiplexed-build-output?'. * guix/scripts/environment.scm (%default-options): Likewise. * guix/scripts/pack.scm (%default-options): Likewise. * guix/scripts/package.scm (%default-options): Likewise. * guix/scripts/pull.scm (%default-options): Likewise. * guix/scripts/system.scm (%default-options): Likewise. --- guix/scripts/build.scm | 3 + guix/scripts/environment.scm | 1 + guix/scripts/pack.scm | 1 + guix/scripts/package.scm | 3 +- guix/scripts/pull.scm | 1 + guix/scripts/system.scm | 1 + guix/status.scm | 169 ++++++++++++++++++++++++++++++++----------- tests/status.scm | 51 ++++++++++++- 8 files changed, 184 insertions(+), 46 deletions(-) (limited to 'guix/scripts/pull.scm') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index f3aa5512d..13978abb7 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -395,6 +395,8 @@ options handled by 'set-build-options-from-command-line', and listed in #:print-build-trace (assoc-ref opts 'print-build-trace?) #:print-extended-build-trace? (assoc-ref opts 'print-extended-build-trace?) + #:multiplexed-build-output? + (assoc-ref opts 'multiplexed-build-output?) #:verbosity (assoc-ref opts 'verbosity))) (define set-build-options-from-command-line* @@ -505,6 +507,7 @@ options handled by 'set-build-options-from-command-line', and listed in (build-hook? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (show-help) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 9fc7edcd3..5965e3426 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -176,6 +176,7 @@ COMMAND or an interactive shell in that environment.\n")) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (tag-package-arg opts arg) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 163f5b1dc..fb3c50521 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -541,6 +541,7 @@ please email '~a'~%") (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0) (symlinks . ()) (compressor . ,(first %compressors)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e588ff81e..5d146b842 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -296,7 +296,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) - (print-extended-build-trace? . #t))) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t))) (define (show-help) (display (G_ "Usage: guix package [OPTION]... diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index d3fd62422..188237aa9 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -64,6 +64,7 @@ (build-hook? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f9d6b9e5b..f9af38b7c 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1082,6 +1082,7 @@ Some ACTIONS support additional ARGS.\n")) (build-hook? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0) (file-system-type . "ext4") diff --git a/guix/status.scm b/guix/status.scm index d8d761dc2..8e05d4eb7 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -116,7 +116,10 @@ (string=? item (download-item download)))) (define* (compute-status event status - #:key (current-time current-time)) + #:key + (current-time current-time) + (derivation-path->output-path + derivation-path->output-path)) "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), compute a new status based on STATUS." (match event @@ -142,8 +145,7 @@ compute a new status based on STATUS." (inherit status) (building (remove (lambda (drv) (equal? (false-if-exception - (derivation->output-path - (read-derivation-from-file drv))) + (derivation-path->output-path drv)) item)) (build-status-building status))) (downloading (cons (download item uri #:size size @@ -219,6 +221,12 @@ build traces\" such as \"@ download-progress\" traces." (and (current-store-protocol-version) (>= (current-store-protocol-version) #x162))) +(define (multiplexed-output-supported?) + "Return true if the daemon supports \"multiplexed output\"--i.e., \"@ +build-log\" traces." + (and (current-store-protocol-version) + (>= (current-store-protocol-version) #x163))) + (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) (lambda (port) @@ -313,7 +321,8 @@ addition to build events." (lambda (line) (spin! port)))) - (display "\r" port) ;erase the spinner + (unless print-log? + (display "\r" port)) ;erase the spinner (match event (('build-started drv . _) (format port (info (G_ "building ~a...")) drv) @@ -384,21 +393,28 @@ addition to build events." expected hash: ~a actual hash: ~a~%")) expected actual)) - (('build-log line) - ;; TODO: Better distinguish daemon messages and build log lines. - (cond ((string-prefix? "substitute: " line) - ;; The daemon prefixes early messages coming with 'guix - ;; substitute' with "substitute:". These are useful ("updating - ;; substitutes from URL"), so let them through. - (format port line) - (force-output port)) - ((string-prefix? "waiting for locks" line) - ;; This is when a derivation is already being built and we're just - ;; waiting for the build to complete. - (display (info (string-trim-right line)) port) - (newline)) - (else - (print-log-line line)))) + (('build-log pid line) + (if (multiplexed-output-supported?) + (if (not pid) + (begin + ;; LINE comes from the daemon, not from builders. Let it + ;; through. + (display line port) + (force-output port)) + (print-log-line line)) + (cond ((string-prefix? "substitute: " line) + ;; The daemon prefixes early messages coming with 'guix + ;; substitute' with "substitute:". These are useful ("updating + ;; substitutes from URL"), so let them through. + (display line port) + (force-output port)) + ((string-prefix? "waiting for locks" line) + ;; This is when a derivation is already being built and we're just + ;; waiting for the build to complete. + (display (info (string-trim-right line)) port) + (newline)) + (else + (print-log-line line))))) (_ event))) @@ -428,9 +444,6 @@ ON-CHANGE can display the build status, build events, etc." ;;; Build port. ;;; -(define %newline - (char-set #\return #\newline)) - (define (maybe-utf8->string bv) "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the case where BV does not contain only valid UTF-8." @@ -447,6 +460,28 @@ case where BV does not contain only valid UTF-8." (close-port port) str))))) +(define (bytevector-index bv number offset count) + "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes; +return the offset where NUMBER first occurs or #f if it could not be found." + (let loop ((offset offset) + (count count)) + (cond ((zero? count) #f) + ((= (bytevector-u8-ref bv offset) number) offset) + (else (loop (+ 1 offset) (- count 1)))))) + +(define (split-lines str) + "Split STR into lines in a way that preserves newline characters." + (let loop ((str str) + (result '())) + (if (string-null? str) + (reverse result) + (match (string-index str #\newline) + (#f + (loop "" (cons str result))) + (index + (loop (string-drop str (+ index 1)) + (cons (string-take str (+ index 1)) result))))))) + (define* (build-event-output-port proc #:optional (seed (build-status))) "Return an output port for use as 'current-build-output-port' that calls PROC with its current state value, initialized with SEED, on every build @@ -467,33 +502,83 @@ The second return value is a thunk to retrieve the current state." ;; Current state for PROC. seed) + ;; When true, this represents the current state while reading a + ;; "@ build-log" trace: the current builder PID, the previously-read + ;; bytevectors, and the number of bytes that remain to be read. + (define %build-output-pid #f) + (define %build-output '()) + (define %build-output-left #f) + (define (process-line line) - (if (string-prefix? "@ " line) - (match (string-tokenize (string-drop line 2)) - (((= string->symbol event-name) args ...) - (set! %state - (proc (cons event-name args) - %state)))) - (set! %state (proc (list 'build-log line) - %state)))) + (cond ((string-prefix? "@ " line) + (match (string-tokenize (string-drop line 2)) + (("build-log" (= string->number pid) (= string->number len)) + (set! %build-output-pid pid) + (set! %build-output '()) + (set! %build-output-left len)) + (((= string->symbol event-name) args ...) + (set! %state + (proc (cons event-name args) + %state))))) + (else + (set! %state (proc (list 'build-log #f line) + %state))))) + + (define (process-build-output pid output) + ;; Transform OUTPUT in 'build-log' events or download events as generated + ;; by extended build traces. + (define (line->event line) + (match (and (string-prefix? "@ " line) + (string-tokenize (string-drop line 2))) + ((type . args) + (if (or (string-prefix? "download-" type) + (string=? "build-remote" type)) + (cons (string->symbol type) args) + `(build-log ,pid ,line))) + (_ + `(build-log ,pid ,line)))) + + (let* ((lines (split-lines output)) + (events (map line->event lines))) + (set! %state (fold proc %state events)))) (define (bytevector-range bv offset count) (let ((ptr (bytevector->pointer bv offset))) (pointer->bytevector ptr count))) (define (write! bv offset count) - (let loop ((str (maybe-utf8->string (bytevector-range bv offset count)))) - (match (string-index str %newline) - ((? integer? cr) - (let ((tail (string-take str (+ 1 cr)))) - (process-line (string-concatenate-reverse - (cons tail %fragments))) - (set! %fragments '()) - (loop (string-drop str (+ 1 cr))))) - (#f - (unless (string-null? str) - (set! %fragments (cons str %fragments))) - count)))) + (if %build-output-pid + (let ((keep (min count %build-output-left))) + (set! %build-output + (let ((bv* (make-bytevector keep))) + (bytevector-copy! bv offset bv* 0 keep) + (cons bv* %build-output))) + (set! %build-output-left + (- %build-output-left keep)) + + (when (zero? %build-output-left) + (process-build-output %build-output-pid + (string-concatenate-reverse + (map maybe-utf8->string %build-output))) ;XXX + (set! %build-output '()) + (set! %build-output-pid #f)) + keep) + (match (bytevector-index bv (char->integer #\newline) + offset count) + ((? integer? cr) + (let* ((tail (maybe-utf8->string + (bytevector-range bv offset (- cr -1 offset)))) + (line (string-concatenate-reverse + (cons tail %fragments)))) + (process-line line) + (set! %fragments '()) + (- cr -1 offset))) + (#f + (unless (zero? count) + (let ((str (maybe-utf8->string + (bytevector-range bv offset count)))) + (set! %fragments (cons str %fragments)))) + count)))) (define port (make-custom-binary-output-port "filtering-input-port" diff --git a/tests/status.scm b/tests/status.scm index 486ad04dd..3b7494667 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -22,7 +22,8 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports)) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) (test-begin "status") @@ -115,7 +116,7 @@ (list first (get-status))))) (test-equal "build-output-port, UTF-8" - '((build-log "lambda is λ!\n")) + '((build-log #f "lambda is λ!\n")) (let-values (((port get-status) (build-event-output-port cons '())) ((bv) (string->utf8 "lambda is λ!\n"))) (put-bytevector port bv) @@ -124,7 +125,7 @@ (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? - '((build-log "garbage: �lambda: λ\n")) + '((build-log #f "garbage: �lambda: λ\n")) (let-values (((port get-status) (build-event-output-port cons '()))) (display "garbage: " port) (put-bytevector port #vu8(128)) @@ -132,4 +133,48 @@ (force-output port) (get-status))) +(test-equal "compute-status, multiplexed build output" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:start 'now)))) + (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 42 + #:start 'now)))) + (build-status + ;; XXX: Should "bar.drv" be present twice? + (builds-completed '("bar.drv" "foo.drv")) + (downloads-completed (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 999 + #:start 'now + #:end 'now))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now) + #:derivation-path->output-path + (match-lambda + ("bar.drv" "bar"))))))) + (display "@ build-started foo.drv 121\n" port) + (display "@ build-started bar.drv 144\n" port) + (display "@ build-log 121 6\nHello!" port) + (display "@ build-log 144 50 +@ download-started bar http://example.org/bar 999\n" port) + (let ((first (get-status))) + (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n") + (display "@ build-log 144 54 +@ download-progress bar http://example.org/bar 999 42\n" + port) + (let ((second (get-status))) + (display "@ download-succeeded bar http://example.org/bar 999\n" port) + (display "@ build-succeeded foo.drv\n" port) + (display "@ build-succeeded bar.drv\n" port) + (list first second (get-status)))))) + (test-end "status") -- cgit v1.3