diff options
Diffstat (limited to 'guix-build-coordinator/utils.scm')
| -rw-r--r-- | guix-build-coordinator/utils.scm | 316 |
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)) |