[bug#61950] [PATCH] lint: Add 'copyleft' checker.

[Antero Mejr via Guix-patches via <guix-patches@gnu.org>]

* guix/lint.scm (check-copyleft, input->package, report-copyleft-violation,
linking-exception?, copyleft?): New procedures.
(%local-checkers): Add 'copyleft' checker.
* tests/lint.scm ("copyleft: incompatible copyleft input"): New tests.
* doc/guix.texi (Invoking guix lint): Mention it.
---
This new linter checks for copyleft license violations, where a copylefted
package is linked by a package with an incompatible license.
It found 2818 incompatible packages.
For example, GNU readline (GPL) is being linked by 71 permissively
licensed packages.

 doc/guix.texi  |   4 ++
 guix/lint.scm  | 109 +++++++++++++++++++++++++++++++++++++++++++++++++
 tests/lint.scm |  10 +++++
 3 files changed, 123 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 74658dbc86..be695967a2 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -14723,6 +14723,10 @@ corresponding package.  This aims to help migrate from the ``old input
 style''.  @xref{package Reference}, for more information on package
 inputs and input styles.  @xref{Invoking guix style}, on how to migrate
 to the new style.
+
+@item copyleft
+Warn about packages with permissive licenses that are not compatible with
+the copyleft licenses of their dependencies.
 @end table
 
 The general syntax is:
diff --git a/guix/lint.scm b/guix/lint.scm
index 8e3976171f..30745b0930 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -40,6 +40,7 @@ (define-module (guix lint)
   #:use-module (guix download)
   #:use-module (guix ftp-client)
   #:use-module (guix http-client)
+  #:use-module (guix licenses)
   #:use-module (guix packages)
   #:use-module (guix i18n)
   #:use-module ((guix gexp)
@@ -108,6 +109,7 @@ (define-module (guix lint)
             check-mirror-url
             check-github-url
             check-license
+            check-copyleft
             check-vulnerabilities
             check-for-updates
             check-formatting
@@ -1451,6 +1453,12 @@ (define format
       (with-store store
         (do-check store))))
 
+
+\f
+;;;
+;;; Package licenses.
+;;;
+
 (define (check-license package)
   "Warn about type errors of the 'license' field of PACKAGE."
   (match (package-license package)
@@ -1462,6 +1470,103 @@ (define (check-license package)
       (make-warning package (G_ "invalid license field")
                     #:field 'license)))))
 
+(define (copyleft? licenses)
+  "Check if a list of licenses are copyleft."
+  (let ((lic (if (list? licenses) licenses (list licenses))))
+    (map (lambda (x)
+           (and (license? x) ;some license fields are not license objects
+                (member (license-name x)
+                        '("AGPL 1" "AGPL 3" "AGPL 3+"
+                          "CC-BY-SA 2.0" "CC-BY-SA 3.0" "CC-BY-SA 4.0"
+                          "CeCILL" "copyleft-next"
+                          "EUPL 1.1" "EUPL 1.2"
+                          "GPL 1" "GPL 1+" "GPL 2" "GPL 2+" "GPL 3" "GPL 3+"
+                          "Sleepycat"))
+                #t))
+         lic)))
+
+(define (linking-exception? package)
+  "Check if a package has a known copyleft linking exception or is not linked."
+  (and (member (package-name package)
+               '(;; linking exception
+                 "classpath" "guile" "java-classpathx-servletapi" "icedtea"
+                 "uwsgi"
+                 ;; copyleft but not typically linked
+                 "alsa-utils" "acpi" "acpica" "audit"
+                 "bash" "bash-completion" "bash-minimal" "bash-static" "bc"
+                 "bluez" "binutils" "bison" "btrfs-progs"
+                 "catdoc" "cdparanoia" "colord" "colord-minimal" "coreutils"
+                 "coreutils-minimal" "cpuid" "cpupower" "cryptsetup"
+                 "dbus" "dbus-glib" "diffutils" "dmidecode" "dmraid" "dnsmasq"
+                 "dosfstools" "dpkg"
+                 "ebtables" "edac-utils" "egawk-next" "efibootmgr" "espeak"
+                 "espeak-ng" "ethtool" "eudev"
+                 "fcitx" "ffmpeg" "findutils" "fontforge"
+                 "gawk" "gawk-mpfr" "geoclue" "gettext" "gettext-minimal"
+                 "ghostscript" "git" "git-minimal" "gjs" "gnupg" "gnome-desktop"
+                 "gpart" "gperf" "gpm" "grep" "groff" "gzip"
+                 "hddtemp" "hwinfo" "kbd" "kexec-tools" "kmod"
+                 "less" "lm-sensors" "lzip"
+                 "i2c-tools" "inetutils" "inxi" "inxi-minimal" "iproute2"
+                 "iptables" "iso-codes"
+                 "m4" "make" "mariadb" "mawk" "mcelog" "mdadm" "memtester"
+                 "miscfiles" "modem-manager" "module-init-tools" "mpv" "mysql"
+                 "ndctl" "net-tools" "netcat" "nvme-cli"
+                 "pandoc" "parted" "password-store" "pciutils" "perl"
+                 "pkg-config" "postgresql" "procps" "psmisc" "pulseaudio"
+                 "qemu" "qemu-minimal" "ragel" "rpm" "rsync"
+                 "samba" "sane-backends" "sbc" "scummvm" "sed"
+                 "shared-mime-info" "shepherd" "smartmontools" "socat"
+                 "squashfs-tools" "sysstat"
+                 "tar" "time" "torsocks"
+                 "upower" "usbutils" "util-linux"
+                 "valgrind" "vidstab" "volume-key"
+                 "wget" "which" "wl-clipboard" "yelp" "xclip"
+                 "linux-libre-headers" "gnumach-headers" "hurd-headers"
+                 "gcc" "gcc-toolchain" "gfortran" "clang-toolchain"
+                 "ld-wrapper" "ld.lld-wrapper" "lld-wrapper"))
+       #t))
+
+(define (report-copyleft-violation package input-name)
+  "Report information about a copyleft license violation."
+  (make-warning package
+                (G_ "The license of input ~a is copyleft, but the license \
+of package ~a is permissive.")
+                (list input-name (package-name package))
+                #:field 'license))
+
+(define (input->package input)
+  "Convert a package input into a package if possible."
+  (if (list? input)
+      (cadr input)
+      #f))
+
+(define (check-copyleft package)
+  "Check that PACKAGE does not violate copyleft licenses of its inputs."
+  ;; Assumes all copyleft licenses are compatible, which is true for now
+  (let* ((pkg-copyleft (member #t (copyleft? (package-license package)))))
+    (apply append
+           (map (lambda (input)
+                  (let ((input-copyleft
+                         ;; if any license is permissive, the input is.
+                         ;; be lenient here to avoid false positives
+                         (not (member #f (copyleft? (package-license input))))))
+                    (if (and input-copyleft
+                             (not pkg-copyleft)
+                             (not (linking-exception? input)))
+                        (list (report-copyleft-violation package
+                                                         (package-name input)))
+                        '())))
+                (filter package?
+                        (map input->package
+                             (append (package-inputs package)
+                                     (package-propagated-inputs package))))))))
+
+\f
+;;;
+;;; Vulnerabilities and updates.
+;;;
+
 (define (current-vulnerabilities*)
   "Like 'current-vulnerabilities', but return the empty list upon networking
 or HTTP errors.  This allows network-less operation and makes problems with
@@ -1885,6 +1990,10 @@ (define %local-checkers
      (description "Make sure the 'license' field is a <license> \
 or a list thereof")
      (check       check-license))
+   (lint-checker
+    (name        'copyleft)
+    (description "Check for copyleft license violations")
+    (check       check-copyleft))
    (lint-checker
      (name        'optional-tests)
      (description "Make sure tests are only run when requested")
diff --git a/tests/lint.scm b/tests/lint.scm
index ce22e2355a..1ae64510b6 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -40,6 +40,7 @@ (define-module (test-lint)
   #:use-module (guix build-system emacs)
   #:use-module (guix build-system gnu)
   #:use-module (guix packages)
+  #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix lint)
   #:use-module (guix ui)
   #:use-module (guix swh)
@@ -51,6 +52,7 @@ (define-module (test-lint)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python-build)
+  #:use-module (gnu packages readline)
   #:use-module ((gnu packages bash) #:select (bash bash-minimal))
   #:use-module (web uri)
   #:use-module (web server)
@@ -665,6 +667,14 @@ (define hsab (string-append (assoc-ref inputs "hsab")
   (single-lint-warning-message
    (check-license (dummy-package "x" (license #f)))))
 
+(test-equal "copyleft: incompatible copyleft input"
+  "The license of input readline is copyleft, but the license of package x is permissive."
+  (single-lint-warning-message
+   (check-copyleft
+    (dummy-package "x"
+                   (inputs `(("readline" ,readline)))
+                   (license license:bsd-3)))))
+
 (test-equal "home-page: wrong home-page"
   "invalid value for home page"
   (let ((pkg (package
-- 
2.38.1