summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/inferior.scm31
-rw-r--r--tests/inferior.scm13
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")