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