diff options
| -rw-r--r-- | guix-build-coordinator/client-communication.scm | 24 |
1 files changed, 14 insertions, 10 deletions
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm index f1d0208..3f59dad 100644 --- a/guix-build-coordinator/client-communication.scm +++ b/guix-build-coordinator/client-communication.scm @@ -680,7 +680,7 @@ (current-error-port) "error: coordinator-http-request: ~A ~A: ~A\n" method path (response-code response)) - (let ((body + (let ((parsed-body (catch #t (lambda () (if (equal? '(application/json (charset . "utf-8")) @@ -694,22 +694,26 @@ "error decoding body ~A ~A\n" key args) #f)))) + (close-port body) (raise-exception (make-exception-with-message - body)))) + parsed-body)))) (begin (set-port-encoding! body "UTF-8") (values - (if (equal? '(application/json-seq) - (response-content-type response)) - (json-seq->scm - body - ;; TODO I would like to use 'throw, but it always raises an - ;; exception, so this needs fixing upstream first - #:handle-truncate 'replace) - (json->scm body)) + (let ((parsed-body + (if (equal? '(application/json-seq) + (response-content-type response)) + (json-seq->scm + body + ;; TODO I would like to use 'throw, but it always raises an + ;; exception, so this needs fixing upstream first + #:handle-truncate 'replace) + (json->scm body)))) + (close-port body) + parsed-body) response)))))) (define* (send-submit-build-request |