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