diff options
Diffstat (limited to 'guix-qa-frontpage/utils.scm')
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 213 |
1 files changed, 48 insertions, 165 deletions
diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index d96db57..63b741c 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -18,172 +18,55 @@ (define-module (guix-qa-frontpage utils) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (ice-9 q) - #:use-module (ice-9 iconv) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (ice-9 threads) - #:use-module (ice-9 atomic) - #:use-module (ice-9 textual-ports) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 exceptions) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 suspendable-ports) - #:use-module ((ice-9 ports internal) #:select (port-poll - port-read-wait-fd - port-write-wait-fd)) - #:use-module (web uri) - #:use-module (web http) - #:use-module (web client) - #:use-module (web request) - #:use-module (web response) #:use-module (fibers) - #:use-module (fibers timers) #:use-module (fibers channels) - #:use-module (fibers scheduler) - #:use-module (fibers conditions) - #:use-module (fibers operations) - #:export (port-read-timeout-error? - port-write-timeout-error? - with-fibers-port-timeouts)) - -(define (readable? port) - "Test if PORT is writable." - (match (select (vector port) #() #() 0) - ((#() #() #()) #f) - ((#(_) #() #()) #t))) - -(define (writable? port) - "Test if PORT is writable." - (match (select #() (vector port) #() 0) - ((#() #() #()) #f) - ((#() #(_) #()) #t))) - -(define (make-wait-operation ready? schedule-when-ready port port-ready-fd this-procedure) - (make-base-operation #f - (lambda _ - (and (ready? (port-ready-fd port)) values)) - (lambda (flag sched resume) - (define (commit) - (match (atomic-box-compare-and-swap! flag 'W 'S) - ('W (resume values)) - ('C (commit)) - ('S #f))) - (schedule-when-ready - sched (port-ready-fd port) commit)))) - -(define (wait-until-port-readable-operation port) - "Make an operation that will succeed when PORT is readable." - (unless (input-port? port) - (error "refusing to wait forever for input on non-input port")) - (make-wait-operation readable? schedule-task-when-fd-readable port - port-read-wait-fd - wait-until-port-readable-operation)) - -(define (wait-until-port-writable-operation port) - "Make an operation that will succeed when PORT is writable." - (unless (output-port? port) - (error "refusing to wait forever for output on non-output port")) - (make-wait-operation writable? schedule-task-when-fd-writable port - port-write-wait-fd - wait-until-port-writable-operation)) - - - -(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-fibers-port-timeouts thunk - #:key timeout - (read-timeout timeout) - (write-timeout timeout)) - (define (no-fibers-wait port mode timeout) - (define poll-timeout-ms 200) - - ;; 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. - (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)))) - - (unless read-timeout - (if timeout - (error "unset read-timeout") - (error "unset timeout"))) - (unless write-timeout - (error "unset write-timeout")) - - (parameterize - ((current-read-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-readable-operation port) - (wrap-operation - (sleep-operation read-timeout) - (lambda () - (raise-exception - (make-port-read-timeout-error thunk port)))))) - (no-fibers-wait port "r" read-timeout)))) - (current-write-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-writable-operation port) - (wrap-operation - (sleep-operation write-timeout) - (lambda () - (raise-exception - (make-port-write-timeout-error thunk port)))))) - (no-fibers-wait port "w" write-timeout))))) - (thunk))) + #:use-module (knots) + #:use-module (zlib) + #:export (non-blocking + call-with-zlib-input-port*)) + +(define (non-blocking thunk) + (let ((channel (make-channel))) + (call-with-default-io-waiters + (lambda () + (call-with-new-thread + (lambda () + (with-exception-handler + (lambda (exn) + (put-message channel `(exception ,exn))) + (lambda () + (with-throw-handler #t + (lambda () + (call-with-values thunk + (lambda values + (put-message channel `(values ,@values))))) + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port))))) + #:unwind? #t))))) + (match (get-message channel) + (('values . results) + (apply values results)) + (('exception . exn) + (raise-exception exn))))) + +(define* (call-with-zlib-input-port* port proc + #:key + (format 'zlib) + (buffer-size %default-buffer-size)) + "Call PROC with a port that wraps PORT and decompresses data read from it. +PORT is closed upon completion. The zlib internal buffer size is set to +BUFFER-SIZE bytes." + (let ((zlib (make-zlib-input-port port + #:format format + #:buffer-size buffer-size + #:close? #t))) + (call-with-values + (lambda () + (proc zlib)) + (lambda vals + (close-port zlib) + (apply values vals))))) |