[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
From: |
Ludovic Courtès |
Date: |
Mon, 22 Jan 2018 04:35:10 -0500 (EST) |
branch: master
commit 1f701262e1a4a706a341b820796ba31954e1be11
Author: Ludovic Courtès <address@hidden>
Date: Mon Jan 22 10:11:37 2018 +0100
Monitor and report build events.
* src/cuirass/base.scm (%newline): New variable.
(build-event-output-port, handle-build-event): New procedures.
(build-packages): Use 'handle-build-event'.
---
src/cuirass/base.scm | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++--
1 file changed, 93 insertions(+), 2 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 960a5e7..ad45b20 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -1,5 +1,5 @@
;;; base.scm -- Cuirass base module
-;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <address@hidden>
;;; Copyright © 2016, 2017 Mathieu Lirzin <address@hidden>
;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
@@ -27,6 +27,7 @@
#:use-module (guix store)
#:use-module (guix git)
#:use-module (git)
+ #:use-module (ice-9 binary-ports)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
@@ -38,6 +39,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (rnrs bytevectors)
#:export (;; Procedures.
call-with-time-display
fetch-repository
@@ -182,6 +184,92 @@ directory and the sha1 of the top level commit in this
directory."
(data data))))
(close-pipe port)
jobs))
+
+;;;
+;;; Build status.
+;;;
+
+;; TODO: Remove this code once it has been integrated in Guix proper as (guix
+;; status).
+
+(define %newline
+ (char-set #\return #\newline))
+
+(define (build-event-output-port proc seed)
+ "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
+event. Build events passed to PROC are tuples corresponding to the \"build
+traces\" produced by the daemon:
+
+ (build-started \"/gnu/store/...-foo.drv\" ...)
+ (substituter-started \"/gnu/store/...-foo\" ...)
+
+and so on. "
+ (define %fragments
+ ;; Line fragments received so far.
+ '())
+
+ (define %state
+ ;; Current state for PROC.
+ seed)
+
+ (define (process-line line)
+ (when (string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (((= string->symbol event-name) args ...)
+ (set! %state
+ (proc (cons event-name args)
+ %state))))))
+
+ (define (write! bv offset count)
+ (let loop ((str (utf8->string bv)))
+ (match (string-index str %newline)
+ ((? integer? cr)
+ (let ((tail (string-take str cr)))
+ (process-line (string-concatenate-reverse
+ (cons tail %fragments)))
+ (set! %fragments '())
+ (loop (string-drop str (+ 1 cr)))))
+ (#f
+ (set! %fragments (cons str %fragments))
+ count))))
+
+ (make-custom-binary-output-port "filtering-input-port"
+ write!
+ #f #f #f))
+
+
+;;;
+;;; Building packages.
+;;;
+
+(define* (handle-build-event db event
+ #:key (log-port (current-error-port)))
+ "Handle EVENT, a build event sexp as produced by 'build-event-output-port'."
+ (define now
+ (current-time time-utc))
+
+ (define date
+ (date->string (time-utc->date now) "~5"))
+
+ (define (log fmt . args)
+ (apply format log-port (string-append date " " fmt "\n")
+ args))
+
+ ;; TODO: Update DB according to EVENT.
+ (match event
+ (('build-started drv _ ...)
+ (log "build started: '~a'" drv))
+ (('build-remote drv host _ ...)
+ (log "build of '~a' offloaded to '~a'" drv host))
+ (('build-succeeded drv _ ...)
+ (log "build succeeded: '~a'" drv))
+ (('substituter-started item _ ...)
+ (log "substituter started: '~a'" item))
+ (('substituter-succeeded item _ ...)
+ (log "substituter succeeded: '~a'" item))
+ (_
+ (log "build event: ~s" event))))
(define (build-packages store db jobs)
"Build JOBS and return a list of Build results."
@@ -229,7 +317,10 @@ directory and the sha1 of the top level commit in this
directory."
(format #t "load-path=~s\n" %load-path)
(format #t "load-compiled-path=~s\n" %load-compiled-path)
(format #t "building ~a derivations...~%" (length jobs))
- (parameterize ((current-build-output-port (%make-void-port "w")))
+ (parameterize ((current-build-output-port
+ (build-event-output-port (lambda (event status)
+ (handle-build-event db event))
+ #t)))
(build-derivations store
(map (lambda (job)
(assq-ref job #:derivation))