aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator/utils.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-build-coordinator/utils.scm')
-rw-r--r--guix-build-coordinator/utils.scm316
1 files changed, 142 insertions, 174 deletions
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index d747962..f4f15dc 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -14,10 +14,11 @@
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 binary-ports)
- #:use-module (ice-9 suspendable-ports)
- #:use-module ((ice-9 ports internal) #:select (port-poll))
#:use-module (ice-9 exceptions)
#:use-module (rnrs bytevectors)
+ #:use-module (oop goops)
+ #:use-module (logging logger)
+ #:use-module (logging port-log)
#:use-module (web uri)
#:use-module (web http)
#:use-module (web client)
@@ -42,18 +43,9 @@
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (guix scripts substitute)
+ #:use-module (guix-build-coordinator utils timeout)
#:export (random-v4-uuid
- &port-timeout
- &port-read-timeout
- &port-write-timeout
-
- port-timeout-error?
- port-read-timeout-error?
- port-write-timeout-error?
-
- with-port-timeouts
-
request-query-parameters
call-with-streaming-http-request
@@ -94,7 +86,13 @@
open-socket-for-uri*
- check-locale!))
+ check-locale!
+
+ display/safe
+ simple-format/safe
+ format/safe
+
+ <custom-port-log>))
(eval-when (eval load compile)
(begin
@@ -182,73 +180,6 @@
(parse-query-string query))
'())))
-(define &port-timeout
- (make-exception-type '&port-timeout
- &external-error
- '(port)))
-
-(define make-port-timeout-error
- (record-constructor &port-timeout))
-
-(define port-timeout-error?
- (record-predicate &port-timeout))
-
-(define &port-read-timeout
- (make-exception-type '&port-read-timeout
- &port-timeout
- '()))
-
-(define make-port-read-timeout-error
- (record-constructor &port-read-timeout))
-
-(define port-read-timeout-error?
- (record-predicate &port-read-timeout))
-
-(define &port-write-timeout
- (make-exception-type '&port-write-timeout
- &port-timeout
- '()))
-
-(define make-port-write-timeout-error
- (record-constructor &port-write-timeout))
-
-(define port-write-timeout-error?
- (record-predicate &port-write-timeout))
-
-(define* (with-port-timeouts thunk #:key (timeout 120))
-
- ;; When the GC runs, it restarts the poll syscall, but the timeout remains
- ;; unchanged! When the timeout is longer than the time between the syscall
- ;; restarting, I think this renders the timeout useless. Therefore, this
- ;; code uses a short timeout, and repeatedly calls poll while watching the
- ;; clock to see if it has timed out overall.
- (define poll-timeout-ms 200)
-
- (define (wait port mode)
- (let ((timeout-internal
- (+ (get-internal-real-time)
- (* internal-time-units-per-second timeout))))
- (let loop ((poll-value
- (port-poll port mode poll-timeout-ms)))
- (if (= poll-value 0)
- (if (> (get-internal-real-time)
- timeout-internal)
- (raise-exception
- (if (string=? mode "r")
- (make-port-read-timeout-error port)
- (make-port-write-timeout-error port)))
- (loop (port-poll port mode poll-timeout-ms)))
- poll-value))))
-
- (parameterize
- ((current-read-waiter
- (lambda (port)
- (wait port "r")))
- (current-write-waiter
- (lambda (port)
- (wait port "w"))))
- (thunk)))
-
(define* (call-with-streaming-http-request uri
content-length
callback
@@ -275,8 +206,8 @@
(setvbuf port 'block (expt 2 13))
(with-exception-handler
(lambda (exp)
- (simple-format #t "error: ~A ~A: ~A\n"
- method (uri-path uri) exp)
+ (simple-format/safe #t "error: ~A ~A: ~A\n"
+ method (uri-path uri) exp)
(close-port port)
(raise-exception exp))
(lambda ()
@@ -291,7 +222,8 @@
(let ((body (read-response-body response)))
(close-port port)
(values response
- body)))))))))))
+ body)))))))))
+ #:timeout 120))
(define (find-missing-substitutes-for-output store substitute-urls output)
(if (valid-path? store output)
@@ -349,7 +281,7 @@
(when (file-exists? cache-file)
(with-exception-handler
(lambda (exn)
- (simple-format
+ (simple-format/safe
(current-error-port)
"error: when deleting substitute cache file: ~A\n"
exn))
@@ -361,7 +293,18 @@
(let ((substitute-urls
(append-map (lambda (substitute-url)
(let ((log-port (open-output-string)))
- (with-throw-handler #t
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format/safe
+ (current-error-port)
+ "exception in has-substiutes-no-cache? (~A): ~A\n"
+ substitute-url exn)
+ (display/safe (string-append
+ (get-output-string log-port)
+ "\n")
+ (current-error-port))
+ (close-output-port log-port)
+ (raise-exception exn))
(lambda ()
(if (null?
;; I doubt the caching is thread safe, so
@@ -371,17 +314,7 @@
(lookup-narinfos substitute-url
(list file)))))
'()
- (list substitute-url)))
- (lambda (key . args)
- (simple-format
- (current-error-port)
- "exception in has-substiutes-no-cache? (~A) ~A: ~A\n"
- substitute-url key args)
- (display (string-append
- (get-output-string log-port)
- "\n")
- (current-error-port))
- (close-output-port log-port)))))
+ (list substitute-url))))))
substitute-urls)))
substitute-urls))
@@ -415,7 +348,7 @@
(take-right lines 10)
lines)))
(close-output-port log-port)
- (simple-format
+ (simple-format/safe
(current-error-port)
"exception when substituting derivation: ~A:\n ~A\n"
exn (string-join last-n-lines "\n"))
@@ -425,27 +358,23 @@
(ensure-path store derivation-name)))
#:unwind? #t)))
-(define read-derivation-from-file*
- (let ((%derivation-cache
- (@@ (guix derivations) %derivation-cache)))
- (lambda (file)
- (or (and file (hash-ref %derivation-cache file))
- (let ((drv
- ;; read-derivation can call read-derivation-from-file, so to
- ;; avoid having many open files when reading a derivation with
- ;; inputs, read it in to a string first.
- (call-with-input-string
- ;; Avoid calling scm_i_relativize_path in
- ;; fport_canonicalize_filename since this leads to lots
- ;; of readlink calls
- (with-fluids ((%file-port-name-canonicalization 'none))
- (call-with-input-file file
- get-string-all))
- (lambda (port)
- (set-port-filename! port file)
- (read-derivation port read-derivation-from-file*)))))
- (hash-set! %derivation-cache file drv)
- drv)))))
+(define* (read-derivation-from-file* file #:optional (drv-hash (make-hash-table)))
+ (or (and file (hash-ref drv-hash file))
+ (let ((drv
+ ;; read-derivation can call read-derivation-from-file, so to
+ ;; avoid having many open files when reading a derivation with
+ ;; inputs, read it in to a string first.
+ (call-with-input-string
+ (call-with-input-file file
+ get-string-all)
+ (lambda (port)
+ (set-port-filename! port file)
+ (read-derivation port (lambda (file)
+ (read-derivation-from-file*
+ file
+ drv-hash)))))))
+ (hash-set! drv-hash file drv)
+ drv)))
(define (read-derivation-through-substitutes derivation-name
substitute-urls)
@@ -638,7 +567,7 @@ References: ~a~%"
#:unwind? #t)
((#t . return-values)
(when (> attempt 1)
- (simple-format
+ (simple-format/safe
(current-error-port)
"retry success: ~A\n on attempt ~A of ~A\n"
f
@@ -649,7 +578,7 @@ References: ~a~%"
(if (>= attempt
(- times 1))
(begin
- (simple-format
+ (simple-format/safe
(current-error-port)
"error: ~A:\n ~A,\n attempt ~A of ~A, last retry in ~A\n"
f
@@ -660,14 +589,14 @@ References: ~a~%"
(when error-hook
(error-hook attempt exn))
(sleep-impl delay)
- (simple-format
+ (simple-format/safe
(current-error-port)
"running last retry of ~A after ~A failed attempts\n"
f
attempt)
(f))
(begin
- (simple-format
+ (simple-format/safe
(current-error-port)
"error: ~A:\n ~A,\n attempt ~A of ~A, retrying in ~A\n"
f
@@ -895,27 +824,29 @@ References: ~a~%"
(define (thread-process-job job-args)
(with-exception-handler
(lambda (exn)
- (simple-format (current-error-port)
- "~A work queue, job raised exception ~A: ~A\n"
- name job-args exn))
+ (simple-format/safe
+ (current-error-port)
+ "~A work queue, job raised exception ~A: ~A\n"
+ name job-args exn))
(lambda ()
- (with-throw-handler #t
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format/safe
+ (current-error-port)
+ "~A work queue, exception when handling job: ~A\n"
+ name exn)
+ (let* ((stack (make-stack #t 3))
+ (backtrace
+ (call-with-output-string
+ (lambda (port)
+ (display-backtrace stack port)
+ (newline port)))))
+ (display/safe
+ backtrace
+ (current-error-port)))
+ (raise-exception exn))
(lambda ()
- (apply proc job-args))
- (lambda (key . args)
- (simple-format
- (current-error-port)
- "~A work queue, exception when handling job: ~A ~A\n"
- name key args)
- (let* ((stack (make-stack #t 3))
- (backtrace
- (call-with-output-string
- (lambda (port)
- (display-backtrace stack port)
- (newline port)))))
- (display
- backtrace
- (current-error-port))))))
+ (apply proc job-args))))
#:unwind? #t))
(define (start-thread thread-index)
@@ -1085,36 +1016,29 @@ References: ~a~%"
(define (thread-process-job job-args)
(with-exception-handler
(lambda (exn)
- (with-exception-handler
- (lambda _
- #f)
- (lambda ()
- ;; Logging may raise an exception, so try and just keep going.
- (display
- (simple-format
- #f
- "~A thread pool, job raised exception ~A: ~A\n"
- name job-args exn)
- (current-error-port)))
- #:unwind? #t))
+ (simple-format/safe
+ (current-error-port)
+ "~A thread pool, job raised exception ~A: ~A\n"
+ name job-args exn))
(lambda ()
- (with-throw-handler #t
- (lambda ()
- (apply proc job-args))
- (lambda (key . args)
- (simple-format
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format/safe
(current-error-port)
- "~A thread pool, exception when handling job: ~A ~A\n"
- name key args)
+ "~A thread pool, exception when handling job: ~A\n"
+ name exn)
(let* ((stack (make-stack #t 3))
(backtrace
(call-with-output-string
(lambda (port)
(display-backtrace stack port)
(newline port)))))
- (display
+ (display/safe
backtrace
- (current-error-port))))))
+ (current-error-port)))
+ (raise-exception exn))
+ (lambda ()
+ (apply proc job-args))))
#:unwind? #t))
(define (start-thread thread-index)
@@ -1354,22 +1278,18 @@ References: ~a~%"
(define (check-locale!)
(with-exception-handler
(lambda (exn)
- (display
- (simple-format
- #f
- "exception when calling setlocale: ~A
+ (simple-format/safe
+ (current-error-port)
+ "exception when calling setlocale: ~A
falling back to en_US.utf8\n"
- exn)
- (current-error-port))
+ exn)
(with-exception-handler
(lambda (exn)
- (display
- (simple-format
- #f
- "exception when calling setlocale with en_US.utf8: ~A\n"
- exn)
- (current-error-port))
+ (simple-format/safe
+ (current-error-port)
+ "exception when calling setlocale with en_US.utf8: ~A\n"
+ exn)
(exit 1))
(lambda _
@@ -1378,3 +1298,51 @@ falling back to en_US.utf8\n"
(lambda _
(setlocale LC_ALL ""))
#:unwind? #t))
+
+(define* (display/safe obj #:optional (port (current-output-port)))
+ ;; Try to avoid the dreaded conversion to port encoding failed error #62590
+ (put-bytevector
+ port
+ (string->utf8
+ (call-with-output-string
+ (lambda (port)
+ (display obj port)))))
+ (force-output port))
+
+(define (simple-format/safe port s . args)
+ (let ((str (apply simple-format #f s args)))
+ (if (eq? #f port)
+ str
+ (display/safe
+ str
+ (if (eq? #t port)
+ (current-output-port)
+ port)))))
+
+(define (format/safe port s . args)
+ (let ((str (apply format #f s args)))
+ (if (eq? #f port)
+ str
+ (display/safe
+ str
+ (if (eq? #t port)
+ (current-output-port)
+ port)))))
+
+(define-class <custom-port-log> (<log-handler>)
+ (port #:init-value #f #:accessor port #:init-keyword #:port))
+
+(define-method (emit-log (self <custom-port-log>) str)
+ (when (port self)
+ (put-bytevector (port self)
+ (string->utf8 str))
+ ;; Even though the port is line buffered, writing to it with
+ ;; put-bytevector doesn't cause the buffer to be flushed.
+ (force-output (port self))))
+
+(define-method (flush-log (self <custom-port-log>))
+ (and=> (port self) force-output))
+
+(define-method (close-log! (self <custom-port-log>))
+ (and=> (port self) close-port)
+ (set! (port self) #f))