gexp: Catch and report non-self-quoting gexp inputs.

Previously we would, for example, generate build scripts in the store;
when trying to run them, we'd get a 'read' error due to the presence
of #<foo> syntax in there.

* guix/gexp.scm (gexp->sexp)[self-quoting?]: New procedure.
[reference->sexp]: Check whether the argument in a <gexp-input> box is
self-quoting.  Raise a '&gexp-input-error' condition if it's not.
* tests/gexp.scm ("lower-gexp, non-self-quoting input"): New test.
This commit is contained in:
Ludovic Courtès 2019-09-23 22:17:39 +02:00
parent 7abd5997f4
commit 24ab804ce1
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 19 additions and 1 deletions

View file

@ -1005,6 +1005,15 @@ (define* (gexp->sexp exp #:key
(target (%current-target-system)))
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)"
(define (self-quoting? x)
(letrec-syntax ((one-of (syntax-rules ()
((_) #f)
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? keyword? pair? null? array?
number? boolean?)))
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
@ -1034,8 +1043,10 @@ (define* (reference->sexp ref #:optional native?)
#:target target)))
;; OBJ must be either a derivation or a store file name.
(return (expand thing obj output)))))
(($ <gexp-input> x)
(($ <gexp-input> (? self-quoting? x))
(return x))
(($ <gexp-input> x)
(raise (condition (&gexp-input-error (input x)))))
(x
(return x)))))

View file

@ -871,6 +871,13 @@ (define (matching-input drv output)
(eq? (derivation-input-derivation (lowered-gexp-guile lexp))
(%guile-for-build)))))))
(test-eq "lower-gexp, non-self-quoting input"
+
(guard (c ((gexp-input-error? c)
(gexp-error-invalid-input c)))
(run-with-store %store
(lower-gexp #~(foo #$+)))))
(test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad
((one (text-file "one" (random-text)))