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