guix/lint.scm

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