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