01/04: gexp: 'local-file' warns when passed a non-literal relative file name.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f43ffee90882c2d61b46d69728daa7432be297e4
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Oct 1 22:09:58 2020 +0200

    gexp: 'local-file' warns when passed a non-literal relative file name.
    
    Fixes <https://bugs.gnu.org/43736>.
    Reported by Vitaliy Shatrov <guix.vits@disroot.org>.
    
    * guix/gexp.scm (%local-file): Add #:literal? and #:location.
    Emit a warning when LITERAL? is false and FILE is not absolute.
    (local-file): In the non-literal case, pass #:location and #:literal?.
    * po/guix/POTFILES.in: Add guix/gexp.scm.
    * tests/guix-system.sh: Add test for the warning.
---
 guix/gexp.scm        | 19 +++++++++++++++----
 po/guix/POTFILES.in  |  1 +
 tests/guix-system.sh | 14 ++++++++++++++
 3 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9d3c52e..40346b6 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -26,6 +26,8 @@
   #:use-module (guix derivations)
   #:use-module (guix grafts)
   #:use-module (guix utils)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -401,9 +403,15 @@ Here TARGET is bound to the cross-compilation triplet or 
#f."
 (define (true file stat) #t)
 
 (define* (%local-file file promise #:optional (name (basename file))
-                      #:key recursive? (select? true))
+                      #:key
+                      (literal? #t) location
+                      recursive? (select? true))
   ;; This intermediate procedure is part of our ABI, but the underlying
   ;; %%LOCAL-FILE is not.
+  (when (and (not literal?) (not (string-prefix? "/" file)))
+    (warning (and=> location source-properties->location)
+             (G_ "resolving '~a' relative to current directory~%")
+             file))
   (%%local-file file promise name recursive? select?))
 
 (define (absolute-file-name file directory)
@@ -443,9 +451,12 @@ appears."
                       rest ...))
       ((_ file rest ...)
        ;; Resolve FILE relative to the current directory.
-       #'(%local-file file
-                      (delay (absolute-file-name file (getcwd)))
-                      rest ...))
+       (with-syntax ((location (datum->syntax s (syntax-source s))))
+        #`(%local-file file
+                       (delay (absolute-file-name file (getcwd)))
+                       #:location 'location
+                       #:literal? #f
+                       rest ...)))
       ((_)
        #'(syntax-error "missing file name"))
       (id
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index f4d0207..b877fac 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -76,6 +76,7 @@ guix/scripts/weather.scm
 guix/scripts/describe.scm
 guix/scripts/processes.scm
 guix/scripts/deploy.scm
+guix/gexp.scm
 guix/gnu-maintenance.scm
 guix/scripts/container.scm
 guix/scripts/container/exec.scm
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 667e084..957479e 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -297,6 +297,20 @@ EOF
 guix system build "$tmpdir/config.scm" -n
 (cd "$tmpdir"; guix system build "config.scm" -n)
 
+# Check that we get a warning when passing 'local-file' a non-literal relative
+# file name.
+cat > "$tmpdir/config.scm" <<EOF
+(use-modules (guix))
+
+(define (bad-local-file file)
+  (local-file file))
+
+(bad-local-file "whatever.scm")
+EOF
+! guix system build "$tmpdir/config.scm" -n
+guix system build "$tmpdir/config.scm" -n 2>&1 | \
+    grep "config\.scm:4:2: warning:.*whatever.*relative to current directory"
+
 # Searching.
 guix system search tor | grep "^name: tor"
 guix system search tor | grep "^shepherdnames: tor"