summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-09-23 22:17:39 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-23 23:41:19 +0200
commit24ab804ce11fe12ff49cd144a3d9c4bfcf55b41c (patch)
treefa0c67df4051d433e02a6b910717d44ec9bfda41
parent7abd5997f41fec38ea1daa9099a9693062f10dbc (diff)
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.
-rw-r--r--guix/gexp.scm13
-rw-r--r--tests/gexp.scm7
2 files changed, 19 insertions, 1 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 45cd5869f7..0d0b661c65 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1005,6 +1005,15 @@ references; otherwise, return only non-native references."
(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 @@ and in the current monad setting (system type, etc.)"
#: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)))))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 5c013d838d..50d0948659 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -871,6 +871,13 @@
(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)))