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