diff options
| -rw-r--r-- | guix/inferior.scm | 31 | ||||
| -rw-r--r-- | tests/inferior.scm | 13 |
2 files changed, 40 insertions, 4 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm index fee97750b6..6be30d3f17 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,6 +19,8 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix utils) #:select (%current-system source-properties->location @@ -29,7 +31,8 @@ #:select (store-connection-socket store-connection-major-version store-connection-minor-version - store-lift)) + store-lift + &store-protocol-error)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) #:use-module (guix gexp) @@ -151,6 +154,7 @@ inferior." (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (ice-9 match)) result) + (inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -462,7 +466,13 @@ thus be the code of a one-argument procedure that accepts a store." (listen socket 1024) (send-inferior-request `(let ((proc ,code) - (socket (socket AF_UNIX SOCK_STREAM 0))) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (error? (if (defined? 'store-protocol-error?) + store-protocol-error? + nix-protocol-error?)) + (error-message (if (defined? 'store-protocol-error-message) + store-protocol-error-message + nix-protocol-error-message))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly @@ -475,7 +485,13 @@ thus be the code of a one-argument procedure that accepts a store." (dynamic-wind (const #t) (lambda () - (proc store)) + ;; Serialize '&store-protocol-error' conditions. The + ;; exception serialization mechanism that + ;; 'read-repl-response' expects is unsuitable for SRFI-35 + ;; error conditions, hence this special case. + (guard (c ((error? c) + `(store-protocol-error ,(error-message c)))) + `(result ,(proc store)))) (lambda () (close-connection store) (close-port socket))))) @@ -484,7 +500,14 @@ thus be the code of a one-argument procedure that accepts a store." ((client . address) (proxy client (store-connection-socket store)))) (close-port socket) - (read-inferior-response inferior))))) + + (match (read-inferior-response inferior) + (('store-protocol-error message) + (raise (condition + (&store-protocol-error (message message) + (status 1))))) + (('result result) + result)))))) (define* (inferior-package-derivation store package #:optional diff --git a/tests/inferior.scm b/tests/inferior.scm index 71ebf8f59b..f54b6d6037 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -186,6 +187,18 @@ (add-text-to-store store "foo" "Hello, world!"))))) +(test-assert "inferior-eval-with-store, &store-protocol-error" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) + "invalid character"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "we|rd/?!@" + "uh uh"))) + #f))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") |