guix/lint.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
   3 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
   4 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   5 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
   6 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
   7 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
   8 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
   9 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
  10 ;;; Copyright © 2017, 2018 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)
  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                                     git-reference-url git-reference-commit)
  50   #:use-module (ice-9 match)
  51   #:use-module (ice-9 regex)
  52   #:use-module (ice-9 format)
  53   #:use-module (web client)
  54   #:use-module (web uri)
  55   #:use-module ((guix build download)
  56                 #:select (maybe-expand-mirrors
  57                           (open-connection-for-uri
  58                            . guix:open-connection-for-uri)))
  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             "autoconf"
 290             "automake"
 291             "bison"
 292             "cmake"
 293             "dejagnu"
 294             "desktop-file-utils"
 295             "doxygen"
 296             "extra-cmake-modules"
 297             "flex"
 298             "gettext"
 299             "glib:bin"
 300             "gobject-introspection"
 301             "googletest-source"
 302             "groff"
 303             "help2man"
 304             "intltool"
 305             "itstool"
 306             "libtool"
 307             "qttools"
 308             "yasm" "nasm" "fasm"
 309             "python-coverage" "python2-coverage"
 310             "python-cython" "python2-cython"
 311             "python-docutils" "python2-docutils"
 312             "python-mock" "python2-mock"
 313             "python-nose" "python2-nose"
 314             "python-pbr" "python2-pbr"
 315             "python-pytest" "python2-pytest"
 316             "python-pytest-cov" "python2-pytest-cov"
 317             "python-setuptools-scm" "python2-setuptools-scm"
 318             "python-sphinx" "python2-sphinx"
 319             "swig"
 320             "qmake"
 321             "qttools"
 322             "texinfo"
 323             "xorg-server-for-tests"
 324             "yelp-tools")))
 325     (map (lambda (input)
 326            (make-warning
 327             package
 328             (G_ "'~a' should probably be a native input")
 329             (list input)
 330             #:field 'inputs))
 331          (package-input-intersection inputs input-names))))
 332
 333 (define (check-inputs-should-not-be-an-input-at-all package)
 334   ;; Emit a warning if some inputs of PACKAGE are likely to should not be
 335   ;; an input at all.
 336   (let ((input-names '("python-setuptools"
 337                        "python2-setuptools"
 338                        "python-pip"
 339                        "python2-pip")))
 340     (map (lambda (input)
 341            (make-warning
 342             package
 343             (G_ "'~a' should probably not be an input at all")
 344             (list input)
 345             #:field 'inputs))
 346          (package-input-intersection (package-direct-inputs package)
 347                                      input-names))))
 348
 349 (define (package-name-regexp package)
 350   "Return a regexp that matches PACKAGE's name as a word at the beginning of a
 351 line."
 352   (make-regexp (string-append "^" (regexp-quote (package-name package))
 353                               "\\>")
 354                regexp/icase))
 355
 356 (define (check-synopsis-style package)
 357   ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
 358   (define (check-final-period synopsis)
 359     ;; Synopsis should not end with a period, except for some special cases.
 360     (if (and (string-suffix? "." synopsis)
 361              (not (string-suffix? "etc." synopsis)))
 362         (list
 363          (make-warning package
 364                        (G_ "no period allowed at the end of the synopsis")
 365                        #:field 'synopsis))
 366         '()))
 367
 368   (define check-start-article
 369     ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
 370     ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>.
 371     (if (false-if-exception (gnu-package? package))
 372         (const '())
 373         (lambda (synopsis)
 374           (if (or (string-prefix-ci? "A " synopsis)
 375                   (string-prefix-ci? "An " synopsis))
 376               (list
 377                (make-warning package
 378                              (G_ "no article allowed at the beginning of \
 379 the synopsis")
 380                              #:field 'synopsis))
 381               '()))))
 382
 383   (define (check-synopsis-length synopsis)
 384     (if (>= (string-length synopsis) 80)
 385         (list
 386          (make-warning package
 387                        (G_ "synopsis should be less than 80 characters long")
 388                        #:field 'synopsis))
 389         '()))
 390
 391   (define (check-proper-start synopsis)
 392     (if (properly-starts-sentence? synopsis)
 393         '()
 394         (list
 395          (make-warning package
 396                        (G_ "synopsis should start with an upper-case letter or digit")
 397                        #:field 'synopsis))))
 398
 399   (define (check-start-with-package-name synopsis)
 400     (if (and (regexp-exec (package-name-regexp package) synopsis)
 401                (not (starts-with-abbreviation? synopsis)))
 402         (list
 403          (make-warning package
 404                        (G_ "synopsis should not start with the package name")
 405                        #:field 'synopsis))
 406         '()))
 407
 408   (define (check-texinfo-markup synopsis)
 409     "Check that SYNOPSIS can be parsed as a Texinfo fragment.  If the
 410 markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
 411     (catch #t
 412       (lambda ()
 413         (texi->plain-text synopsis)
 414         '())
 415       (lambda (keys . args)
 416         (list
 417          (make-warning package
 418                        (G_ "Texinfo markup in synopsis is invalid")
 419                        #:field 'synopsis)))))
 420
 421   (define checks
 422     (list check-proper-start
 423           check-final-period
 424           check-start-article
 425           check-start-with-package-name
 426           check-synopsis-length
 427           check-texinfo-markup))
 428
 429   (match (package-synopsis package)
 430     (""
 431      (list
 432       (make-warning package
 433                     (G_ "synopsis should not be empty")
 434                     #:field 'synopsis)))
 435     ((? string? synopsis)
 436      (append-map
 437       (lambda (proc)
 438         (proc synopsis))
 439       checks))
 440     (invalid
 441      (list
 442       (make-warning package
 443                     (G_ "invalid synopsis: ~s")
 444                     (list invalid)
 445                     #:field 'synopsis)))))
 446
 447 (define* (probe-uri uri #:key timeout)
 448   "Probe URI, a URI object, and return two values: a symbol denoting the
 449 probing status, such as 'http-response' when we managed to get an HTTP
 450 response from URI, and additional details, such as the actual HTTP response.
 451
 452 TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
 453 for connections to complete; when TIMEOUT is #f, wait as long as needed."
 454   (define headers
 455     '((User-Agent . "GNU Guile")
 456       (Accept . "*/*")))
 457
 458   (let loop ((uri     uri)
 459              (visited '()))
 460     (match (uri-scheme uri)
 461       ((or 'http 'https)
 462        (catch #t
 463          (lambda ()
 464            (let ((port    (guix:open-connection-for-uri
 465                            uri #:timeout timeout))
 466                  (request (build-request uri #:headers headers)))
 467              (define response
 468                (dynamic-wind
 469                  (const #f)
 470                  (lambda ()
 471                    (write-request request port)
 472                    (force-output port)
 473                    (read-response port))
 474                  (lambda ()
 475                    (close-port port))))
 476
 477              (case (response-code response)
 478                ((302                    ; found (redirection)
 479                  303                    ; see other
 480                  307                    ; temporary redirection
 481                  308)                   ; permanent redirection
 482                 (let ((location (response-location response)))
 483                   (if (or (not location) (member location visited))
 484                       (values 'http-response response)
 485                       (loop location (cons location visited))))) ;follow the redirect
 486                ((301)                   ; moved permanently
 487                 (let ((location (response-location response)))
 488                   ;; Return RESPONSE, unless the final response as we follow
 489                   ;; redirects is not 200.
 490                   (if location
 491                       (let-values (((status response2)
 492                                     (loop location (cons location visited))))
 493                         (case status
 494                           ((http-response)
 495                            (values 'http-response
 496                                    (if (= 200 (response-code response2))
 497                                        response
 498                                        response2)))
 499                           (else
 500                            (values status response2))))
 501                       (values 'http-response response)))) ;invalid redirect
 502                (else
 503                 (values 'http-response response)))))
 504          (lambda (key . args)
 505            (case key
 506              ((bad-header bad-header-component)
 507               ;; This can happen if the server returns an invalid HTTP header,
 508               ;; as is the case with the 'Date' header at sqlite.org.
 509               (values 'invalid-http-response #f))
 510              ((getaddrinfo-error system-error
 511                gnutls-error tls-certificate-error)
 512               (values key args))
 513              (else
 514               (apply throw key args))))))
 515       ('ftp
 516        (catch #t
 517          (lambda ()
 518            (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
 519              (define response
 520                (dynamic-wind
 521                  (const #f)
 522                  (lambda ()
 523                    (ftp-chdir conn (dirname (uri-path uri)))
 524                    (ftp-size conn (basename (uri-path uri))))
 525                  (lambda ()
 526                    (ftp-close conn))))
 527              (values 'ftp-response '(ok))))
 528          (lambda (key . args)
 529            (case key
 530              ((ftp-error)
 531               (values 'ftp-response `(error ,@args)))
 532              ((getaddrinfo-error system-error gnutls-error)
 533               (values key args))
 534              (else
 535               (apply throw key args))))))
 536       (_
 537        (values 'unknown-protocol #f)))))
 538
 539 (define (tls-certificate-error-string args)
 540   "Return a string explaining the 'tls-certificate-error' arguments ARGS."
 541   (call-with-output-string
 542     (lambda (port)
 543       (print-exception port #f
 544                        'tls-certificate-error args))))
 545
 546 (define (validate-uri uri package field)
 547   "Return #t if the given URI can be reached, otherwise return a warning for
 548 PACKAGE mentioning the FIELD."
 549   (let-values (((status argument)
 550                 (probe-uri uri #:timeout 3)))     ;wait at most 3 seconds
 551     (case status
 552       ((http-response)
 553        (cond ((= 200 (response-code argument))
 554               (match (response-content-length argument)
 555                 ((? number? length)
 556                  ;; As of July 2016, SourceForge returns 200 (instead of 404)
 557                  ;; with a small HTML page upon failure.  Attempt to detect
 558                  ;; such malicious behavior.
 559                  (or (> length 1000)
 560                      (make-warning package
 561                                    (G_ "URI ~a returned \
 562 suspiciously small file (~a bytes)")
 563                                    (list (uri->string uri)
 564                                          length)
 565                                    #:field field)))
 566                 (_ #t)))
 567              ((= 301 (response-code argument))
 568               (if (response-location argument)
 569                   (make-warning package
 570                                 (G_ "permanent redirect from ~a to ~a")
 571                                 (list (uri->string uri)
 572                                       (uri->string
 573                                        (response-location argument)))
 574                                 #:field field)
 575                   (make-warning package
 576                                 (G_ "invalid permanent redirect \
 577 from ~a")
 578                                 (list (uri->string uri))
 579                                 #:field field)))
 580              (else
 581               (make-warning package
 582                             (G_ "URI ~a not reachable: ~a (~s)")
 583                             (list (uri->string uri)
 584                                   (response-code argument)
 585                                   (response-reason-phrase argument))
 586                             #:field field))))
 587       ((ftp-response)
 588        (match argument
 589          (('ok) #t)
 590          (('error port command code message)
 591           (make-warning package
 592                         (G_ "URI ~a not reachable: ~a (~s)")
 593                         (list (uri->string uri)
 594                               code (string-trim-both message))
 595                         #:field field))))
 596       ((getaddrinfo-error)
 597        (make-warning package
 598                      (G_ "URI ~a domain not found: ~a")
 599                      (list (uri->string uri)
 600                            (gai-strerror (car argument)))
 601                      #:field field))
 602       ((system-error)
 603        (make-warning package
 604                      (G_ "URI ~a unreachable: ~a")
 605                      (list (uri->string uri)
 606                            (strerror
 607                             (system-error-errno
 608                              (cons status argument))))
 609                      #:field field))
 610       ((tls-certificate-error)
 611        (make-warning package
 612                      (G_ "TLS certificate error: ~a")
 613                      (list (tls-certificate-error-string argument))
 614                      #:field field))
 615       ((invalid-http-response gnutls-error)
 616        ;; Probably a misbehaving server; ignore.
 617        #f)
 618       ((unknown-protocol)                         ;nothing we can do
 619        #f)
 620       (else
 621        (error "internal linter error" status)))))
 622
 623 (define (check-home-page package)
 624   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 625 'home-page' is not reachable."
 626   (let ((uri (and=> (package-home-page package) string->uri)))
 627     (cond
 628      ((uri? uri)
 629       (match (validate-uri uri package 'home-page)
 630         ((and (? lint-warning? warning) warning)
 631          (list warning))
 632         (_ '())))
 633      ((not (package-home-page package))
 634       (if (or (string-contains (package-name package) "bootstrap")
 635               (string=? (package-name package) "ld-wrapper"))
 636           '()
 637           (list
 638            (make-warning package
 639                          (G_ "invalid value for home page")
 640                          #:field 'home-page))))
 641      (else
 642       (list
 643        (make-warning package
 644                      (G_ "invalid home page URL: ~s")
 645                      (list (package-home-page package))
 646                      #:field 'home-page))))))
 647
 648 (define %distro-directory
 649   (mlambda ()
 650     (dirname (search-path %load-path "gnu.scm"))))
 651
 652 (define (check-patch-file-names package)
 653   "Emit a warning if the patches requires by PACKAGE are badly named or if the
 654 patch could not be found."
 655   (guard (c ((message-condition? c)     ;raised by 'search-patch'
 656              (list
 657               ;; Use %make-warning, as condition-mesasge is already
 658               ;; translated.
 659               (%make-warning package (condition-message c)
 660                              #:field 'patch-file-names))))
 661     (define patches
 662       (or (and=> (package-source package) origin-patches)
 663           '()))
 664
 665     (append
 666      (if (every (match-lambda        ;patch starts with package name?
 667                   ((? string? patch)
 668                    (and=> (string-contains (basename patch)
 669                                            (package-name package))
 670                           zero?))
 671                   (_  #f))     ;must be an <origin> or something like that.
 672                 patches)
 673          '()
 674          (list
 675           (make-warning
 676            package
 677            (G_ "file names of patches should start with the package name")
 678            #:field 'patch-file-names)))
 679
 680      ;; Check whether we're reaching tar's maximum file name length.
 681      (let ((prefix (string-length (%distro-directory)))
 682            (margin (string-length "guix-0.13.0-10-123456789/"))
 683            (max    99))
 684        (filter-map (match-lambda
 685                      ((? string? patch)
 686                       (if (> (+ margin (if (string-prefix? (%distro-directory)
 687                                                            patch)
 688                                            (- (string-length patch) prefix)
 689                                            (string-length patch)))
 690                              max)
 691                           (make-warning
 692                            package
 693                            (G_ "~a: file name is too long")
 694                            (list (basename patch))
 695                            #:field 'patch-file-names)
 696                           #f))
 697                      (_ #f))
 698                    patches)))))
 699
 700 (define (escape-quotes str)
 701   "Replace any quote character in STR by an escaped quote character."
 702   (list->string
 703    (string-fold-right (lambda (chr result)
 704                         (match chr
 705                           (#\" (cons* #\\ #\"result))
 706                           (_   (cons chr result))))
 707                       '()
 708                       str)))
 709
 710 (define official-gnu-packages*
 711   (mlambda ()
 712     "A memoizing version of 'official-gnu-packages' that returns the empty
 713 list when something goes wrong, such as a networking issue."
 714     (let ((gnus (false-if-exception (official-gnu-packages))))
 715       (or gnus '()))))
 716
 717 (define (check-gnu-synopsis+description package)
 718   "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
 719 descriptions maintained upstream."
 720   (match (find (lambda (descriptor)
 721                  (string=? (gnu-package-name descriptor)
 722                            (package-name package)))
 723                (official-gnu-packages*))
 724     (#f                                   ;not a GNU package, so nothing to do
 725      '())
 726     (descriptor                                   ;a genuine GNU package
 727      (append
 728       (let ((upstream   (gnu-package-doc-summary descriptor))
 729             (downstream (package-synopsis package)))
 730         (if (and upstream
 731                  (or (not (string? downstream))
 732                      (not (string=? upstream downstream))))
 733             (list
 734              (make-warning package
 735                            (G_ "proposed synopsis: ~s~%")
 736                            (list upstream)
 737                            #:field 'synopsis))
 738             '()))
 739
 740       (let ((upstream   (gnu-package-doc-description descriptor))
 741             (downstream (package-description package)))
 742         (if (and upstream
 743                  (or (not (string? downstream))
 744                      (not (string=? (fill-paragraph upstream 100)
 745                                     (fill-paragraph downstream 100)))))
 746             (list
 747              (make-warning
 748               package
 749               (G_ "proposed description:~%     \"~a\"~%")
 750               (list (fill-paragraph (escape-quotes upstream) 77 7))
 751               #:field 'description))
 752             '()))))))
 753
 754 (define (origin-uris origin)
 755   "Return the list of URIs (strings) for ORIGIN."
 756   (match (origin-uri origin)
 757     ((? string? uri)
 758      (list uri))
 759     ((uris ...)
 760      uris)))
 761
 762 (define (check-source package)
 763   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 764 'source' is not reachable."
 765   (define (warnings-for-uris uris)
 766     (let loop ((uris uris)
 767                (warnings '()))
 768       (match uris
 769         (()
 770          (reverse warnings))
 771         ((uri rest ...)
 772          (match (validate-uri uri package 'source)
 773            (#t
 774             ;; We found a working URL, so stop right away.
 775             '())
 776            ((? lint-warning? warning)
 777             (loop rest (cons warning warnings))))))))
 778
 779   (let ((origin (package-source package)))
 780     (if (and origin
 781              (eqv? (origin-method origin) url-fetch))
 782         (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
 783                                      (map string->uri (origin-uris origin))))
 784                (warnings (warnings-for-uris uris)))
 785
 786           ;; Just make sure that at least one of the URIs is valid.
 787           (if (= (length uris) (length warnings))
 788               ;; When everything fails, report all of WARNINGS, otherwise don't
 789               ;; report anything.
 790               ;;
 791               ;; XXX: Ideally we'd still allow warnings to be raised if *some*
 792               ;; URIs are unreachable, but distinguish that from the error case
 793               ;; where *all* the URIs are unreachable.
 794               (cons*
 795                (make-warning package
 796                              (G_ "all the source URIs are unreachable:")
 797                              #:field 'source)
 798                warnings)
 799               '()))
 800         '())))
 801
 802 (define (check-source-file-name package)
 803   "Emit a warning if PACKAGE's origin has no meaningful file name."
 804   (define (origin-file-name-valid? origin)
 805     ;; Return #f if the source file name contains only a version or is #f;
 806     ;; indicates that the origin needs a 'file-name' field.
 807     (let ((file-name (origin-actual-file-name origin))
 808           (version (package-version package)))
 809       (and file-name
 810            ;; Common in many projects is for the filename to start
 811            ;; with a "v" followed by the version,
 812            ;; e.g. "v3.2.0.tar.gz".
 813            (not (string-match (string-append "^v?" version) file-name)))))
 814
 815   (let ((origin (package-source package)))
 816     (if (or (not origin) (origin-file-name-valid? origin))
 817         '()
 818         (list
 819          (make-warning package
 820                        (G_ "the source file name should contain the package name")
 821                        #:field 'source)))))
 822
 823 (define (check-source-unstable-tarball package)
 824   "Emit a warning if PACKAGE's source is an autogenerated tarball."
 825   (define (check-source-uri uri)
 826     (if (and (string=? (uri-host (string->uri uri)) "github.com")
 827              (match (split-and-decode-uri-path
 828                      (uri-path (string->uri uri)))
 829                ((_ _ "archive" _ ...) #t)
 830                (_ #f)))
 831         (make-warning package
 832                       (G_ "the source URI should not be an autogenerated tarball")
 833                       #:field 'source)
 834         #f))
 835
 836   (let ((origin (package-source package)))
 837     (if (and (origin? origin)
 838              (eqv? (origin-method origin) url-fetch))
 839         (filter-map check-source-uri
 840                     (origin-uris origin))
 841         '())))
 842
 843 (define (check-mirror-url package)
 844   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
 845   (define (check-mirror-uri uri)                  ;XXX: could be optimized
 846     (let loop ((mirrors %mirrors))
 847       (match mirrors
 848         (()
 849          #f)
 850         (((mirror-id mirror-urls ...) rest ...)
 851          (match (find (cut string-prefix? <> uri) mirror-urls)
 852            (#f
 853             (loop rest))
 854            (prefix
 855             (make-warning package
 856                           (G_ "URL should be \
 857 'mirror://~a/~a'")
 858                           (list mirror-id
 859                                 (string-drop uri (string-length prefix)))
 860                           #:field 'source)))))))
 861
 862   (let ((origin (package-source package)))
 863     (if (and (origin? origin)
 864              (eqv? (origin-method origin) url-fetch))
 865         (let ((uris (origin-uris origin)))
 866           (filter-map check-mirror-uri uris))
 867         '())))
 868
 869 (define* (check-github-url package #:key (timeout 3))
 870   "Check whether PACKAGE uses source URLs that redirect to GitHub."
 871   (define (follow-redirect url)
 872     (let* ((uri      (string->uri url))
 873            (port     (guix:open-connection-for-uri uri #:timeout timeout))
 874            (response (http-head uri #:port port)))
 875       (close-port port)
 876       (case (response-code response)
 877         ((301 302)
 878          (uri->string (assoc-ref (response-headers response) 'location)))
 879         (else #f))))
 880
 881   (define (follow-redirects-to-github uri)
 882     (cond
 883      ((string-prefix? "https://github.com/" uri) uri)
 884      ((string-prefix? "http" uri)
 885       (and=> (follow-redirect uri) follow-redirects-to-github))
 886      ;; Do not attempt to follow redirects on URIs other than http and https
 887      ;; (such as mirror, file)
 888      (else #f)))
 889
 890   (let ((origin (package-source package)))
 891     (if (and (origin? origin)
 892              (eqv? (origin-method origin) url-fetch))
 893         (filter-map
 894          (lambda (uri)
 895            (and=> (follow-redirects-to-github uri)
 896                   (lambda (github-uri)
 897                     (if (string=? github-uri uri)
 898                         #f
 899                         (make-warning
 900                          package
 901                          (G_ "URL should be '~a'")
 902                          (list github-uri)
 903                          #:field 'source)))))
 904          (origin-uris origin))
 905         '())))
 906
 907 (define (check-derivation package)
 908   "Emit a warning if we fail to compile PACKAGE to a derivation."
 909   (define (try system)
 910     (catch #t
 911       (lambda ()
 912         (guard (c ((store-protocol-error? c)
 913                    (make-warning package
 914                                  (G_ "failed to create ~a derivation: ~a")
 915                                  (list system
 916                                        (store-protocol-error-message c))))
 917                   ((message-condition? c)
 918                    (make-warning package
 919                                  (G_ "failed to create ~a derivation: ~a")
 920                                  (list system
 921                                        (condition-message c)))))
 922           (with-store store
 923             ;; Disable grafts since it can entail rebuilds.
 924             (parameterize ((%graft? #f))
 925               (package-derivation store package system #:graft? #f)
 926
 927               ;; If there's a replacement, make sure we can compute its
 928               ;; derivation.
 929               (match (package-replacement package)
 930                 (#f #t)
 931                 (replacement
 932                  (package-derivation store replacement system
 933                                      #:graft? #f)))))))
 934       (lambda args
 935         (make-warning package
 936                       (G_ "failed to create ~a derivation: ~s")
 937                       (list system args)))))
 938
 939   (filter lint-warning?
 940           (map try (package-supported-systems package))))
 941
 942 (define (check-license package)
 943   "Warn about type errors of the 'license' field of PACKAGE."
 944   (match (package-license package)
 945     ((or (? license?)
 946          ((? license?) ...))
 947      '())
 948     (x
 949      (list
 950       (make-warning package (G_ "invalid license field")
 951                     #:field 'license)))))
 952
 953 (define (call-with-networking-fail-safe message error-value proc)
 954   "Call PROC catching any network-related errors.  Upon a networking error,
 955 display a message including MESSAGE and return ERROR-VALUE."
 956   (guard (c ((http-get-error? c)
 957              (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
 958                       message
 959                       (uri->string (http-get-error-uri c))
 960                       (http-get-error-code c)
 961                       (http-get-error-reason c))
 962              error-value))
 963     (catch #t
 964       proc
 965       (match-lambda*
 966         (('getaddrinfo-error errcode)
 967          (warning (G_ "~a: host lookup failure: ~a~%")
 968                   message
 969                   (gai-strerror errcode))
 970          error-value)
 971         (('tls-certificate-error args ...)
 972          (warning (G_ "~a: TLS certificate error: ~a")
 973                   message
 974                   (tls-certificate-error-string args))
 975          error-value)
 976         ((and ('system-error _ ...) args)
 977          (let ((errno (system-error-errno args)))
 978            (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
 979                (let ((details (call-with-output-string
 980                                 (lambda (port)
 981                                   (print-exception port #f (car args)
 982                                                    (cdr args))))))
 983                  (warning (G_ "~a: ~a~%") message details)
 984                  error-value)
 985                (apply throw args))))
 986         (args
 987          (apply throw args))))))
 988
 989 (define-syntax-rule (with-networking-fail-safe message error-value exp ...)
 990   (call-with-networking-fail-safe message error-value
 991                                   (lambda () exp ...)))
 992
 993 (define (current-vulnerabilities*)
 994   "Like 'current-vulnerabilities', but return the empty list upon networking
 995 or HTTP errors.  This allows network-less operation and makes problems with
 996 the NIST server non-fatal."
 997   (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
 998                              '()
 999                              (current-vulnerabilities)))
1000
1001 (define package-vulnerabilities
1002   (let ((lookup (delay (vulnerabilities->lookup-proc
1003                         (current-vulnerabilities*)))))
1004     (lambda (package)
1005       "Return a list of vulnerabilities affecting PACKAGE."
1006       ;; First we retrieve the Common Platform Enumeration (CPE) name and
1007       ;; version for PACKAGE, then we can pass them to LOOKUP.
1008       (let ((name    (or (assoc-ref (package-properties package)
1009                                     'cpe-name)
1010                          (package-name package)))
1011             (version (or (assoc-ref (package-properties package)
1012                                     'cpe-version)
1013                          (package-version package))))
1014         ((force lookup) name version)))))
1015
1016 (define (check-vulnerabilities package)
1017   "Check for known vulnerabilities for PACKAGE."
1018   (let ((package (or (package-replacement package) package)))
1019     (match (package-vulnerabilities package)
1020       (()
1021        '())
1022       ((vulnerabilities ...)
1023        (let* ((patched    (package-patched-vulnerabilities package))
1024               (known-safe (or (assq-ref (package-properties package)
1025                                         'lint-hidden-cve)
1026                               '()))
1027               (unpatched (remove (lambda (vuln)
1028                                    (let ((id (vulnerability-id vuln)))
1029                                      (or (member id patched)
1030                                          (member id known-safe))))
1031                                  vulnerabilities)))
1032          (if (null? unpatched)
1033              '()
1034              (list
1035               (make-warning
1036                package
1037                (G_ "probably vulnerable to ~a")
1038                (list (string-join (map vulnerability-id unpatched)
1039                                   ", "))))))))))
1040
1041 (define (check-for-updates package)
1042   "Check if there is an update available for PACKAGE."
1043   (match (with-networking-fail-safe
1044           (format #f (G_ "while retrieving upstream info for '~a'")
1045                   (package-name package))
1046           #f
1047           (package-latest-release* package (force %updaters)))
1048     ((? upstream-source? source)
1049      (if (version>? (upstream-source-version source)
1050                     (package-version package))
1051          (list
1052           (make-warning package
1053                         (G_ "can be upgraded to ~a")
1054                         (list (upstream-source-version source))
1055                         #:field 'version))
1056          '()))
1057     (#f '()))) ; cannot find newer upstream release
1058
1059
1060 (define (check-archival package)
1061   "Check whether PACKAGE's source code is archived on Software Heritage.  If
1062 it's not, and if its source code is a VCS snapshot, then send a \"save\"
1063 request to Software Heritage.
1064
1065 Software Heritage imposes limits on the request rate per client IP address.
1066 This checker prints a notice and stops doing anything once that limit has been
1067 reached."
1068   (define (response->warning url method response)
1069     (if (request-rate-limit-reached? url method)
1070         (list (make-warning package
1071                             (G_ "Software Heritage rate limit reached; \
1072 try again later")
1073                             #:field 'source))
1074         (list (make-warning package
1075                             (G_ "'~a' returned ~a")
1076                             (list url (response-code response))
1077                             #:field 'source))))
1078
1079   (define skip-key (gensym "skip-archival-check"))
1080
1081   (define (skip-when-limit-reached url method)
1082     (or (not (request-rate-limit-reached? url method))
1083         (throw skip-key #t)))
1084
1085   (parameterize ((%allow-request? skip-when-limit-reached))
1086     (catch #t
1087       (lambda ()
1088         (match (and (origin? (package-source package))
1089                     (package-source package))
1090           (#f                                     ;no source
1091            '())
1092           ((= origin-uri (? git-reference? reference))
1093            (define url
1094              (git-reference-url reference))
1095            (define commit
1096              (git-reference-commit reference))
1097
1098            (match (if (commit-id? commit)
1099                       (or (lookup-revision commit)
1100                           (lookup-origin-revision url commit))
1101                       (lookup-origin-revision url commit))
1102              ((? revision? revision)
1103               '())
1104              (#f
1105               ;; Revision is missing from the archive, attempt to save it.
1106               (catch 'swh-error
1107                 (lambda ()
1108                   (save-origin (git-reference-url reference) "git")
1109                   (list (make-warning
1110                          package
1111                          ;; TRANSLATORS: "Software Heritage" is a proper noun
1112                          ;; that must remain untranslated.  See
1113                          ;; <https://www.softwareheritage.org>.
1114                          (G_ "scheduled Software Heritage archival")
1115                          #:field 'source)))
1116                 (lambda (key url method response . _)
1117                   (cond ((= 429 (response-code response))
1118                          (list (make-warning
1119                                 package
1120                                 (G_ "archival rate limit exceeded; \
1121 try again later")
1122                                 #:field 'source)))
1123                         (else
1124                          (response->warning url method response))))))))
1125           ((? origin? origin)
1126            ;; Since "save" origins are not supported for non-VCS source, all
1127            ;; we can do is tell whether a given tarball is available or not.
1128            (if (origin-sha256 origin)             ;XXX: for ungoogled-chromium
1129                (match (lookup-content (origin-sha256 origin) "sha256")
1130                  (#f
1131                   (list (make-warning package
1132                                       (G_ "source not archived on Software \
1133 Heritage")
1134                                       #:field 'source)))
1135                  ((? content?)
1136                   '()))
1137                '()))))
1138       (match-lambda*
1139         ((key url method response)
1140          (response->warning url method response))
1141         ((key . args)
1142          (if (eq? key skip-key)
1143              '()
1144              (with-networking-fail-safe
1145               (G_ "while connecting to Software Heritage")
1146               '()
1147               (apply throw key args))))))))
1148
1149 \f
1150 ;;;
1151 ;;; Source code formatting.
1152 ;;;
1153
1154 (define (report-tabulations package line line-number)
1155   "Warn about tabulations found in LINE."
1156   (match (string-index line #\tab)
1157     (#f #f)
1158     (index
1159      (make-warning package
1160                    (G_ "tabulation on line ~a, column ~a")
1161                    (list line-number index)
1162                    #:location
1163                    (location (package-file package)
1164                              line-number
1165                              index)))))
1166
1167 (define (report-trailing-white-space package line line-number)
1168   "Warn about trailing white space in LINE."
1169   (and (not (or (string=? line (string-trim-right line))
1170                 (string=? line (string #\page))))
1171        (make-warning package
1172                      (G_ "trailing white space on line ~a")
1173                      (list line-number)
1174                      #:location
1175                      (location (package-file package)
1176                                line-number
1177                                0))))
1178
1179 (define (report-long-line package line line-number)
1180   "Emit a warning if LINE is too long."
1181   ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
1182   ;; make it hard to fit within that limit and we want to avoid making too
1183   ;; much noise.
1184   (and (> (string-length line) 90)
1185        (make-warning package
1186                      (G_ "line ~a is way too long (~a characters)")
1187                      (list line-number (string-length line))
1188                      #:location
1189                      (location (package-file package)
1190                                line-number
1191                                0))))
1192
1193 (define %hanging-paren-rx
1194   (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
1195
1196 (define (report-lone-parentheses package line line-number)
1197   "Emit a warning if LINE contains hanging parentheses."
1198   (and (regexp-exec %hanging-paren-rx line)
1199        (make-warning package
1200                      (G_ "parentheses feel lonely, \
1201 move to the previous or next line")
1202                      (list line-number)
1203                      #:location
1204                      (location (package-file package)
1205                                line-number
1206                                0))))
1207
1208 (define %formatting-reporters
1209   ;; List of procedures that report formatting issues.  These are not separate
1210   ;; checkers because they would need to re-read the file.
1211   (list report-tabulations
1212         report-trailing-white-space
1213         report-long-line
1214         report-lone-parentheses))
1215
1216 (define* (report-formatting-issues package file starting-line
1217                                    #:key (reporters %formatting-reporters))
1218   "Report white-space issues in FILE starting from STARTING-LINE, and report
1219 them for PACKAGE."
1220   (define (sexp-last-line port)
1221     ;; Return the last line of the sexp read from PORT or an estimate thereof.
1222     (define &failure (list 'failure))
1223
1224     (let ((start      (ftell port))
1225           (start-line (port-line port))
1226           (sexp       (catch 'read-error
1227                         (lambda () (read port))
1228                         (const &failure))))
1229       (let ((line (port-line port)))
1230         (seek port start SEEK_SET)
1231         (set-port-line! port start-line)
1232         (if (eq? sexp &failure)
1233             (+ start-line 60)                     ;conservative estimate
1234             line))))
1235
1236   (call-with-input-file file
1237     (lambda (port)
1238       (let loop ((line-number 1)
1239                  (last-line #f)
1240                  (warnings '()))
1241         (let ((line (read-line port)))
1242           (if (or (eof-object? line)
1243                   (and last-line (> line-number last-line)))
1244               warnings
1245               (if (and (= line-number starting-line)
1246                        (not last-line))
1247                   (loop (+ 1 line-number)
1248                         (+ 1 (sexp-last-line port))
1249                         warnings)
1250                   (loop (+ 1 line-number)
1251                         last-line
1252                         (append
1253                          warnings
1254                          (if (< line-number starting-line)
1255                              '()
1256                              (filter-map (lambda (report)
1257                                            (report package line line-number))
1258                                          reporters)))))))))))
1259
1260 (define (check-formatting package)
1261   "Check the formatting of the source code of PACKAGE."
1262   (let ((location (package-location package)))
1263     (if location
1264         (and=> (search-path %load-path (location-file location))
1265                (lambda (file)
1266                  ;; Report issues starting from the line before the 'package'
1267                  ;; form, which usually contains the 'define' form.
1268                  (report-formatting-issues package file
1269                                            (- (location-line location) 1))))
1270         '())))
1271
1272 \f
1273 ;;;
1274 ;;; List of checkers.
1275 ;;;
1276
1277 (define %local-checkers
1278   (list
1279    (lint-checker
1280      (name        'description)
1281      (description "Validate package descriptions")
1282      (check       check-description-style))
1283    (lint-checker
1284      (name        'inputs-should-be-native)
1285      (description "Identify inputs that should be native inputs")
1286      (check       check-inputs-should-be-native))
1287    (lint-checker
1288      (name        'inputs-should-not-be-input)
1289      (description "Identify inputs that shouldn't be inputs at all")
1290      (check       check-inputs-should-not-be-an-input-at-all))
1291    (lint-checker
1292      (name        'license)
1293      ;; TRANSLATORS: <license> is the name of a data type and must not be
1294      ;; translated.
1295      (description "Make sure the 'license' field is a <license> \
1296 or a list thereof")
1297      (check       check-license))
1298    (lint-checker
1299      (name        'mirror-url)
1300      (description "Suggest 'mirror://' URLs")
1301      (check       check-mirror-url))
1302    (lint-checker
1303      (name        'source-file-name)
1304      (description "Validate file names of sources")
1305      (check       check-source-file-name))
1306    (lint-checker
1307      (name        'source-unstable-tarball)
1308      (description "Check for autogenerated tarballs")
1309      (check       check-source-unstable-tarball))
1310    (lint-checker
1311      (name        'derivation)
1312      (description "Report failure to compile a package to a derivation")
1313      (check       check-derivation))
1314    (lint-checker
1315     (name        'patch-file-names)
1316     (description "Validate file names and availability of patches")
1317     (check       check-patch-file-names))
1318    (lint-checker
1319      (name        'formatting)
1320      (description "Look for formatting issues in the source")
1321      (check       check-formatting))))
1322
1323 (define %network-dependent-checkers
1324   (list
1325    (lint-checker
1326      (name        'synopsis)
1327      (description "Validate package synopses")
1328      (check       check-synopsis-style))
1329    (lint-checker
1330      (name        'gnu-description)
1331      (description "Validate synopsis & description of GNU packages")
1332      (check       check-gnu-synopsis+description))
1333    (lint-checker
1334      (name        'home-page)
1335      (description "Validate home-page URLs")
1336      (check       check-home-page))
1337    (lint-checker
1338      (name        'source)
1339      (description "Validate source URLs")
1340      (check       check-source))
1341    (lint-checker
1342      (name        'github-url)
1343      (description "Suggest GitHub URLs")
1344      (check       check-github-url))
1345    (lint-checker
1346      (name        'cve)
1347      (description "Check the Common Vulnerabilities and Exposures\
1348  (CVE) database")
1349      (check       check-vulnerabilities))
1350    (lint-checker
1351      (name        'refresh)
1352      (description "Check the package for new upstream releases")
1353      (check       check-for-updates))
1354    (lint-checker
1355      (name        'archival)
1356      (description "Ensure source code archival on Software Heritage")
1357      (check       check-archival))))
1358
1359 (define %all-checkers
1360   (append %local-checkers
1361           %network-dependent-checkers))