From 71507435225f10d8d944ba183cbcc77ef953e0e5 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 20 Sep 2019 22:26:53 +0200
Subject: 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 <contact@carldong.me>.

* 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 +++++++++++++++++++++++++++----
 1 file changed, 27 insertions(+), 4 deletions(-)

(limited to 'guix')

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 @@ (define-module (guix inferior)
                 #: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 @@ (define* (port->inferior pipe #:optional (close close-port))
        (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 @@ (define (inferior-eval-with-store inferior store code)
        (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 @@ (define (inferior-eval-with-store inferior store code)
              (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 @@ (define (inferior-eval-with-store inferior store code)
          ((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
-- 
cgit v1.2.3