Subject: bug#49315: closed (Re: [bug#49315] [PATCH]: Lint usages of 'wrap-program' without a "bash" input.)

From: [email-masked] (GNU bug Tracking System)
Date: Wed, 07 Jul 2021 09:13:02 +0000

Your bug report

#49315: [PATCH]: Lint usages of 'wrap-program' without a "bash" input.

which was filed against the guix-patches package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
49315: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=49315
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: [bug#49315] [PATCH]: Lint usages of 'wrap-program' without a "bash" input.
From: Mathieu Othacehe <[email-masked]>
To: Maxime Devos <[email-masked]>
Cc: [email-masked]
Date: Wed, 07 Jul 2021 11:12:33 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

Hey,

> That usage should ideally be detected by 'wrap-program'.  But as no
> current package definition seems to do such a thing, and using
> 'find-procedure-body' seems marginally ‘cleaner’ to me (YMMV?),
> I would use 'find-procedure-body' anyways.

OK, seems fair. I just edited the first patch to use "last" that has the
benefit of hiding a "car" call and wrapped a long line.

Pushed on master.

Thanks,

Mathieu

Subject: [PATCH]: Lint usages of 'wrap-program' without a "bash" input.
From: Maxime Devos <[email-masked]>
To: [email-masked]
Date: Thu, 01 Jul 2021 13:39:53 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

Hi Guix,

These two patches add a 'wrapper-inputs' linter.
It detects if "wrap-program" is used without adding
"bash" or "bash-minimal" to 'inputs'. Adding "bash"
or "bash-minimal" is necessary when cross-compiling,
otherwise the resulting wrapper will use an interpreter
for the wrong architecture.

This linter detects 365 problematic packages.

Greetings,
Maxime.
From 18a7cfcbe54e20c80afd55e21c504a872c053593 Mon Sep 17 00:00:00 2001
From: Maxime Devos <[email-masked]>
Date: Thu, 1 Jul 2021 12:51:14 +0200
Subject: [PATCH 1/2] lint: Define some procedures for analysing code in
 phases.

* guix/lint.scm
  (check-optional-tests): Extract logic for extracting the phases from a
  package to ...
  (find-phase-deltas): ... here, and ...
  (report-bogus-phase-deltas): ... here.
  (check-optional-tests)[check-check-procedure]: Extract code for extracting
  the procedure body to ...
  (find-procedure-body) ... here.
  (find-phase-procedure): New procedure.
  (report-bogus-phase-procedure): New procedure.
---
 guix/lint.scm | 116 ++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 83 insertions(+), 33 deletions(-)

diff --git a/guix/lint.scm b/guix/lint.scm
index c637929c38..f54f6949ec 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -160,6 +160,77 @@
     ((_ package (G_ message) rest ...)
      (%make-warning package message rest ...))))
 
+
+;;;
+;;; Procedures for analysing Scheme code in package definitions
+;;;
+
+(define* (find-procedure-body expression found
+                              #:key (not-found (const '())))
+  "Try to find the body of the procedure defined inline by EXPRESSION.
+If it was found, call EXPRESSION with its body. If it wasn't, call
+the thunk NOT-FOUND."
+  (match expression
+    (`(,(or 'let 'let*) . ,_)
+     (find-procedure-body (car (last-pair expression)) found
+                          #:not-found not-found))
+    (`(,(or 'lambda 'lambda*) ,_ . ,code)
+     (found code))
+    (_ (not-found))))
+
+(define* (report-bogus-phase-deltas package bogus-deltas)
+  "Report a bogus invocation of ‘modify-phases’."
+  (list (make-warning package
+                      ;; TRANSLATORS: 'modify-phases' is a Scheme syntax
+                      ;; and should not be translated.
+                      (G_ "incorrect call to ‘modify-phases’")
+                      #:field 'arguments)))
+
+(define* (find-phase-deltas package found
+                            #:key (not-found (const '()))
+                            (bogus (cut report-bogus-phase-deltas package <>)))
+  "Try to find the clauses of the ‘modify-phases’ form in the phases
+specification of PACKAGE.  If they were found, all FOUND with a list
+of the clauses.  If they weren't (e.g. because ‘modify-phases’ wasn't
+used at all), call the thunk NOT-FOUND instead.  If ‘modify-phases’
+was used, but the clauses don't form a list, call BOGUS with the
+not-a-list."
+  (apply (lambda* (#:key phases #:allow-other-keys)
+           (define phases/sexp
+             (if (gexp? phases)
+                 (gexp->approximate-sexp phases)
+                 phases))
+           (match phases/sexp
+             (`(modify-phases ,_ . ,changes)
+              ((if (list? changes) found bogus) changes))
+             (_ (not-found))))
+         (package-arguments package)))
+
+(define (report-bogus-phase-procedure package)
+  "Report a syntactically-invalid phase clause."
+  (list (make-warning package
+                      ;; TRANSLATORS: See ‘modify-phases’ in the manual.
+                      (G_ "invalid phase clause")
+                      #:field 'arguments)))
+
+(define* (find-phase-procedure package expression found
+                               #:key (not-found (const '()))
+                               (bogus (cut report-bogus-phase-procedure
+                                           package)))
+  "Try to find the procedure in the phase clause EXPRESSION. If it was
+found, call FOUND with the procedure expression. If EXPRESSION isn't
+actually a phase clause, call the thunk BOGUS. If the phase form doesn't
+have a procedure, call the thunk NOT-FOUND."
+  (match expression
+    (('add-after before after proc-expr)
+     (found proc-expr))
+    (('add-before after before proc-expr)
+     (found proc-expr))
+    (('replace _ proc-expr)
+     (found proc-expr))
+    (('delete _) (not-found))
+    (_ (bogus))))
+
 
 ;;;
 ;;; Checkers
@@ -1063,46 +1134,25 @@ descriptions maintained upstream."
   (define (sexp-uses-tests?? sexp)
     "Test if SEXP contains the symbol 'tests?'."
     (sexp-contains-atom? sexp 'tests?))
+  (define (check-procedure-body code)
+    (if (sexp-uses-tests?? code)
+        '()
+        (list (make-warning package
+                            ;; TRANSLATORS: check and #:tests? are a
+                            ;; Scheme symbol and keyword respectively
+                            ;; and should not be translated.
+                            (G_ "the 'check' phase should respect #:tests?")
+                            #:field 'arguments))))
   (define (check-check-procedure expression)
-    (match expression
-      (`(,(or 'let 'let*) . ,_)
-       (check-check-procedure (car (last-pair expression))))
-      (`(,(or 'lambda 'lambda*) ,_ . ,code)
-       (if (sexp-uses-tests?? code)
-           '()
-           (list (make-warning package
-                               ;; TRANSLATORS: check and #:tests? are a
-                               ;; Scheme symbol and keyword respectively
-                               ;; and should not be translated.
-                               (G_ "the 'check' phase should respect #:tests?")
-                               #:field 'arguments))))
-      (_ '())))
+    (find-procedure-body expression check-procedure-body))
   (define (check-phases-delta delta)
     (match delta
       (`(replace 'check ,expression)
        (check-check-procedure expression))
       (_ '())))
   (define (check-phases-deltas deltas)
-    (match deltas
-      (() '())
-      ((head . tail)
-       (append (check-phases-delta head)
-               (check-phases-deltas tail)))
-      (_ (list (make-warning package
-                             ;; TRANSLATORS: modify-phases is a Scheme
-                             ;; syntax and must not be translated.
-                             (G_ "incorrect call to ‘modify-phases’")
-                             #:field 'arguments)))))
-  (apply (lambda* (#:key phases #:allow-other-keys)
-           (define phases/sexp
-             (if (gexp? phases)
-                 (gexp->approximate-sexp phases)
-                 phases))
-           (match phases/sexp
-             (`(modify-phases ,_ . ,changes)
-              (check-phases-deltas changes))
-             (_ '())))
-         (package-arguments package)))
+    (append-map check-phases-delta deltas))
+  (find-phase-deltas package check-phases-deltas))
 
 (define* (check-derivation package #:key store)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
-- 
2.32.0

From 776db32c98ad3a2bad0f81c3314878fa9eea84ab Mon Sep 17 00:00:00 2001
From: Maxime Devos <[email-masked]>
Date: Thu, 1 Jul 2021 12:59:52 +0200
Subject: [PATCH 2/2] lint: Lint usages of 'wrap-program' without a "bash"
 input.

When using 'wrap-program', "bash" (or "bash-minimal") should be
in inputs.  Otherwise, when cross-compiling, 'wrap-program' will use
a native bash instead of the cross bash and the 'patch-shebangs' won't
be able to correct this.

Tobias Geerinckx-Rice is added to the copyright lines because
a part of the "straw-viewer" package definition is included.

This linter detects 365 problematic package definitions at time
of writing.

* guix/lint.scm
  (report-wrap-program-error): New procedure.
  (check-wrapper-inputs): New linter.
  (%local-checkers)[wrapper-inputs]: Add the new linter.
  ("explicit #:sh argument to 'wrap-program' is acceptable")
  ("'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs")
  ("'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs")
  ("\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'")
  ("\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'")
  ("'cut' doesn't hide bad usages of 'wrap-program'")
  ("bogus phase specifications don't crash the linter"): New tests.
---
 guix/lint.scm  | 48 +++++++++++++++++++++++++++
 tests/lint.scm | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 136 insertions(+)

diff --git a/guix/lint.scm b/guix/lint.scm
index f54f6949ec..e12b35bca8 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -80,6 +80,7 @@
   #:export (check-description-style
             check-inputs-should-be-native
             check-inputs-should-not-be-an-input-at-all
+            check-wrapper-inputs
             check-patch-file-names
             check-patch-headers
             check-synopsis-style
@@ -489,6 +490,49 @@ of a package, and INPUT-NAMES, a list of package specifications such as
          (package-input-intersection (package-direct-inputs package)
                                      input-names))))
 
+(define (report-wrap-program-error package wrapper-name)
+  "Warn that \"bash-minimal\" is missing from 'inputs', while WRAPPER-NAME
+requires it."
+  (make-warning package
+                (G_ "\"bash-minimal\" should be in 'inputs' when '~a' is used")
+                (list wrapper-name)))
+
+(define (check-wrapper-inputs package)
+  "Emit a warning if PACKAGE uses 'wrap-program' or similar, but \"bash\"
+or \"bash-minimal\" is not in its inputs. 'wrap-script' is not supported."
+  (define input-names '("bash" "bash-minimal"))
+  (define has-bash-input?
+    (pair? (package-input-intersection (package-inputs package)
+                                       input-names)))
+  (define (check-procedure-body body)
+    (match body
+      ;; Explicitely setting an interpreter is acceptable,
+      ;; #:sh support is added on 'core-updates'.
+      ;; TODO(core-updates): remove mention of core-updates.
+      (('wrap-program _ '#:sh . _) '())
+      (('wrap-program _ . _)
+       (list (report-wrap-program-error package 'wrap-program)))
+      ;; Wrapper of 'wrap-program' for Qt programs.
+      ;; TODO #:sh is not yet supported but probably will be.
+      (('wrap-qt-program _ '#:sh . _) '())
+      (('wrap-qt-program _ . _)
+       (list (report-wrap-program-error package 'wrap-qt-program)))
+      ((x . y)
+       (append (check-procedure-body x) (check-procedure-body y)))
+      (_ '())))
+  (define (check-phase-procedure expression)
+    (find-procedure-body expression check-procedure-body))
+  (define (check-delta expression)
+    (find-phase-procedure package expression check-phase-procedure))
+  (define (check-deltas deltas)
+    (append-map check-delta deltas))
+  (if has-bash-input?
+      ;; "bash" (or "bash-minimal") is in 'inputs', so everything seems ok.
+      '()
+      ;; "bash" is not in 'inputs'.  Verify 'wrap-program' and friends
+      ;; are unused
+      (find-phase-deltas package check-deltas)))
+
 (define (package-name-regexp package)
   "Return a regexp that matches PACKAGE's name as a word at the beginning of a
 line."
@@ -1687,6 +1731,10 @@ them for PACKAGE."
      (name        'inputs-should-not-be-input)
      (description "Identify inputs that shouldn't be inputs at all")
      (check       check-inputs-should-not-be-an-input-at-all))
+   (lint-checker
+     (name        'wrapper-inputs)
+     (description "Make sure 'wrap-program' can finds its interpreter.")
+     (check       check-wrapper-inputs))
    (lint-checker
      (name        'license)
      ;; TRANSLATORS: <license> is the name of a data type and must not be
diff --git a/tests/lint.scm b/tests/lint.scm
index 4ef400a9a0..82971db8f0 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2017 Efraim Flashner <[email-masked]>
 ;;; Copyright © 2018, 2019 Arun Isaac <[email-masked]>
 ;;; Copyright © 2020 Timothy Sample <[email-masked]>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <[email-masked]>
 ;;; Copyright © 2021 Xinglu Chen <[email-masked]>
 ;;; Copyright © 2021 Maxime Devos <[email-masked]>
 ;;;
@@ -47,6 +48,7 @@
   #:use-module (gnu packages glib)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python-xyz)
+  #:use-module ((gnu packages bash) #:select (bash bash-minimal))
   #:use-module (web uri)
   #:use-module (web server)
   #:use-module (web server http)
@@ -357,6 +359,92 @@
                               `(("python-setuptools" ,python-setuptools))))))
      (check-inputs-should-not-be-an-input-at-all pkg))))
 
+(test-equal "explicit #:sh argument to 'wrap-program' is acceptable"
+  '()
+  (let* ((phases
+          ;; Loosely based on the "catfish" package
+          `(modify-phases %standard-phases
+             (add-after 'install 'wrap
+               (lambda* (#:key inputs outputs #:allow-other-keys)
+                 (define catfish (string-append (assoc-ref outputs "out")
+                                                "/bin/catfish"))
+                 (define hsab (string-append (assoc-ref inputs "hsab")
+                                             "/bin/hsab"))
+                 (wrap-program catfish #:sh hsab
+                               `("PYTHONPATH" = (,"blabla")))))))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
+    (check-wrapper-inputs pkg)))
+
+(test-equal
+    "'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs"
+  "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used"
+  (let* ((phases
+          `(modify-phases %standard-phases
+             (add-after 'install 'wrap
+               (lambda _
+                 (wrap-program the-binary bla-bla)))))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
+    (single-lint-warning-message (check-wrapper-inputs pkg))))
+
+(test-equal
+    "'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs"
+  "\"bash-minimal\" should be in 'inputs' when 'wrap-qt-program' is used"
+  (let* ((phases
+          `(modify-phases %standard-phases
+             (add-after 'install 'qtwrap
+               (lambda _
+                 (wrap-qt-program the-binary bla-bla)))))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
+    (single-lint-warning-message (check-wrapper-inputs pkg))))
+
+(test-equal "\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'"
+  '()
+  (let* ((phases
+          `(modify-phases %standard-phases
+             (add-after 'install 'wrap
+               (lambda _
+                 (wrap-program the-binary bla-bla)))))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases))
+                             (inputs `(("bash" ,bash))))))
+    (check-wrapper-inputs pkg)))
+
+(test-equal "\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'"
+  '()
+  (let* ((phases
+          `(modify-phases %standard-phases
+             (add-after 'install 'wrap
+               (lambda _
+                 (wrap-program THE-BINARY bla-bla)))))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases))
+                             (inputs `(("bash-minimal" ,bash-minimal))))))
+    (check-wrapper-inputs pkg)))
+
+(test-equal "'cut' doesn't hide bad usages of 'wrap-program'"
+  "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used"
+  (let* ((phases
+          ;; Taken from the "straw-viewer" package
+          `(modify-phases %standard-phases
+             (add-after 'install 'wrap-program
+               (lambda* (#:key outputs #:allow-other-keys)
+                 (let* ((out (assoc-ref outputs "out"))
+                        (bin-dir (string-append out "/bin/"))
+                        (site-dir (string-append out "/lib/perl5/site_perl/"))
+                        (lib-path (getenv "PERL5LIB")))
+                   (for-each (cut wrap-program <>
+                                  `("PERL5LIB" ":" prefix
+                                    (,lib-path ,site-dir)))
+                             (find-files bin-dir)))))))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
+    (single-lint-warning-message (check-wrapper-inputs pkg))))
+
+(test-equal "bogus phase specifications don't crash the linter"
+  "invalid phase clause"
+  (let* ((phases
+          `(modify-phases %standard-phases
+             (add-invalid)))
+         (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
+    (single-lint-warning-message (check-wrapper-inputs pkg))))
+
 (test-equal "file patches: different file name -> warning"
   "file names of patches should start with the package name"
   (single-lint-warning-message
-- 
2.32.0