From 18fc84bce86eedb85d44a8708a9a5ef7c1b23da5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 5 Nov 2020 14:32:04 +0100 Subject: gexp: Store the source code location in . * guix/gexp.scm ()[location]: New field. (gexp-location): New procedure. (write-gexp): Print the location of GEXP. (gexp->derivation): Adjust call to 'make-gexp'. (gexp): Likewise. --- guix/gexp.scm | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 9339b226b7..97a6101868 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -146,12 +146,17 @@ ;; "G expressions". (define-record-type - (make-gexp references modules extensions proc) + (make-gexp references modules extensions proc location) gexp? (references gexp-references) ;list of (modules gexp-self-modules) ;list of module names (extensions gexp-self-extensions) ;list of lowerable things - (proc gexp-proc)) ;procedure + (proc gexp-proc) ;procedure + (location %gexp-location)) ;location alist + +(define (gexp-location gexp) + "Return the source code location of GEXP." + (and=> (%gexp-location gexp) source-properties->location)) (define (write-gexp gexp port) "Write GEXP on PORT." @@ -164,6 +169,11 @@ (write (apply (gexp-proc gexp) (gexp-references gexp)) port)) + + (let ((loc (gexp-location gexp))) + (when loc + (format port " ~a" (location->string loc)))) + (format port " ~a>" (number->string (object-address gexp) 16))) @@ -1084,7 +1094,8 @@ The other arguments are as for 'derivation'." (make-gexp (gexp-references exp) (append modules (gexp-self-modules exp)) (gexp-self-extensions exp) - (gexp-proc exp)))) + (gexp-proc exp) + (gexp-location exp)))) (mlet* %store-monad ( ;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= @@ -1414,7 +1425,8 @@ execution environment." current-imported-modules current-imported-extensions (lambda #,formals - #,sexp))))))) + #,sexp) + (current-source-location))))))) ;;; -- cgit v1.2.3 From ca465a9c8454289b7aded22719cd5d919e441780 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 5 Nov 2020 14:52:29 +0100 Subject: gexp: Warn when importing (guix config) or (ice-9 …). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit While importing those modules from the host system is valid, it is often a mistake that introduces non-reproducibility. This patch prints a warning when that happens. * guix/gexp.scm (gexp-attribute): Add #:validate parameter and honor it. (gexp-modules)[validate-modules]: New procedure. Pass it to 'gexp-attribute'. * tests/gexp.scm ("gexp-modules, warning"): New test. --- guix/gexp.scm | 41 ++++++++++++++++++++++++++++++++--------- tests/gexp.scm | 12 ++++++++++++ 2 files changed, 44 insertions(+), 9 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 97a6101868..051831238e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -35,6 +35,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (gexp gexp? @@ -747,22 +748,26 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! write-gexp-output) -(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?)) +(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?) + #:key (validate (const #t))) "Recurse on GEXP and the expressions it refers to, summing the items returned by SELF-ATTRIBUTE, a procedure that takes a gexp. Use EQUAL? as the -second argument to 'delete-duplicates'." +second argument to 'delete-duplicates'. Pass VALIDATE every gexp and +attribute that is traversed." (if (gexp? gexp) (delete-duplicates - (append (self-attribute gexp) + (append (let ((attribute (self-attribute gexp))) + (validate gexp attribute) + attribute) (append-map (match-lambda (($ (? gexp? exp)) - (gexp-attribute exp self-attribute)) + (gexp-attribute exp self-attribute + #:validate validate)) (($ (lst ...)) (append-map (lambda (item) - (if (gexp? item) - (gexp-attribute item - self-attribute) - '())) + (gexp-attribute item self-attribute + #:validate + validate)) lst)) (_ '())) @@ -788,7 +793,25 @@ false, meaning that GEXP is a plain Scheme object, return the empty list." (_ (equal? m1 m2)))) - (gexp-attribute gexp gexp-self-modules module=?)) + (define (validate-modules gexp modules) + ;; Warn if MODULES, imported by GEXP, contains modules that in general + ;; should not be imported from the host because they vary from user to + ;; user and may thus be a source of non-reproducibility. This includes + ;; (guix config) as well as modules that come with Guile. + (match (filter (match-lambda + ((or ('guix 'config) ('ice-9 . _)) #t) + (_ #f)) + modules) + (() #t) + (suspects + (warning (gexp-location gexp) + (N_ "importing module~{ ~a~} from the host~%" + "importing modules~{ ~a~} from the host~%" + (length suspects)) + suspects)))) + + (gexp-attribute gexp gexp-self-modules module=? + #:validate validate-modules)) (define (gexp-extensions gexp) "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? diff --git a/tests/gexp.scm b/tests/gexp.scm index 0487f2a96d..686334af61 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -30,6 +30,7 @@ #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) + #:use-module ((guix diagnostics) #:select (guix-warning-port)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) @@ -818,6 +819,17 @@ '() (gexp-modules #t)) +(test-assert "gexp-modules, warning" + (string-match "tests/gexp.scm:[0-9]+:[0-9]+: warning: \ +importing.* \\(guix config\\) from the host" + (call-with-output-string + (lambda (port) + (parameterize ((guix-warning-port port)) + (let* ((x (with-imported-modules '((guix config)) + #~(+ 1 2 3))) + (y #~(+ 39 #$x))) + (gexp-modules y))))))) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin -- cgit v1.2.3