ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

inferior: Propagate '&store-protocol-error' error conditions.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2019-09-20 22:26:53 +02:00
parent a43e9157ef
commit 7150743522
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 40 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
guix/inferior.scm
View file

@ -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

13
tests/inferior.scm
View file

@ -27,6 +27,7 @@ (define-module (test-inferior)
#: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 @@ (define result
(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")