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