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