02/07: inferior: Propagate '&store-protocol-error' error conditions.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 71507435225f10d8d944ba183cbcc77ef953e0e5
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 20 22:26:53 2019 +0200

    inferior: Propagate '&store-protocol-error' error conditions.
    
    Until now '&store-protocol-error' conditions raised in the inferior
    would not be correctly propagated because SRFI-35 records lack a read
    syntax.
    
    Reported at <https://bugs.gnu.org/37449>
    by Carl Dong <address@hidden>.
    
    * guix/inferior.scm (port->inferior): Import (srfi srfi-34) in the inferior.
    (inferior-eval-with-store): Define 'error?' and 'error-message'.  Wrap
    call to PROC in 'guard'.  Check the response of INFERIOR for a
    'store-protocol-error' or a 'result' tag.
    * tests/inferior.scm ("inferior-eval-with-store, &store-protocol-error"):
    New test.
---
 guix/inferior.scm  | 31 +++++++++++++++++++++++++++----
 tests/inferior.scm | 13 +++++++++++++
 2 files changed, 40 insertions(+), 4 deletions(-)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index fee9775..6be30d3 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 71ebf8f..f54b6d6 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")