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 @@ references; otherwise, return only non-native references."
(target (%current-target-system))) (target (%current-target-system)))
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT, "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)" 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?) (define* (reference->sexp ref #:optional native?)
(with-monad %store-monad (with-monad %store-monad
(match ref (match ref
@ -1034,8 +1043,10 @@ and in the current monad setting (system type, etc.)"
#:target target))) #:target target)))
;; OBJ must be either a derivation or a store file name. ;; OBJ must be either a derivation or a store file name.
(return (expand thing obj output))))) (return (expand thing obj output)))))
(($ <gexp-input> x) (($ <gexp-input> (? self-quoting? x))
(return x)) (return x))
(($ <gexp-input> x)
(raise (condition (&gexp-input-error (input x)))))
(x (x
(return x))))) (return x)))))

View File

@ -871,6 +871,13 @@
(eq? (derivation-input-derivation (lowered-gexp-guile lexp)) (eq? (derivation-input-derivation (lowered-gexp-guile lexp))
(%guile-for-build))))))) (%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" (test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad (mlet* %store-monad
((one (text-file "one" (random-text))) ((one (text-file "one" (random-text)))