guix/lint.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
   3 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
   4 ;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
   5 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
   6 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
   7 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
   8 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
   9 ;;; Copyright © 2017, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
  10 ;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
  11 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
  12 ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
  13 ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
  14 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
  15 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
  16 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
  17 ;;;
  18 ;;; This file is part of GNU Guix.
  19 ;;;
  20 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  21 ;;; under the terms of the GNU General Public License as published by
  22 ;;; the Free Software Foundation; either version 3 of the License, or (at
  23 ;;; your option) any later version.
  24 ;;;
  25 ;;; GNU Guix is distributed in the hope that it will be useful, but
  26 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  27 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  28 ;;; GNU General Public License for more details.
  29 ;;;
  30 ;;; You should have received a copy of the GNU General Public License
  31 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  32
  33 (define-module (guix lint)
  34   #:use-module (guix store)
  35   #:autoload   (guix base16) (bytevector->base16-string)
  36   #:use-module (guix base32)
  37   #:autoload   (guix base64) (base64-encode)
  38   #:use-module (guix build-system)
  39   #:use-module (guix diagnostics)
  40   #:use-module (guix download)
  41   #:use-module (guix ftp-client)
  42   #:use-module (guix http-client)
  43   #:use-module (guix packages)
  44   #:use-module (guix i18n)
  45   #:use-module ((guix gexp)
  46                 #:select (gexp? local-file? local-file-absolute-file-name
  47                                 gexp->approximate-sexp))
  48   #:use-module (guix licenses)
  49   #:use-module (guix records)
  50   #:use-module (guix upstream)
  51   #:use-module (guix utils)
  52   #:use-module (guix memoization)
  53   #:use-module (guix profiles)
  54   #:use-module (guix monads)
  55   #:use-module (guix scripts)
  56   #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
  57   #:use-module (guix gnu-maintenance)
  58   #:use-module (guix cve)
  59   #:use-module ((guix swh) #:hide (origin?))
  60   #:autoload   (guix git-download) (git-reference?
  61                                     git-reference-url git-reference-commit)
  62   #:autoload   (guix svn-download) (svn-reference?
  63                                     svn-reference-url
  64                                     svn-reference-user-name
  65                                     svn-reference-password
  66
  67                                     svn-multi-reference?
  68                                     svn-multi-reference-url
  69                                     svn-multi-reference-user-name
  70                                     svn-multi-reference-password)
  71   #:use-module (guix import stackage)
  72   #:use-module (ice-9 match)
  73   #:use-module (ice-9 regex)
  74   #:use-module (ice-9 format)
  75   #:autoload   (rnrs bytevectors) (string->utf8)
  76   #:use-module (web client)
  77   #:use-module (web uri)
  78   #:use-module ((guix build download)
  79                 #:select (maybe-expand-mirrors
  80                           (open-connection-for-uri
  81                            . guix:open-connection-for-uri)))
  82   #:use-module (web request)
  83   #:use-module (web response)
  84   #:autoload   (gnutls) (error->string)
  85   #:use-module (srfi srfi-1)
  86   #:use-module (srfi srfi-6)                      ;Unicode string ports
  87   #:use-module (srfi srfi-9)
  88   #:use-module (srfi srfi-11)
  89   #:use-module (srfi srfi-26)
  90   #:use-module (srfi srfi-34)
  91   #:use-module (srfi srfi-35)
  92   #:use-module (ice-9 rdelim)
  93   #:export (check-description-style
  94             check-inputs-should-be-native
  95             check-inputs-should-not-be-an-input-at-all
  96             check-input-labels
  97             check-wrapper-inputs
  98             check-patch-file-names
  99             check-patch-headers
 100             check-synopsis-style
 101             check-derivation
 102             check-home-page
 103             check-name
 104             check-source
 105             check-source-file-name
 106             check-source-unstable-tarball
 107             check-optional-tests
 108             check-mirror-url
 109             check-github-url
 110             check-license
 111             check-vulnerabilities
 112             check-for-updates
 113             check-formatting
 114             check-archival
 115             check-profile-collisions
 116             check-haskell-stackage
 117             check-tests-true
 118
 119             lint-warning
 120             lint-warning?
 121             lint-warning-package
 122             lint-warning-message
 123             lint-warning-message-text
 124             lint-warning-message-data
 125             lint-warning-location
 126
 127             %local-checkers
 128             %network-dependent-checkers
 129             %all-checkers
 130
 131             lint-checker
 132             lint-checker?
 133             lint-checker-name
 134             lint-checker-description
 135             lint-checker-check
 136             lint-checker-requires-store?))
 137
 138 \f
 139 ;;;
 140 ;;; Warnings
 141 ;;;
 142
 143 (define-record-type* <lint-warning>
 144   lint-warning make-lint-warning
 145   lint-warning?
 146   (package       lint-warning-package)
 147   (message-text  lint-warning-message-text)
 148   (message-data  lint-warning-message-data
 149                  (default '()))
 150   (location      lint-warning-location
 151                  (default #f)))
 152
 153 (define (lint-warning-message warning)
 154   (apply format #f
 155          (G_ (lint-warning-message-text warning))
 156          (lint-warning-message-data warning)))
 157
 158 (define (package-file package)
 159   (location-file
 160    (package-location package)))
 161
 162 (define* (%make-warning package message-text
 163                         #:optional (message-data '())
 164                         #:key field location)
 165   (make-lint-warning
 166    package
 167    message-text
 168    message-data
 169    (or location
 170        (and field (package-field-location package field))
 171        (package-location package))))
 172
 173 (define-syntax make-warning
 174   (syntax-rules (G_)
 175     ((_ package (G_ message) rest ...)
 176      (%make-warning package message rest ...))))
 177
 178 \f
 179 ;;;
 180 ;;; Procedures for analysing Scheme code in package definitions
 181 ;;;
 182
 183 (define* (find-procedure-body expression found
 184                               #:key (not-found (const '())))
 185   "Try to find the body of the procedure defined inline by EXPRESSION.
 186 If it was found, call FOUND with its body. If it wasn't, call
 187 the thunk NOT-FOUND."
 188   (match expression
 189     (`(,(or 'let 'let*) . ,_)
 190      (find-procedure-body (car (last-pair expression)) found
 191                           #:not-found not-found))
 192     (`(,(or 'lambda 'lambda*) ,_ . ,code)
 193      (found code))
 194     (_ (not-found))))
 195
 196 (define* (report-bogus-phase-deltas package bogus-deltas)
 197   "Report a bogus invocation of ‘modify-phases’."
 198   (list (make-warning package
 199                       ;; TRANSLATORS: 'modify-phases' is a Scheme syntax
 200                       ;; and should not be translated.
 201                       (G_ "incorrect call to ‘modify-phases’")
 202                       #:field 'arguments)))
 203
 204 (define* (find-phase-deltas package found
 205                             #:key (not-found (const '()))
 206                             (bogus
 207                              (cut report-bogus-phase-deltas package <>)))
 208   "Try to find the clauses of the ‘modify-phases’ form in the phases
 209 specification of PACKAGE.  If they were found, all FOUND with a list
 210 of the clauses.  If they weren't (e.g. because ‘modify-phases’ wasn't
 211 used at all), call the thunk NOT-FOUND instead.  If ‘modify-phases’
 212 was used, but the clauses don't form a list, call BOGUS with the
 213 not-a-list."
 214   (apply (lambda* (#:key phases #:allow-other-keys)
 215            (define phases/sexp
 216              (if (gexp? phases)
 217                  (gexp->approximate-sexp phases)
 218                  phases))
 219            (match phases/sexp
 220              (`(modify-phases ,_ . ,changes)
 221               ((if (list? changes) found bogus) changes))
 222              (_ (not-found))))
 223          (package-arguments package)))
 224
 225 (define (report-bogus-phase-procedure package)
 226   "Report a syntactically-invalid phase clause."
 227   (list (make-warning package
 228                       ;; TRANSLATORS: See ‘modify-phases’ in the manual.
 229                       (G_ "invalid phase clause")
 230                       #:field 'arguments)))
 231
 232 (define* (find-phase-procedure package expression found
 233                                #:key (not-found (const '()))
 234                                (bogus (cut report-bogus-phase-procedure
 235                                            package)))
 236   "Try to find the procedure in the phase clause EXPRESSION. If it was
 237 found, call FOUND with the procedure expression. If EXPRESSION isn't
 238 actually a phase clause, call the thunk BOGUS. If the phase form doesn't
 239 have a procedure, call the thunk NOT-FOUND."
 240   (match expression
 241     (('add-after before after proc-expr)
 242      (found proc-expr))
 243     (('add-before after before proc-expr)
 244      (found proc-expr))
 245     (('replace _ proc-expr)
 246      (found proc-expr))
 247     (('delete _) (not-found))
 248     (_ (bogus))))
 249
 250 \f
 251 ;;;
 252 ;;; Checkers
 253 ;;;
 254
 255 (define-record-type* <lint-checker>
 256   lint-checker make-lint-checker
 257   lint-checker?
 258   ;; TODO: add a 'certainty' field that shows how confident we are in the
 259   ;; checker. Then allow users to only run checkers that have a certain
 260   ;; 'certainty' level.
 261   (name        lint-checker-name)
 262   (description lint-checker-description)
 263   (check       lint-checker-check)
 264   (requires-store? lint-checker-requires-store?
 265                    (default #f)))
 266
 267 (define (check-name package)
 268   "Check whether PACKAGE's name matches our guidelines."
 269   (let ((name (package-name package)))
 270     (cond
 271      ;; Currently checks only whether the name is too short.
 272      ((and (<= (string-length name) 1)
 273            (not (string=? name "r"))) ; common-sense exception
 274       (list
 275        (make-warning package
 276                      (G_ "name should be longer than a single character")
 277                      #:field 'name)))
 278      ((string-index name #\_)
 279       (list
 280        (make-warning package
 281                      (G_ "name should use hyphens instead of underscores")
 282                      #:field 'name)))
 283      (else '()))))
 284
 285 (define (check-tests-true package)
 286   "Check whether PACKAGE explicitly requests to run tests, which is
 287 superfluous when building natively and incorrect when cross-compiling."
 288   (define (tests-explicitly-enabled?)
 289     (apply (lambda* (#:key tests? #:allow-other-keys)
 290              (eq? tests? #t))
 291            (package-arguments package)))
 292   (if (and (tests-explicitly-enabled?)
 293            ;; emacs-build-system sets #:tests? #f by default, therefore
 294            ;; writing #:tests? #t in package definitions using
 295            ;; emacs-build-system is reasonable.  Likewise for
 296            ;; texlive-build-system.
 297            ;;
 298            ;; Compare the name of the build system instead of the build system
 299            ;; itself to avoid loading unnecessary modules when only a few
 300            ;; modules are linted.
 301            (not (memq (build-system-name (package-build-system package))
 302                       '(emacs texlive)))
 303            ;; Some packages, e.g. gnutls, set #:tests?
 304            ;; differently depending on whether it is being
 305            ;; cross-compiled.
 306            (parameterize ((%current-target-system "aarch64-linux-gnu"))
 307              (tests-explicitly-enabled?)))
 308       (list (make-warning package
 309                           ;; TRANSLATORS: #:tests? and #t are Scheme constants
 310                           ;; and must not be translated.
 311                           (G_ "#:tests? must not be explicitly set to #t")
 312                           #:field 'arguments))
 313       '()))
 314
 315 (define (properly-starts-sentence? s)
 316   (string-match "^[(\"'`[:upper:][:digit:]]" s))
 317
 318 (define (starts-with-abbreviation? s)
 319   "Return #t if S starts with what looks like an abbreviation or acronym."
 320   (string-match "^[A-Z][A-Z0-9]+\\>" s))
 321
 322 (define %quoted-identifier-rx
 323   ;; A quoted identifier, like 'this'.
 324   (make-regexp "['`][[:graph:]]+'"))
 325
 326 (define (check-description-style package)
 327   ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
 328   (define (check-not-empty description)
 329     (if (string-null? description)
 330         (list
 331          (make-warning package
 332                        (G_ "description should not be empty")
 333                        #:field 'description))
 334         '()))
 335
 336   (define (check-texinfo-markup description)
 337     "Check that DESCRIPTION can be parsed as a Texinfo fragment.  If the
 338 markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
 339     (catch #t
 340       (lambda () (texi->plain-text description))
 341       (lambda (keys . args)
 342         (make-warning package
 343                       (G_ "Texinfo markup in description is invalid")
 344                       #:field 'description))))
 345
 346   (define (check-description-typo description typo-corrections)
 347     "Check that DESCRIPTION does not contain typo, with optional correction"
 348     (append-map
 349      (match-lambda
 350       ((typo . correction)
 351        (if (string-contains description typo)
 352            (list
 353             (make-warning package
 354                           (G_
 355                            (format #false
 356                                    "description contains typo '~a'~@[, should be '~a'~]"
 357                                    typo correction))))
 358            '())))
 359      typo-corrections))
 360
 361   (define (check-trademarks description)
 362     "Check that DESCRIPTION does not contain '™' or '®' characters.  See
 363 http://www.gnu.org/prep/standards/html_node/Trademarks.html."
 364     (match (string-index description (char-set #\™ #\®))
 365       ((and (? number?) index)
 366        (list
 367         (make-warning package
 368                       (G_ "description should not contain ~
 369 trademark sign '~a' at ~d")
 370                       (list (string-ref description index) index)
 371                       #:field 'description)))
 372       (else '())))
 373
 374   (define (check-quotes description)
 375     "Check whether DESCRIPTION contains single quotes and suggest @code."
 376     (if (regexp-exec %quoted-identifier-rx description)
 377         (list
 378          (make-warning package
 379                        ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
 380                        ;; as is.
 381                        (G_ "use @code or similar ornament instead of quotes")
 382                        #:field 'description))
 383         '()))
 384
 385   (define (check-proper-start description)
 386     (if (or (string-null? description)
 387             (properly-starts-sentence? description)
 388             (string-prefix-ci? (package-name package) description))
 389         '()
 390         (list
 391          (make-warning
 392           package
 393           (G_ "description should start with an upper-case letter or digit")
 394           #:field 'description))))
 395
 396   (define (check-end-of-sentence-space description)
 397     "Check that an end-of-sentence period is followed by two spaces."
 398     (let ((infractions
 399            (reverse (fold-matches
 400                      "\\. [A-Z]" description '()
 401                      (lambda (m r)
 402                        ;; Filter out matches of common abbreviations.
 403                        (if (find (lambda (s)
 404                                    (string-suffix-ci? s (match:prefix m)))
 405                                  '("i.e" "e.g" "a.k.a" "resp"))
 406                            r (cons (match:start m) r)))))))
 407       (if (null? infractions)
 408           '()
 409           (list
 410            (make-warning package
 411                          (G_ "sentences in description should be followed ~
 412 by two spaces; possible infraction~p at ~{~a~^, ~}")
 413                          (list (length infractions)
 414                                infractions)
 415                          #:field 'description)))))
 416
 417   (define (check-no-leading-whitespace description)
 418     "Check that DESCRIPTION doesn't have trailing whitespace."
 419     (if (string-prefix? " " description)
 420         (list
 421          (make-warning package
 422                        (G_ "description contains leading whitespace")
 423                        #:field 'description))
 424         '()))
 425
 426   (define (check-no-trailing-whitespace description)
 427     "Check that DESCRIPTION doesn't have trailing whitespace."
 428     (if (string-suffix? " " description)
 429         (list
 430          (make-warning package
 431                        (G_ "description contains trailing whitespace")
 432                        #:field 'description))
 433         '()))
 434
 435   (let ((description (package-description package)))
 436     (if (string? description)
 437         (append
 438          (check-not-empty description)
 439          (check-quotes description)
 440          (check-trademarks description)
 441          (check-description-typo description '(("This packages" . "This package")
 442                                                ("This modules" . "This module")
 443                                                ("allows to" . #f)
 444                                                ("permits to" . #f)))
 445          ;; Use raw description for this because Texinfo rendering
 446          ;; automatically fixes end of sentence space.
 447          (check-end-of-sentence-space description)
 448          (check-no-leading-whitespace description)
 449          (check-no-trailing-whitespace description)
 450          (match (check-texinfo-markup description)
 451            ((and warning (? lint-warning?)) (list warning))
 452            (plain-description
 453             (check-proper-start plain-description))))
 454         (list
 455          (make-warning package
 456                        (G_ "invalid description: ~s")
 457                        (list description)
 458                        #:field 'description)))))
 459
 460 (define (package-input-intersection inputs-to-check input-names)
 461   "Return the intersection between INPUTS-TO-CHECK, the list of input tuples
 462 of a package, and INPUT-NAMES, a list of package specifications such as
 463 \"glib:bin\"."
 464   (match inputs-to-check
 465     (((labels packages . outputs) ...)
 466      (filter-map (lambda (package output)
 467                    (and (package? package)
 468                         (let ((input (string-append
 469                                       (package-name package)
 470                                       (if (> (length output) 0)
 471                                           (string-append ":" (car output))
 472                                           ""))))
 473                           (and (member input input-names)
 474                                input))))
 475                  packages outputs))))
 476
 477 (define (check-inputs-should-be-native package)
 478   ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
 479   ;; native inputs.
 480   (let ((inputs (append (package-inputs package)
 481                         (package-propagated-inputs package)))
 482         (input-names
 483          '("pkg-config"
 484             "autoconf"
 485             "automake"
 486             "bison"
 487             "cmake"
 488             "dejagnu"
 489             "desktop-file-utils"
 490             "doxygen"
 491             "extra-cmake-modules"
 492             "flex"
 493             "gettext"
 494             "glib:bin"
 495             "gobject-introspection"
 496             "googletest-source"
 497             "groff"
 498             "gtk-doc"
 499             "help2man"
 500             "intltool"
 501             "itstool"
 502             "kdoctools"
 503             "libtool"
 504             "m4"
 505             "qttools-5"
 506             "yasm" "nasm" "fasm"
 507             "python-coverage"
 508             "python-cython"
 509             "python-docutils"
 510             "python-mock"
 511             "python-nose"
 512             "python-pbr"
 513             "python-pytest"
 514             "python-pytest-cov"
 515             "python-setuptools-scm"
 516             "python-sphinx"
 517             "scdoc"
 518             "swig"
 519             "qmake"
 520             "qttools-5"
 521             "texinfo"
 522             "xorg-server-for-tests"
 523             "yelp-tools")))
 524     (map (lambda (input)
 525            (make-warning
 526             package
 527             (G_ "'~a' should probably be a native input")
 528             (list input)
 529             #:field 'inputs))
 530          (package-input-intersection inputs input-names))))
 531
 532 (define (check-inputs-should-not-be-an-input-at-all package)
 533   ;; Emit a warning if some inputs of PACKAGE are likely to should not be
 534   ;; an input at all.
 535   (let ((input-names '("python-setuptools"
 536                        "python-pip")))
 537     (map (lambda (input)
 538            (make-warning
 539             package
 540             (G_ "'~a' should probably not be an input at all")
 541             (list input)
 542             #:field 'inputs))
 543          (package-input-intersection (package-direct-inputs package)
 544                                      input-names))))
 545
 546 (define (check-input-labels package)
 547   "Emit a warning for labels that differ from the corresponding package name."
 548   (define (check input-kind package-inputs)
 549     (define (warning label name)
 550       (make-warning package
 551                     (G_ "label '~a' does not match package name '~a'")
 552                     (list label name)
 553                     #:field input-kind))
 554
 555     (append-map (match-lambda
 556                   (((? string? label) (? package? dependency))
 557                    (if (string=? label (package-name dependency))
 558                        '()
 559                        (list (warning label (package-name dependency)))))
 560                   (((? string? label) (? package? dependency) output)
 561                    (let ((expected (string-append (package-name dependency)
 562                                                   ":" output)))
 563                      (if (string=? label expected)
 564                          '()
 565                          (list (warning label expected)))))
 566                   (_
 567                    '()))
 568                 (package-inputs package)))
 569
 570   (append-map (match-lambda
 571                 ((kind proc)
 572                  (check kind proc)))
 573               `((native-inputs ,package-native-inputs)
 574                 (inputs ,package-inputs)
 575                 (propagated-inputs ,package-propagated-inputs))))
 576
 577 (define (report-wrap-program-error package wrapper-name)
 578   "Warn that \"bash-minimal\" is missing from 'inputs', while WRAPPER-NAME
 579 requires it."
 580   (make-warning package
 581                 (G_ "\"bash-minimal\" should be in 'inputs' when '~a' is used")
 582                 (list wrapper-name)))
 583
 584 (define (check-wrapper-inputs package)
 585   "Emit a warning if PACKAGE uses 'wrap-program' or similar, but \"bash\"
 586 or \"bash-minimal\" is not in its inputs. 'wrap-script' is not supported."
 587   (define input-names '("bash" "bash-minimal"))
 588   (define has-bash-input?
 589     (pair? (package-input-intersection (package-inputs package)
 590                                        input-names)))
 591   (define (check-procedure-body body)
 592     (match body
 593       ;; Explicitely setting an interpreter is acceptable.
 594       (('wrap-program _ '#:sh . _) '())
 595       (('wrap-program _ . _)
 596        (list (report-wrap-program-error package 'wrap-program)))
 597       ;; Wrapper of 'wrap-program' for Qt programs.
 598       ;; TODO #:sh is not yet supported but probably will be.
 599       (('wrap-qt-program _ '#:sh . _) '())
 600       (('wrap-qt-program _ . _)
 601        (list (report-wrap-program-error package 'wrap-qt-program)))
 602       ((x . y)
 603        (append (check-procedure-body x) (check-procedure-body y)))
 604       (_ '())))
 605   (define (check-phase-procedure expression)
 606     (find-procedure-body expression check-procedure-body))
 607   (define (check-delta expression)
 608     (find-phase-procedure package expression check-phase-procedure))
 609   (define (check-deltas deltas)
 610     (append-map check-delta deltas))
 611   (if has-bash-input?
 612       ;; "bash" (or "bash-minimal") is in 'inputs', so everything seems ok.
 613       '()
 614       ;; "bash" is not in 'inputs'.  Verify 'wrap-program' and friends
 615       ;; are unused
 616       (find-phase-deltas package check-deltas)))
 617
 618 (define (package-name-regexp package)
 619   "Return a regexp that matches PACKAGE's name as a word at the beginning of a
 620 line."
 621   (make-regexp (string-append "^" (regexp-quote (package-name package))
 622                               "\\>")
 623                regexp/icase))
 624
 625 (define (check-synopsis-style package)
 626   ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
 627   (define (check-final-period synopsis)
 628     ;; Synopsis should not end with a period, except for some special cases.
 629     (if (and (string-suffix? "." synopsis)
 630              (not (string-suffix? "etc." synopsis)))
 631         (list
 632          (make-warning package
 633                        (G_ "no period allowed at the end of the synopsis")
 634                        #:field 'synopsis))
 635         '()))
 636
 637   (define check-start-article
 638     ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
 639     ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>.
 640     (if (false-if-exception (gnu-package? package))
 641         (const '())
 642         (lambda (synopsis)
 643           (if (or (string-prefix-ci? "A " synopsis)
 644                   (string-prefix-ci? "An " synopsis))
 645               (list
 646                (make-warning package
 647                              (G_ "no article allowed at the beginning of \
 648 the synopsis")
 649                              #:field 'synopsis))
 650               '()))))
 651
 652   (define (check-synopsis-length synopsis)
 653     (if (>= (string-length synopsis) 80)
 654         (list
 655          (make-warning package
 656                        (G_ "synopsis should be less than 80 characters long")
 657                        #:field 'synopsis))
 658         '()))
 659
 660   (define (check-proper-start synopsis)
 661     (if (properly-starts-sentence? synopsis)
 662         '()
 663         (list
 664          (make-warning package
 665                        (G_ "synopsis should start with an upper-case letter or digit")
 666                        #:field 'synopsis))))
 667
 668   (define (check-start-with-package-name synopsis)
 669     (if (and (regexp-exec (package-name-regexp package) synopsis)
 670                (not (starts-with-abbreviation? synopsis)))
 671         (list
 672          (make-warning package
 673                        (G_ "synopsis should not start with the package name")
 674                        #:field 'synopsis))
 675         '()))
 676
 677   (define (check-texinfo-markup synopsis)
 678     "Check that SYNOPSIS can be parsed as a Texinfo fragment.  If the
 679 markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
 680     (catch #t
 681       (lambda ()
 682         (texi->plain-text synopsis)
 683         '())
 684       (lambda (keys . args)
 685         (list
 686          (make-warning package
 687                        (G_ "Texinfo markup in synopsis is invalid")
 688                        #:field 'synopsis)))))
 689
 690   (define (check-no-trailing-whitespace synopsis)
 691     "Check that SYNOPSIS doesn't have trailing whitespace."
 692     (if (string-suffix? " " synopsis)
 693         (list
 694          (make-warning package
 695                        (G_ "synopsis contains trailing whitespace")
 696                        #:field 'synopsis))
 697         '()))
 698
 699   (define checks
 700     (list check-proper-start
 701           check-final-period
 702           check-start-article
 703           check-start-with-package-name
 704           check-synopsis-length
 705           check-texinfo-markup
 706           check-no-trailing-whitespace))
 707
 708   (match (package-synopsis package)
 709     (""
 710      (list
 711       (make-warning package
 712                     (G_ "synopsis should not be empty")
 713                     #:field 'synopsis)))
 714     ((? string? synopsis)
 715      (append-map
 716       (lambda (proc)
 717         (proc synopsis))
 718       checks))
 719     (invalid
 720      (list
 721       (make-warning package
 722                     (G_ "invalid synopsis: ~s")
 723                     (list invalid)
 724                     #:field 'synopsis)))))
 725
 726 (define* (probe-uri uri #:key timeout)
 727   "Probe URI, a URI object, and return two values: a symbol denoting the
 728 probing status, such as 'http-response' when we managed to get an HTTP
 729 response from URI, and additional details, such as the actual HTTP response.
 730
 731 TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
 732 for connections to complete; when TIMEOUT is #f, wait as long as needed."
 733   (define headers
 734     `((User-Agent . "GNU Guile")
 735       (Accept . "*/*")
 736       ,@(match (uri-userinfo uri)
 737           ((? string? str)                        ;"basic authentication"
 738            `((Authorization . ,(string-append "Basic "
 739                                               (base64-encode
 740                                                (string->utf8 str))))))
 741           (_ '()))))
 742
 743   (let loop ((uri     uri)
 744              (visited '()))
 745     (match (uri-scheme uri)
 746       ((or 'http 'https)
 747        (catch #t
 748          (lambda ()
 749            (let ((port    (guix:open-connection-for-uri
 750                            uri #:timeout timeout))
 751                  (request (build-request uri #:headers headers)))
 752              (define response
 753                (dynamic-wind
 754                  (const #f)
 755                  (lambda ()
 756                    (write-request request port)
 757                    (force-output port)
 758                    (read-response port))
 759                  (lambda ()
 760                    (close-port port))))
 761
 762              (case (response-code response)
 763                ((302                    ; found (redirection)
 764                  303                    ; see other
 765                  307                    ; temporary redirection
 766                  308)                   ; permanent redirection
 767                 (let ((location (response-location response)))
 768                   (if (or (not location) (member location visited))
 769                       (values 'http-response response)
 770                       (loop location (cons location visited))))) ;follow the redirect
 771                ((301)                   ; moved permanently
 772                 (let ((location (response-location response)))
 773                   ;; Return RESPONSE, unless the final response as we follow
 774                   ;; redirects is not 200.
 775                   (if location
 776                       (let-values (((status response2)
 777                                     (loop location (cons location visited))))
 778                         (case status
 779                           ((http-response)
 780                            (values 'http-response
 781                                    (if (= 200 (response-code response2))
 782                                        response
 783                                        response2)))
 784                           (else
 785                            (values status response2))))
 786                       (values 'http-response response)))) ;invalid redirect
 787                (else
 788                 (values 'http-response response)))))
 789          (lambda (key . args)
 790            (case key
 791              ((bad-header bad-header-component)
 792               ;; This can happen if the server returns an invalid HTTP header,
 793               ;; as is the case with the 'Date' header at sqlite.org.
 794               (values 'invalid-http-response #f))
 795              ((getaddrinfo-error system-error
 796                gnutls-error tls-certificate-error)
 797               (values key args))
 798              (else
 799               (apply throw key args))))))
 800       ('ftp
 801        (catch #t
 802          (lambda ()
 803            (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
 804              (define response
 805                (dynamic-wind
 806                  (const #f)
 807                  (lambda ()
 808                    (ftp-chdir conn (dirname (uri-path uri)))
 809                    (ftp-size conn (basename (uri-path uri))))
 810                  (lambda ()
 811                    (ftp-close conn))))
 812              (values 'ftp-response '(ok))))
 813          (lambda (key . args)
 814            (case key
 815              ((ftp-error)
 816               (values 'ftp-response `(error ,@args)))
 817              ((getaddrinfo-error system-error gnutls-error)
 818               (values key args))
 819              (else
 820               (apply throw key args))))))
 821       (_
 822        (values 'unknown-protocol #f)))))
 823
 824 (define (call-with-networking-fail-safe message error-value proc)
 825   "Call PROC catching any network-related errors.  Upon a networking error,
 826 display a message including MESSAGE and return ERROR-VALUE."
 827   (guard (c ((http-get-error? c)
 828              (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
 829                       message
 830                       (uri->string (http-get-error-uri c))
 831                       (http-get-error-code c)
 832                       (http-get-error-reason c))
 833              error-value))
 834     (catch #t
 835       proc
 836       (match-lambda*
 837         (('getaddrinfo-error errcode)
 838          (warning (G_ "~a: host lookup failure: ~a~%")
 839                   message
 840                   (gai-strerror errcode))
 841          error-value)
 842         (('tls-certificate-error args ...)
 843          (warning (G_ "~a: TLS certificate error: ~a")
 844                   message
 845                   (tls-certificate-error-string args))
 846          error-value)
 847         (('gnutls-error error function _ ...)
 848          (warning (G_ "~a: TLS error in '~a': ~a~%")
 849                   message
 850                   function (error->string error))
 851          error-value)
 852         ((and ('system-error _ ...) args)
 853          (let ((errno (system-error-errno args)))
 854            (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
 855                (let ((details (call-with-output-string
 856                                 (lambda (port)
 857                                   (print-exception port #f (car args)
 858                                                    (cdr args))))))
 859                  (warning (G_ "~a: ~a~%") message details)
 860                  error-value)
 861                (apply throw args))))
 862         (args
 863          (apply throw args))))))
 864
 865 (define-syntax-rule (with-networking-fail-safe message error-value exp ...)
 866   (call-with-networking-fail-safe message error-value
 867                                   (lambda () exp ...)))
 868
 869 (define (tls-certificate-error-string args)
 870   "Return a string explaining the 'tls-certificate-error' arguments ARGS."
 871   (call-with-output-string
 872     (lambda (port)
 873       (print-exception port #f
 874                        'tls-certificate-error args))))
 875
 876 (define (validate-uri uri package field)
 877   "Return #t if the given URI can be reached, otherwise return a warning for
 878 PACKAGE mentioning the FIELD."
 879   (let-values (((status argument)
 880                 (probe-uri uri #:timeout 3)))     ;wait at most 3 seconds
 881     (case status
 882       ((http-response)
 883        (cond ((= 200 (response-code argument))
 884               (match (response-content-length argument)
 885                 ((? number? length)
 886                  ;; As of July 2016, SourceForge returns 200 (instead of 404)
 887                  ;; with a small HTML page upon failure.  Attempt to detect
 888                  ;; such malicious behavior.
 889                  (or (> length 1000)
 890                      (make-warning package
 891                                    (G_ "URI ~a returned \
 892 suspiciously small file (~a bytes)")
 893                                    (list (uri->string uri)
 894                                          length)
 895                                    #:field field)))
 896                 (_ #t)))
 897              ((= 301 (response-code argument))
 898               (if (response-location argument)
 899                   (make-warning package
 900                                 (G_ "permanent redirect from ~a to ~a")
 901                                 (list (uri->string uri)
 902                                       (uri->string
 903                                        (response-location argument)))
 904                                 #:field field)
 905                   (make-warning package
 906                                 (G_ "invalid permanent redirect \
 907 from ~a")
 908                                 (list (uri->string uri))
 909                                 #:field field)))
 910              (else
 911               (make-warning package
 912                             (G_ "URI ~a not reachable: ~a (~s)")
 913                             (list (uri->string uri)
 914                                   (response-code argument)
 915                                   (response-reason-phrase argument))
 916                             #:field field))))
 917       ((ftp-response)
 918        (match argument
 919          (('ok) #t)
 920          (('error port command code message)
 921           (make-warning package
 922                         (G_ "URI ~a not reachable: ~a (~s)")
 923                         (list (uri->string uri)
 924                               code (string-trim-both message))
 925                         #:field field))))
 926       ((getaddrinfo-error)
 927        (make-warning package
 928                      (G_ "URI ~a domain not found: ~a")
 929                      (list (uri->string uri)
 930                            (gai-strerror (car argument)))
 931                      #:field field))
 932       ((system-error)
 933        (make-warning package
 934                      (G_ "URI ~a unreachable: ~a")
 935                      (list (uri->string uri)
 936                            (strerror
 937                             (system-error-errno
 938                              (cons status argument))))
 939                      #:field field))
 940       ((tls-certificate-error)
 941        (make-warning package
 942                      (G_ "TLS certificate error: ~a")
 943                      (list (tls-certificate-error-string argument))
 944                      #:field field))
 945       ((invalid-http-response gnutls-error)
 946        ;; Probably a misbehaving server; ignore.
 947        #f)
 948       ((unknown-protocol)                         ;nothing we can do
 949        #f)
 950       (else
 951        (error "internal linter error" status)))))
 952
 953 (define (check-home-page package)
 954   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 955 'home-page' is not reachable."
 956   (let ((uri (and=> (package-home-page package) string->uri)))
 957     (cond
 958      ((uri? uri)
 959       (match (validate-uri uri package 'home-page)
 960         ((and (? lint-warning? warning) warning)
 961          (list warning))
 962         (_ '())))
 963      ((not (package-home-page package))
 964       (if (or (string-contains (package-name package) "bootstrap")
 965               (string=? (package-name package) "ld-wrapper"))
 966           '()
 967           (list
 968            (make-warning package
 969                          (G_ "invalid value for home page")
 970                          #:field 'home-page))))
 971      (else
 972       (list
 973        (make-warning package
 974                      (G_ "invalid home page URL: ~s")
 975                      (list (package-home-page package))
 976                      #:field 'home-page))))))
 977
 978 (define %distro-directory
 979   (mlambda ()
 980     (dirname (search-path %load-path "gnu.scm"))))
 981
 982 (define (check-patch-file-names package)
 983   "Emit a warning if the patches requires by PACKAGE are badly named or if the
 984 patch could not be found."
 985   (guard (c ((formatted-message? c)               ;raised by 'search-patch'
 986              (list (%make-warning package
 987                                   (formatted-message-string c)
 988                                   (formatted-message-arguments c)
 989                                   #:field 'source))))
 990     (define patches
 991       (match (package-source package)
 992         ((? origin? origin) (origin-patches origin))
 993         (_ '())))
 994
 995     (define (starts-with-package-name? file-name)
 996       (and=> (string-contains file-name (package-name package))
 997              zero?))
 998
 999     (append
1000      (if (every (match-lambda        ;patch starts with package name?
1001                   ((? string? patch)
1002                    (starts-with-package-name? (basename patch)))
1003                   ((? origin? patch)
1004                    (starts-with-package-name? (origin-actual-file-name patch)))
1005                   (_  #f))     ;must be some other file-like object
1006                 patches)
1007          '()
1008          (list
1009           (make-warning
1010            package
1011            (G_ "file names of patches should start with the package name")
1012            #:field 'patch-file-names)))
1013
1014      ;; Check whether we're reaching tar's maximum file name length.
1015      (let ((prefix (string-length (%distro-directory)))
1016            ;; Margin approximating the largest path that "make dist" might
1017            ;; create, with a release candidate version, 123456 commits, and
1018            ;; git commit hash abcde0.
1019            (margin (string-length "guix-92.0.0rc3-123456-abcde0/"))
1020            ;; Tested maximum patch file length for ustar format.
1021            (max    151))
1022        (filter-map (match-lambda
1023                      ((? string? patch)
1024                       (if (> (+ margin (if (string-prefix? (%distro-directory)
1025                                                            patch)
1026                                            (- (string-length patch) prefix)
1027                                            (string-length patch)))
1028                              max)
1029                           (make-warning
1030                            package
1031                            (G_ "~a: file name is too long, which may break 'make dist'")
1032                            (list (basename patch))
1033                            #:field 'patch-file-names)
1034                           #f))
1035                      (_ #f))
1036                    patches)))))
1037
1038 (define (check-patch-headers package)
1039   "Check that PACKAGE's patches start with a comment.  Return a list of
1040 warnings."
1041   (define (blank? str)
1042     (string-every char-set:blank str))
1043
1044   (define (patch-header-warnings patch)
1045     (call-with-input-file patch
1046       (lambda (port)
1047         ;; Read from PORT until a non-blank line is found or EOF is reached.
1048         (let loop ()
1049           (let ((line (read-line port)))
1050             (cond ((eof-object? line)
1051                    (list (make-warning package
1052                                        (G_ "~a: empty patch")
1053                                        (list (basename patch))
1054                                        #:field 'source)))
1055                   ((blank? line)
1056                    (loop))
1057                   ((or (string-prefix? "--- " line)
1058                        (string-prefix? "+++ " line)
1059                        (string-prefix? "diff --git " line))
1060                    (list (make-warning package
1061                                        (G_ "~a: patch lacks comment and \
1062 upstream status")
1063                                        (list (basename patch))
1064                                        #:field 'source)))
1065                   (else
1066                    '())))))))
1067
1068   (guard (c ((formatted-message? c)               ;raised by 'search-patch'
1069              (list (%make-warning package
1070                                   (formatted-message-string c)
1071                                   (formatted-message-arguments c)
1072                                   #:field 'source))))
1073    (let ((patches (if (origin? (package-source package))
1074                       (origin-patches (package-source package))
1075                       '())))
1076      (append-map (lambda (patch)
1077                    ;; Dismiss PATCH if it's an origin or similar.
1078                    (cond ((string? patch)
1079                           (patch-header-warnings patch))
1080                          ((local-file? patch)
1081                           (patch-header-warnings
1082                            (local-file-absolute-file-name patch)))
1083                          (else
1084                           '())))
1085                  patches))))
1086
1087 (define (escape-quotes str)
1088   "Replace any quote character in STR by an escaped quote character."
1089   (list->string
1090    (string-fold-right (lambda (chr result)
1091                         (match chr
1092                           (#\" (cons* #\\ #\"result))
1093                           (_   (cons chr result))))
1094                       '()
1095                       str)))
1096
1097 (define official-gnu-packages*
1098   (mlambda ()
1099     "A memoizing version of 'official-gnu-packages' that returns the empty
1100 list when something goes wrong, such as a networking issue."
1101     (let ((gnus (false-if-exception (official-gnu-packages))))
1102       (or gnus '()))))
1103
1104 (define (check-gnu-synopsis+description package)
1105   "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
1106 descriptions maintained upstream."
1107   (match (find (lambda (descriptor)
1108                  (string=? (gnu-package-name descriptor)
1109                            (package-name package)))
1110                (official-gnu-packages*))
1111     (#f                                   ;not a GNU package, so nothing to do
1112      '())
1113     (descriptor                                   ;a genuine GNU package
1114      (append
1115       (let ((upstream   (gnu-package-doc-summary descriptor))
1116             (downstream (package-synopsis package)))
1117         (if (and upstream
1118                  (or (not (string? downstream))
1119                      (not (string=? upstream downstream))))
1120             (list
1121              (make-warning package
1122                            (G_ "proposed synopsis: ~s~%")
1123                            (list upstream)
1124                            #:field 'synopsis))
1125             '()))
1126
1127       (let ((upstream   (gnu-package-doc-description descriptor))
1128             (downstream (package-description package)))
1129         (if (and upstream
1130                  (or (not (string? downstream))
1131                      (not (string=? (fill-paragraph upstream 100)
1132                                     (fill-paragraph downstream 100)))))
1133             (list
1134              (make-warning
1135               package
1136               (G_ "proposed description:~%     \"~a\"~%")
1137               (list (fill-paragraph (escape-quotes upstream) 77 7))
1138               #:field 'description))
1139             '()))))))
1140
1141 (define (origin-uris origin)
1142   "Return the list of URIs (strings) for ORIGIN."
1143   (match (origin-uri origin)
1144     ((? string? uri)
1145      (list uri))
1146     ((uris ...)
1147      uris)))
1148
1149 (define (svn-reference-uri-with-userinfo ref)
1150   "Return the URI of REF, an <svn-reference> or <svn-multi-reference> object,
1151 but with an additional 'userinfo' part corresponding to REF's user name and
1152 password, provided REF's URI is HTTP or HTTPS."
1153   ;; XXX: For lack of record type inheritance.
1154   (define ->url
1155     (if (svn-reference? ref)
1156         svn-reference-url
1157         svn-multi-reference-url))
1158   (define ->user-name
1159     (if (svn-reference? ref)
1160         svn-reference-user-name
1161         svn-multi-reference-user-name))
1162   (define ->password
1163     (if (svn-reference? ref)
1164         svn-reference-password
1165         svn-multi-reference-password))
1166
1167   (let ((uri (string->uri (->url ref))))
1168     (if (and (->user-name ref)
1169              (memq (uri-scheme uri) '(http https)))
1170         (build-uri (uri-scheme uri)
1171                    #:userinfo
1172                    (string-append (->user-name ref)
1173                                   (if (->password ref)
1174                                       (string-append
1175                                        ":" (->password ref))
1176                                       ""))
1177                    #:host (uri-host uri)
1178                    #:port (uri-port uri)
1179                    #:query (uri-query uri)
1180                    #:fragment (uri-fragment uri))
1181         uri)))
1182
1183 (define (check-source package)
1184   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
1185 'source' is not reachable."
1186   (define (warnings-for-uris uris)
1187     (let loop ((uris uris)
1188                (warnings '()))
1189       (match uris
1190         (()
1191          (reverse warnings))
1192         ((uri rest ...)
1193          (match (validate-uri uri package 'source)
1194            (#t
1195             ;; We found a working URL, so stop right away.
1196             '())
1197            (#f
1198             ;; Unsupported URL or other error, skip.
1199             (loop rest warnings))
1200            ((? lint-warning? warning)
1201             (loop rest (cons warning warnings))))))))
1202
1203   (let ((origin (package-source package)))
1204     (if (origin? origin)
1205         (cond
1206          ((eq? (origin-method origin) url-fetch)
1207           (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
1208                                        (map string->uri (origin-uris origin))))
1209                  (warnings (warnings-for-uris uris)))
1210
1211             ;; Just make sure that at least one of the URIs is valid.
1212             (if (= (length uris) (length warnings))
1213                 ;; When everything fails, report all of WARNINGS, otherwise don't
1214                 ;; report anything.
1215                 ;;
1216                 ;; XXX: Ideally we'd still allow warnings to be raised if *some*
1217                 ;; URIs are unreachable, but distinguish that from the error case
1218                 ;; where *all* the URIs are unreachable.
1219                 (cons*
1220                  (make-warning package
1221                                (G_ "all the source URIs are unreachable:")
1222                                #:field 'source)
1223                  warnings)
1224                 '())))
1225          ((git-reference? (origin-uri origin))
1226           (warnings-for-uris
1227            (list (string->uri (git-reference-url (origin-uri origin))))))
1228          ((or (svn-reference? (origin-uri origin))
1229               (svn-multi-reference? (origin-uri origin)))
1230           (let ((uri (svn-reference-uri-with-userinfo (origin-uri origin))))
1231             (if (memq (uri-scheme uri) '(http https))
1232                 (warnings-for-uris (list uri))
1233                 '())))                            ;TODO: handle svn:// URLs
1234          (else
1235           '()))
1236         '())))
1237
1238 (define (check-source-file-name package)
1239   "Emit a warning if PACKAGE's origin has no meaningful file name."
1240   (define (origin-file-name-valid? origin)
1241     ;; Return #f if the source file name contains only a version or is #f;
1242     ;; indicates that the origin needs a 'file-name' field.
1243     (let ((file-name (origin-actual-file-name origin))
1244           (version (package-version package)))
1245       (and file-name
1246            ;; Common in many projects is for the filename to start
1247            ;; with a "v" followed by the version,
1248            ;; e.g. "v3.2.0.tar.gz".
1249            (not (string-match (string-append "^v?" version) file-name)))))
1250
1251   (let ((origin (package-source package)))
1252     (if (or (not (origin? origin)) (origin-file-name-valid? origin))
1253         '()
1254         (list
1255          (make-warning package
1256                        (G_ "the source file name should contain the package name")
1257                        #:field 'source)))))
1258
1259 (define (check-source-unstable-tarball package)
1260   "Emit a warning if PACKAGE's source is an autogenerated tarball."
1261   (define (check-source-uri uri)
1262     (if (and (string=? (uri-host (string->uri uri)) "github.com")
1263              (match (split-and-decode-uri-path
1264                      (uri-path (string->uri uri)))
1265                ((_ _ "archive" _ ...) #t)
1266                (_ #f)))
1267         (make-warning package
1268                       (G_ "the source URI should not be an autogenerated tarball")
1269                       #:field 'source)
1270         #f))
1271
1272   (let ((origin (package-source package)))
1273     (if (and (origin? origin)
1274              (eqv? (origin-method origin) url-fetch))
1275         (filter-map check-source-uri
1276                     (origin-uris origin))
1277         '())))
1278
1279 (define (check-mirror-url package)
1280   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
1281   (define (check-mirror-uri uri)
1282     (define rewritten-uri
1283       (uri-mirror-rewrite uri))
1284
1285     (and (not (string=? uri rewritten-uri))
1286          (make-warning package (G_ "URL should be '~a'")
1287                        (list rewritten-uri)
1288                        #:field 'source)))
1289
1290   (let ((origin (package-source package)))
1291     (if (and (origin? origin)
1292              (eqv? (origin-method origin) url-fetch))
1293         (let ((uris (origin-uris origin)))
1294           (filter-map check-mirror-uri uris))
1295         '())))
1296
1297 (define* (check-github-url package #:key (timeout 3))
1298   "Check whether PACKAGE uses source URLs that redirect to GitHub."
1299   (define (follow-redirect url)
1300     (let* ((uri      (string->uri url))
1301            (port     (guix:open-connection-for-uri uri #:timeout timeout))
1302            (response (http-head uri #:port port)))
1303       (close-port port)
1304       (case (response-code response)
1305         ((301 302)
1306          (uri->string (assoc-ref (response-headers response) 'location)))
1307         (else #f))))
1308
1309   (define (follow-redirects-to-github uri)
1310     (cond
1311      ((string-prefix? "https://github.com/" uri) uri)
1312      ((string-prefix? "http" uri)
1313       (and=> (follow-redirect uri) follow-redirects-to-github))
1314      ;; Do not attempt to follow redirects on URIs other than http and https
1315      ;; (such as mirror, file)
1316      (else #f)))
1317
1318   (let ((origin (package-source package)))
1319     (if (and (origin? origin)
1320              (eqv? (origin-method origin) url-fetch))
1321         (filter-map
1322          (lambda (uri)
1323            (and=> (with-networking-fail-safe
1324                    (format #f (G_ "while accessing '~a'") uri)
1325                    #f
1326                    (follow-redirects-to-github uri))
1327                   (lambda (github-uri)
1328                     (and (not (string=? github-uri uri))
1329                          (make-warning
1330                           package
1331                           (G_ "URL should be '~a'")
1332                           (list github-uri)
1333                           #:field 'source)))))
1334          (origin-uris origin))
1335         '())))
1336
1337 ;; Guile 3.0.0 does not export this predicate.
1338 (define exception-with-kind-and-args?
1339   (exception-predicate &exception-with-kind-and-args))
1340
1341 (define (check-optional-tests package)
1342   "Emit a warning if the test suite is run unconditionally."
1343   (define (sexp-contains-atom? sexp atom)
1344     "Test if SEXP contains ATOM."
1345     (if (pair? sexp)
1346         (or (sexp-contains-atom? (car sexp) atom)
1347             (sexp-contains-atom? (cdr sexp) atom))
1348         (eq? sexp atom)))
1349   (define (sexp-uses-tests?? sexp)
1350     "Test if SEXP contains the symbol 'tests?'."
1351     (sexp-contains-atom? sexp 'tests?))
1352   (define (check-procedure-body code)
1353     (if (sexp-uses-tests?? code)
1354         '()
1355         (list (make-warning package
1356                             ;; TRANSLATORS: check and #:tests? are a
1357                             ;; Scheme symbol and keyword respectively
1358                             ;; and should not be translated.
1359                             (G_ "the 'check' phase should respect #:tests?")
1360                             #:field 'arguments))))
1361   (define (check-check-procedure expression)
1362     (find-procedure-body expression check-procedure-body))
1363   (define (check-phases-delta delta)
1364     (match delta
1365       (`(replace 'check ,expression)
1366        (check-check-procedure expression))
1367       (_ '())))
1368   (define (check-phases-deltas deltas)
1369     (append-map check-phases-delta deltas))
1370   (find-phase-deltas package check-phases-deltas))
1371
1372 (define* (check-derivation package #:key store)
1373   "Emit a warning if we fail to compile PACKAGE to a derivation."
1374   (define (try store system)
1375     (guard (c ((store-protocol-error? c)
1376                (make-warning package
1377                              (G_ "failed to create ~a derivation: ~a")
1378                              (list system
1379                                    (store-protocol-error-message c))))
1380               ((exception-with-kind-and-args? c)
1381                (make-warning package
1382                              (G_ "failed to create ~a derivation: ~s")
1383                              (list system
1384                                    (cons (exception-kind c)
1385                                          (exception-args c)))))
1386               ((message-condition? c)
1387                (make-warning package
1388                              (G_ "failed to create ~a derivation: ~a")
1389                              (list system
1390                                    (condition-message c))))
1391               ((formatted-message? c)
1392                (let ((str (apply format #f
1393                                  (formatted-message-string c)
1394                                  (formatted-message-arguments c))))
1395                  (make-warning package
1396                                (G_ "failed to create ~a derivation: ~a")
1397                                (list system str))))
1398               (else
1399                (make-warning package
1400                              (G_ "failed to create ~a derivation: ~a")
1401                              (list system c))))
1402       (parameterize ((%graft? #f))
1403         (package-derivation store package system #:graft? #f)
1404
1405         ;; If there's a replacement, make sure we can compute its
1406         ;; derivation.
1407         (match (package-replacement package)
1408           (#f #t)
1409           (replacement
1410            (package-derivation store replacement system
1411                                #:graft? #f))))))
1412
1413   (define (check-with-store store)
1414     (filter lint-warning?
1415             (map (cut try store <>) (package-supported-systems package))))
1416
1417   ;; For backwards compatability, don't rely on store being set
1418   (or (and=> store check-with-store)
1419       (with-store store
1420         (check-with-store store))))
1421
1422 (define* (check-profile-collisions package #:key store)
1423   "Check for collisions that would occur when installing PACKAGE as a result
1424 of the propagated inputs it pulls in."
1425   (define (do-check store)
1426     (guard (c ((profile-collision-error? c)
1427                (let ((first  (profile-collision-error-entry c))
1428                      (second (profile-collision-error-conflict c)))
1429                  (define format
1430                    (if (string=? (manifest-entry-version first)
1431                                  (manifest-entry-version second))
1432                        manifest-entry-item
1433                        (lambda (entry)
1434                          (string-append (manifest-entry-name entry) "@"
1435                                         (manifest-entry-version entry)))))
1436
1437                  (list (make-warning package
1438                                      (G_ "propagated inputs ~a and ~a collide")
1439                                      (list (format first)
1440                                            (format second)))))))
1441       ;; Disable grafts to avoid building PACKAGE and its dependencies.
1442       (parameterize ((%graft? #f))
1443         (run-with-store store
1444           (mbegin %store-monad
1445             (check-for-collisions (packages->manifest (list package))
1446                                   (%current-system))
1447             (return '()))))))
1448
1449   (if store
1450       (do-check store)
1451       (with-store store
1452         (do-check store))))
1453
1454 (define (check-license package)
1455   "Warn about type errors of the 'license' field of PACKAGE."
1456   (match (package-license package)
1457     ((or (? license?)
1458          ((? license?) ...))
1459      '())
1460     (x
1461      (list
1462       (make-warning package (G_ "invalid license field")
1463                     #:field 'license)))))
1464
1465 (define (current-vulnerabilities*)
1466   "Like 'current-vulnerabilities', but return the empty list upon networking
1467 or HTTP errors.  This allows network-less operation and makes problems with
1468 the NIST server non-fatal."
1469   (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
1470                              '()
1471                              (current-vulnerabilities #:timeout 4)))
1472
1473 (define package-vulnerabilities
1474   (let ((lookup (delay (vulnerabilities->lookup-proc
1475                         (current-vulnerabilities*)))))
1476     (lambda (package)
1477       "Return a list of vulnerabilities affecting PACKAGE."
1478       ;; First we retrieve the Common Platform Enumeration (CPE) name and
1479       ;; version for PACKAGE, then we can pass them to LOOKUP.
1480       (let ((name    (or (assoc-ref (package-properties package)
1481                                     'cpe-name)
1482                          (package-name package)))
1483             (version (or (assoc-ref (package-properties package)
1484                                     'cpe-version)
1485                          (package-version package))))
1486         ((force lookup) name version)))))
1487
1488 (define* (check-vulnerabilities package
1489                                 #:optional (package-vulnerabilities
1490                                             package-vulnerabilities))
1491   "Check for known vulnerabilities for PACKAGE.  Obtain the list of
1492 vulnerability records for PACKAGE by calling PACKAGE-VULNERABILITIES."
1493   (let ((package (or (package-replacement package) package)))
1494     (match (package-vulnerabilities package)
1495       (()
1496        '())
1497       ((vulnerabilities ...)
1498        (let* ((patched    (package-patched-vulnerabilities package))
1499               (known-safe (or (assq-ref (package-properties package)
1500                                         'lint-hidden-cve)
1501                               '()))
1502               (unpatched (remove (lambda (vuln)
1503                                    (let ((id (vulnerability-id vuln)))
1504                                      (or (member id patched)
1505                                          (member id known-safe))))
1506                                  vulnerabilities)))
1507          (if (null? unpatched)
1508              '()
1509              (list
1510               (make-warning
1511                package
1512                (G_ "probably vulnerable to ~a")
1513                (list (string-join (map vulnerability-id unpatched)
1514                                   ", "))))))))))
1515
1516 (define (check-for-updates package)
1517   "Check if there is an update available for PACKAGE."
1518   (match (lookup-updater package)
1519     (#f
1520      (list (make-warning package (G_ "no updater for ~a")
1521                          (list (package-name package))
1522                          #:field 'source)))
1523     ((? upstream-updater? updater)
1524      (match (with-networking-fail-safe
1525              (format #f (G_ "while retrieving upstream info for '~a'")
1526                      (package-name package))
1527              #f
1528              (package-latest-release package))
1529        ((? upstream-source? source)
1530         (if (version>? (upstream-source-version source)
1531                        (package-version package))
1532             (list
1533              (make-warning package
1534                            (G_ "can be upgraded to ~a")
1535                            (list (upstream-source-version source))
1536                            #:field 'version))
1537             '()))
1538        (#f                                       ;cannot find upstream release
1539         (list (make-warning package
1540                             (G_ "updater '~a' failed to find \
1541 upstream releases")
1542                             (list (upstream-updater-name updater))
1543                             #:field 'source)))))))
1544
1545
1546 (define (lookup-disarchive-spec hash)
1547   "If Disarchive mirrors have a spec for HASH, return the list of SWH
1548 directory identifiers the spec refers to.  Otherwise return #f."
1549   (define (extract-swh-id spec)
1550     ;; Return the list of SWH directory identifiers SPEC refers to, where SPEC
1551     ;; is a Disarchive sexp.  Instead of attempting to parse it, traverse it
1552     ;; in a pretty unintelligent fashion.
1553     (let loop ((sexp spec)
1554                (ids '()))
1555       (match sexp
1556         ((? string? str)
1557          (let ((prefix "swh:1:dir:"))
1558            (if (string-prefix? prefix str)
1559                (cons (string-drop str (string-length prefix)) ids)
1560                ids)))
1561         ((head tail ...)
1562          (loop tail (loop head ids)))
1563         (_ ids))))
1564
1565   (any (lambda (mirror)
1566          (with-networking-fail-safe
1567           (format #f (G_ "failed to access Disarchive database at ~a")
1568                   mirror)
1569           #f
1570           (guard (c ((http-get-error? c) #f))
1571             (let* ((url (string-append mirror
1572                                        (symbol->string
1573                                         (content-hash-algorithm hash))
1574                                        "/"
1575                                        (bytevector->base16-string
1576                                         (content-hash-value hash))))
1577                    (port (http-fetch (string->uri url) #:text? #t))
1578                    (spec (read port)))
1579               (close-port port)
1580               (extract-swh-id spec)))))
1581        %disarchive-mirrors))
1582
1583 (define (check-archival package)
1584   "Check whether PACKAGE's source code is archived on Software Heritage.  If
1585 it's not, and if its source code is a VCS snapshot, then send a \"save\"
1586 request to Software Heritage.
1587
1588 Software Heritage imposes limits on the request rate per client IP address.
1589 This checker prints a notice and stops doing anything once that limit has been
1590 reached."
1591   (define (response->warning url method response)
1592     (if (request-rate-limit-reached? url method)
1593         (list (make-warning package
1594                             (G_ "Software Heritage rate limit reached; \
1595 try again later")
1596                             #:field 'source))
1597         (list (make-warning package
1598                             (G_ "'~a' returned ~a")
1599                             (list url (response-code response))
1600                             #:field 'source))))
1601
1602   (define skip-key (gensym "skip-archival-check"))
1603
1604   (define (skip-when-limit-reached url method)
1605     (or (not (request-rate-limit-reached? url method))
1606         (throw skip-key #t)))
1607
1608   (parameterize ((%allow-request? skip-when-limit-reached))
1609     (catch #t
1610       (lambda ()
1611         (match (and (origin? (package-source package))
1612                     (package-source package))
1613           (#f                                     ;no source
1614            '())
1615           ((= origin-uri (? git-reference? reference))
1616            (define url
1617              (git-reference-url reference))
1618            (define commit
1619              (git-reference-commit reference))
1620
1621            (match (if (commit-id? commit)
1622                       (or (lookup-revision commit)
1623                           (lookup-origin-revision url commit))
1624                       (lookup-origin-revision url commit))
1625              ((? revision? revision)
1626               '())
1627              (#f
1628               ;; Revision is missing from the archive, attempt to save it.
1629               (catch 'swh-error
1630                 (lambda ()
1631                   (save-origin (git-reference-url reference) "git")
1632                   (list (make-warning
1633                          package
1634                          ;; TRANSLATORS: "Software Heritage" is a proper noun
1635                          ;; that must remain untranslated.  See
1636                          ;; <https://www.softwareheritage.org>.
1637                          (G_ "scheduled Software Heritage archival")
1638                          #:field 'source)))
1639                 (lambda (key url method response . _)
1640                   (cond ((= 429 (response-code response))
1641                          (list (make-warning
1642                                 package
1643                                 (G_ "archival rate limit exceeded; \
1644 try again later")
1645                                 #:field 'source)))
1646                         (else
1647                          (response->warning url method response))))))))
1648           ((? origin? origin)
1649            ;; Since "save" origins are not supported for non-VCS source, all
1650            ;; we can do is tell whether a given tarball is available or not.
1651            (if (and=> (origin-hash origin)          ;XXX: for ungoogled-chromium
1652                       content-hash-value)           ;& icecat
1653                (let ((hash (origin-hash origin)))
1654                  (match (lookup-content (content-hash-value hash)
1655                                         (symbol->string
1656                                          (content-hash-algorithm hash)))
1657                    (#f
1658                     ;; If SWH doesn't have HASH as is, it may be because it's
1659                     ;; a hand-crafted tarball.  In that case, check whether
1660                     ;; the Disarchive database has an entry for that tarball.
1661                     (match (lookup-disarchive-spec hash)
1662                       (#f
1663                        (list (make-warning package
1664                                            (G_ "source not archived on Software \
1665 Heritage and missing from the Disarchive database")
1666                                            #:field 'source)))
1667                       (directory-ids
1668                        (match (find (lambda (id)
1669                                       (not (lookup-directory id)))
1670                                     directory-ids)
1671                          (#f '())
1672                          (id
1673                           (list (make-warning package
1674                                               (G_ "\
1675 Disarchive entry refers to non-existent SWH directory '~a'")
1676                                               (list id)
1677                                               #:field 'source)))))))
1678                    ((? content?)
1679                     '())))
1680                '()))
1681           (_
1682            (list (make-warning package
1683                                (G_ "unsupported source type")
1684                                #:field 'source)))))
1685       (match-lambda*
1686         (('swh-error url method response)
1687          (response->warning url method response))
1688         ((key . args)
1689          (if (eq? key skip-key)
1690              '()
1691              (with-networking-fail-safe
1692               (G_ "while connecting to Software Heritage")
1693               '()
1694               (apply throw key args))))))))
1695
1696 (define (check-haskell-stackage package)
1697   "Check whether PACKAGE is a Haskell package ahead of the current
1698 Stackage LTS version."
1699   (match (with-networking-fail-safe
1700           (format #f (G_ "while retrieving upstream info for '~a'")
1701                   (package-name package))
1702           #f
1703           (package-latest-release package (list %stackage-updater)))
1704     ((? upstream-source? source)
1705      (if (version>? (package-version package)
1706                     (upstream-source-version source))
1707          (list
1708           (make-warning package
1709                         (G_ "ahead of Stackage LTS version ~a")
1710                         (list (upstream-source-version source))
1711                         #:field 'version))
1712          '()))
1713     (#f '())))
1714
1715 \f
1716 ;;;
1717 ;;; Source code formatting.
1718 ;;;
1719
1720 (define (report-tabulations package line line-number)
1721   "Warn about tabulations found in LINE."
1722   (match (string-index line #\tab)
1723     (#f #f)
1724     (index
1725      (make-warning package
1726                    (G_ "tabulation on line ~a, column ~a")
1727                    (list line-number index)
1728                    #:location
1729                    (location (package-file package)
1730                              line-number
1731                              index)))))
1732
1733 (define (report-trailing-white-space package line line-number)
1734   "Warn about trailing white space in LINE."
1735   (and (not (or (string=? line (string-trim-right line))
1736                 (string=? line (string #\page))))
1737        (make-warning package
1738                      (G_ "trailing white space on line ~a")
1739                      (list line-number)
1740                      #:location
1741                      (location (package-file package)
1742                                line-number
1743                                0))))
1744
1745 (define (report-long-line package line line-number)
1746   "Emit a warning if LINE is too long."
1747   ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
1748   ;; make it hard to fit within that limit and we want to avoid making too
1749   ;; much noise.
1750   (and (> (string-length line) 90)
1751        (make-warning package
1752                      (G_ "line ~a is way too long (~a characters)")
1753                      (list line-number (string-length line))
1754                      #:location
1755                      (location (package-file package)
1756                                line-number
1757                                0))))
1758
1759 (define %hanging-paren-rx
1760   (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
1761
1762 (define (report-lone-parentheses package line line-number)
1763   "Emit a warning if LINE contains hanging parentheses."
1764   (and (regexp-exec %hanging-paren-rx line)
1765        (make-warning package
1766                      (G_ "parentheses feel lonely, \
1767 move to the previous or next line")
1768                      (list line-number)
1769                      #:location
1770                      (location (package-file package)
1771                                line-number
1772                                0))))
1773
1774 (define %formatting-reporters
1775   ;; List of procedures that report formatting issues.  These are not separate
1776   ;; checkers because they would need to re-read the file.
1777   (list report-tabulations
1778         report-trailing-white-space
1779         report-long-line
1780         report-lone-parentheses))
1781
1782 (define* (report-formatting-issues package file starting-line
1783                                    #:key (reporters %formatting-reporters))
1784   "Report white-space issues in FILE starting from STARTING-LINE, and report
1785 them for PACKAGE."
1786   (define (sexp-last-line port)
1787     ;; Return the last line of the sexp read from PORT or an estimate thereof.
1788     (define &failure (list 'failure))
1789
1790     (let ((start      (ftell port))
1791           (start-line (port-line port))
1792           (sexp       (catch 'read-error
1793                         (lambda () (read port))
1794                         (const &failure))))
1795       (let ((line (port-line port)))
1796         (seek port start SEEK_SET)
1797         (set-port-line! port start-line)
1798         (if (eq? sexp &failure)
1799             (+ start-line 60)                     ;conservative estimate
1800             line))))
1801
1802   (call-with-input-file file
1803     (lambda (port)
1804       (let loop ((line-number 1)
1805                  (last-line #f)
1806                  (warnings '()))
1807         (let ((line (read-line port)))
1808           (if (or (eof-object? line)
1809                   (and last-line (> line-number last-line)))
1810               warnings
1811               (if (and (= line-number starting-line)
1812                        (not last-line))
1813                   (loop (+ 1 line-number)
1814                         (+ 1 (sexp-last-line port))
1815                         warnings)
1816                   (loop (+ 1 line-number)
1817                         last-line
1818                         (append
1819                          warnings
1820                          (if (< line-number starting-line)
1821                              '()
1822                              (filter-map (lambda (report)
1823                                            (report package line line-number))
1824                                          reporters)))))))))))
1825
1826 (define (check-formatting package)
1827   "Check the formatting of the source code of PACKAGE."
1828   (let ((location (package-location package)))
1829     (if location
1830         ;; Report issues starting from the line before the 'package'
1831         ;; form, which usually contains the 'define' form.
1832         (let ((line (- (location-line location) 1)))
1833           (match (search-path %load-path (location-file location))
1834             ((? string? file)
1835              (report-formatting-issues package file line))
1836             (#f
1837              ;; It could be that LOCATION lists a "true" relative file
1838              ;; name--i.e., not relative to an element of %LOAD-PATH.
1839              (let ((file (location-file location)))
1840                (if (file-exists? file)
1841                    (report-formatting-issues package file line)
1842                    (list (make-warning package
1843                                        (G_ "source file not found"))))))))
1844         '())))
1845
1846 \f
1847 ;;;
1848 ;;; List of checkers.
1849 ;;;
1850
1851 (define %local-checkers
1852   (list
1853    (lint-checker
1854      (name        'name)
1855      (description "Validate package names")
1856      (check       check-name))
1857    (lint-checker
1858      (name        'tests-true)
1859      (description "Check if tests are explicitly enabled")
1860      (check       check-tests-true))
1861    (lint-checker
1862      (name        'description)
1863      (description "Validate package descriptions")
1864      (check       check-description-style))
1865    (lint-checker
1866      (name        'inputs-should-be-native)
1867      (description "Identify inputs that should be native inputs")
1868      (check       check-inputs-should-be-native))
1869    (lint-checker
1870      (name        'inputs-should-not-be-input)
1871      (description "Identify inputs that shouldn't be inputs at all")
1872      (check       check-inputs-should-not-be-an-input-at-all))
1873    (lint-checker
1874      (name        'input-labels)
1875      (description "Identify input labels that do not match package names")
1876      (check       check-input-labels))
1877    (lint-checker
1878      (name        'wrapper-inputs)
1879      (description "Make sure 'wrap-program' can finds its interpreter.")
1880      (check       check-wrapper-inputs))
1881    (lint-checker
1882      (name        'license)
1883      ;; TRANSLATORS: <license> is the name of a data type and must not be
1884      ;; translated.
1885      (description "Make sure the 'license' field is a <license> \
1886 or a list thereof")
1887      (check       check-license))
1888    (lint-checker
1889      (name        'optional-tests)
1890      (description "Make sure tests are only run when requested")
1891      (check       check-optional-tests))
1892    (lint-checker
1893      (name        'mirror-url)
1894      (description "Suggest 'mirror://' URLs")
1895      (check       check-mirror-url))
1896    (lint-checker
1897      (name        'source-file-name)
1898      (description "Validate file names of sources")
1899      (check       check-source-file-name))
1900    (lint-checker
1901      (name        'source-unstable-tarball)
1902      (description "Check for autogenerated tarballs")
1903      (check       check-source-unstable-tarball))
1904    (lint-checker
1905      (name            'derivation)
1906      (description     "Report failure to compile a package to a derivation")
1907      (check           check-derivation)
1908      (requires-store? #t))
1909    (lint-checker
1910      (name            'profile-collisions)
1911      (description     "Report collisions that would occur due to propagated inputs")
1912      (check           check-profile-collisions)
1913      (requires-store? #t))
1914    (lint-checker
1915     (name        'patch-file-names)
1916     (description "Validate file names and availability of patches")
1917     (check       check-patch-file-names))
1918    (lint-checker
1919     (name        'patch-headers)
1920     (description "Validate patch headers")
1921     (check       check-patch-headers))
1922    (lint-checker
1923      (name        'formatting)
1924      (description "Look for formatting issues in the source")
1925      (check       check-formatting))))
1926
1927 (define %network-dependent-checkers
1928   (list
1929    (lint-checker
1930      (name        'synopsis)
1931      (description "Validate package synopses")
1932      (check       check-synopsis-style))
1933    (lint-checker
1934      (name        'gnu-description)
1935      (description "Validate synopsis & description of GNU packages")
1936      (check       check-gnu-synopsis+description))
1937    (lint-checker
1938      (name        'home-page)
1939      (description "Validate home-page URLs")
1940      (check       check-home-page))
1941    (lint-checker
1942      (name        'source)
1943      (description "Validate source URLs")
1944      (check       check-source))
1945    (lint-checker
1946      (name        'github-url)
1947      (description "Suggest GitHub URLs")
1948      (check       check-github-url))
1949    (lint-checker
1950      (name        'cve)
1951      (description "Check the Common Vulnerabilities and Exposures\
1952  (CVE) database")
1953      (check       check-vulnerabilities))
1954    (lint-checker
1955      (name        'refresh)
1956      (description "Check the package for new upstream releases")
1957      (check       check-for-updates))
1958    (lint-checker
1959      (name        'archival)
1960      (description "Ensure source code archival on Software Heritage")
1961      (check       check-archival))
1962    (lint-checker
1963      (name        'haskell-stackage)
1964      (description "Ensure Haskell packages use Stackage LTS versions")
1965      (check       check-haskell-stackage))))
1966
1967 (define %all-checkers
1968   (append %local-checkers
1969           %network-dependent-checkers))