guix/scripts/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 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 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (guix scripts lint)
  25   #:use-module ((guix store) #:hide (close-connection))
  26   #:use-module (guix base32)
  27   #:use-module (guix download)
  28   #:use-module (guix ftp-client)
  29   #:use-module (guix http-client)
  30   #:use-module (guix packages)
  31   #:use-module (guix licenses)
  32   #:use-module (guix records)
  33   #:use-module (guix ui)
  34   #:use-module (guix utils)
  35   #:use-module (guix memoization)
  36   #:use-module (guix scripts)
  37   #:use-module (guix gnu-maintenance)
  38   #:use-module (guix monads)
  39   #:use-module (guix cve)
  40   #:use-module (gnu packages)
  41   #:use-module (ice-9 match)
  42   #:use-module (ice-9 regex)
  43   #:use-module (ice-9 format)
  44   #:use-module (web uri)
  45   #:use-module ((guix build download)
  46                 #:select (maybe-expand-mirrors
  47                           open-connection-for-uri
  48                           close-connection))
  49   #:use-module (web request)
  50   #:use-module (web response)
  51   #:use-module (srfi srfi-1)
  52   #:use-module (srfi srfi-6)                      ;Unicode string ports
  53   #:use-module (srfi srfi-9)
  54   #:use-module (srfi srfi-11)
  55   #:use-module (srfi srfi-26)
  56   #:use-module (srfi srfi-34)
  57   #:use-module (srfi srfi-35)
  58   #:use-module (srfi srfi-37)
  59   #:use-module (ice-9 rdelim)
  60   #:export (guix-lint
  61             check-description-style
  62             check-inputs-should-be-native
  63             check-inputs-should-not-be-an-input-at-all
  64             check-patch-file-names
  65             check-synopsis-style
  66             check-derivation
  67             check-home-page
  68             check-source
  69             check-source-file-name
  70             check-mirror-url
  71             check-license
  72             check-vulnerabilities
  73             check-formatting
  74             run-checkers
  75
  76             %checkers
  77             lint-checker
  78             lint-checker?
  79             lint-checker-name
  80             lint-checker-description
  81             lint-checker-check))
  82
  83 \f
  84 ;;;
  85 ;;; Helpers
  86 ;;;
  87 (define* (emit-warning package message #:optional field)
  88   ;; Emit a warning about PACKAGE, printing the location of FIELD if it is
  89   ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
  90   ;; provided MESSAGE.
  91   (let ((loc (or (package-field-location package field)
  92                  (package-location package))))
  93     (format (guix-warning-port) "~a: ~a: ~a~%"
  94             (location->string loc)
  95             (package-full-name package)
  96             message)))
  97
  98 (define (call-with-accumulated-warnings thunk)
  99   "Call THUNK, accumulating any warnings in the current state, using the state
 100 monad."
 101   (let ((port (open-output-string)))
 102     (mlet %state-monad ((state      (current-state))
 103                         (result ->  (parameterize ((guix-warning-port port))
 104                                       (thunk)))
 105                         (warning -> (get-output-string port)))
 106       (mbegin %state-monad
 107         (munless (string=? "" warning)
 108           (set-current-state (cons warning state)))
 109         (return result)))))
 110
 111 (define-syntax-rule (with-accumulated-warnings exp ...)
 112   "Evaluate EXP and accumulate warnings in the state monad."
 113   (call-with-accumulated-warnings
 114    (lambda ()
 115      exp ...)))
 116
 117 \f
 118 ;;;
 119 ;;; Checkers
 120 ;;;
 121 (define-record-type* <lint-checker>
 122   lint-checker make-lint-checker
 123   lint-checker?
 124   ;; TODO: add a 'certainty' field that shows how confident we are in the
 125   ;; checker. Then allow users to only run checkers that have a certain
 126   ;; 'certainty' level.
 127   (name        lint-checker-name)
 128   (description lint-checker-description)
 129   (check       lint-checker-check))
 130
 131 (define (list-checkers-and-exit)
 132   ;; Print information about all available checkers and exit.
 133   (format #t (_ "Available checkers:~%"))
 134   (for-each (lambda (checker)
 135               (format #t "- ~a: ~a~%"
 136                       (lint-checker-name checker)
 137                       (_ (lint-checker-description checker))))
 138             %checkers)
 139   (exit 0))
 140
 141 (define (properly-starts-sentence? s)
 142   (string-match "^[(\"'`[:upper:][:digit:]]" s))
 143
 144 (define (starts-with-abbreviation? s)
 145   "Return #t if S starts with what looks like an abbreviation or acronym."
 146   (string-match "^[A-Z][A-Z0-9]+\\>" s))
 147
 148 (define %quoted-identifier-rx
 149   ;; A quoted identifier, like 'this'.
 150   (make-regexp "['`][[:graph:]]+'"))
 151
 152 (define (check-description-style package)
 153   ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
 154   (define (check-not-empty description)
 155     (when (string-null? description)
 156       (emit-warning package
 157                     (_ "description should not be empty")
 158                     'description)))
 159
 160   (define (check-texinfo-markup description)
 161     "Check that DESCRIPTION can be parsed as a Texinfo fragment.  If the
 162 markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
 163     (catch #t
 164       (lambda () (texi->plain-text description))
 165       (lambda (keys . args)
 166         (emit-warning package
 167                       (_ "Texinfo markup in description is invalid")
 168                       'description)
 169         #f)))
 170
 171   (define (check-trademarks description)
 172     "Check that DESCRIPTION does not contain '™' or '®' characters.  See
 173 http://www.gnu.org/prep/standards/html_node/Trademarks.html."
 174     (match (string-index description (char-set #\™ #\®))
 175       ((and (? number?) index)
 176        (emit-warning package
 177                      (format #f (_ "description should not contain ~
 178 trademark sign '~a' at ~d")
 179                              (string-ref description index) index)
 180                      'description))
 181       (else #t)))
 182
 183   (define (check-quotes description)
 184     "Check whether DESCRIPTION contains single quotes and suggest @code."
 185     (when (regexp-exec %quoted-identifier-rx description)
 186       (emit-warning package
 187
 188                     ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
 189                     ;; as is.
 190                     (_ "use @code or similar ornament instead of quotes")
 191                     'description)))
 192
 193   (define (check-proper-start description)
 194     (unless (or (properly-starts-sentence? description)
 195                 (string-prefix-ci? (package-name package) description))
 196       (emit-warning package
 197                     (_ "description should start with an upper-case letter or digit")
 198                     'description)))
 199
 200   (define (check-end-of-sentence-space description)
 201     "Check that an end-of-sentence period is followed by two spaces."
 202     (let ((infractions
 203            (reverse (fold-matches
 204                      "\\. [A-Z]" description '()
 205                      (lambda (m r)
 206                        ;; Filter out matches of common abbreviations.
 207                        (if (find (lambda (s)
 208                                    (string-suffix-ci? s (match:prefix m)))
 209                                  '("i.e" "e.g" "a.k.a" "resp"))
 210                            r (cons (match:start m) r)))))))
 211       (unless (null? infractions)
 212         (emit-warning package
 213                       (format #f (_ "sentences in description should be followed ~
 214 by two spaces; possible infraction~p at ~{~a~^, ~}")
 215                               (length infractions)
 216                               infractions)
 217                       'description))))
 218
 219   (let ((description (package-description package)))
 220     (if (string? description)
 221         (begin
 222           (check-not-empty description)
 223           (check-quotes description)
 224           (check-trademarks description)
 225           ;; Use raw description for this because Texinfo rendering
 226           ;; automatically fixes end of sentence space.
 227           (check-end-of-sentence-space description)
 228           (and=> (check-texinfo-markup description)
 229                  check-proper-start))
 230         (emit-warning package
 231                       (format #f (_ "invalid description: ~s") description)
 232                       'description))))
 233
 234 (define (warn-if-package-has-input linted inputs-to-check input-names message)
 235   ;; Emit a warning MESSAGE if some of the inputs named in INPUT-NAMES are
 236   ;; contained in INPUTS-TO-CHECK, which are assumed to be inputs of package
 237   ;; LINTED.
 238   (match inputs-to-check
 239     (((labels packages . outputs) ...)
 240      (for-each (lambda (package output)
 241                  (when (package? package)
 242                    (let ((input (string-append
 243                                  (package-name package)
 244                                  (if (> (length output) 0)
 245                                      (string-append ":" (car output))
 246                                      ""))))
 247                      (when (member input input-names)
 248                        (emit-warning linted
 249                                      (format #f (_ message) input)
 250                                      'inputs-to-check)))))
 251                packages outputs))))
 252
 253 (define (check-inputs-should-be-native package)
 254   ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
 255   ;; native inputs.
 256   (let ((message "'~a' should probably be a native input")
 257         (inputs (package-inputs package))
 258         (input-names
 259           '("pkg-config"
 260             "extra-cmake-modules"
 261             "glib:bin"
 262             "intltool"
 263             "itstool"
 264             "qttools"
 265             "python-coverage" "python2-coverage"
 266             "python-cython" "python2-cython"
 267             "python-docutils" "python2-docutils"
 268             "python-mock" "python2-mock"
 269             "python-nose" "python2-nose"
 270             "python-pbr" "python2-pbr"
 271             "python-pytest" "python2-pytest"
 272             "python-pytest-cov" "python2-pytest-cov"
 273             "python-setuptools-scm" "python2-setuptools-scm"
 274             "python-sphinx" "python2-sphinx")))
 275     (warn-if-package-has-input package inputs input-names message)))
 276
 277 (define (check-inputs-should-not-be-an-input-at-all package)
 278   ;; Emit a warning if some inputs of PACKAGE are likely to should not be
 279   ;; an input at all.
 280   (let ((message "'~a' should probably not be an input at all")
 281         (inputs (package-inputs package))
 282         (input-names
 283           '("python-setuptools"
 284             "python2-setuptools"
 285             "python-pip"
 286             "python2-pip")))
 287     (warn-if-package-has-input package (package-inputs package)
 288                                input-names message)
 289     (warn-if-package-has-input package (package-native-inputs package)
 290                                input-names message)
 291     (warn-if-package-has-input package (package-propagated-inputs package)
 292                                input-names message)))
 293
 294 (define (package-name-regexp package)
 295   "Return a regexp that matches PACKAGE's name as a word at the beginning of a
 296 line."
 297   (make-regexp (string-append "^" (regexp-quote (package-name package))
 298                               "\\>")
 299                regexp/icase))
 300
 301 (define (check-synopsis-style package)
 302   ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
 303   (define (check-not-empty synopsis)
 304     (when (string-null? synopsis)
 305       (emit-warning package
 306                     (_ "synopsis should not be empty")
 307                     'synopsis)))
 308
 309   (define (check-final-period synopsis)
 310     ;; Synopsis should not end with a period, except for some special cases.
 311     (when (and (string-suffix? "." synopsis)
 312                (not (string-suffix? "etc." synopsis)))
 313       (emit-warning package
 314                     (_ "no period allowed at the end of the synopsis")
 315                     'synopsis)))
 316
 317   (define check-start-article
 318     ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
 319     ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>.
 320     (if (false-if-exception (gnu-package? package))
 321         (const #t)
 322         (lambda (synopsis)
 323           (when (or (string-prefix-ci? "A " synopsis)
 324                     (string-prefix-ci? "An " synopsis))
 325             (emit-warning package
 326                           (_ "no article allowed at the beginning of \
 327 the synopsis")
 328                           'synopsis)))))
 329
 330   (define (check-synopsis-length synopsis)
 331     (when (>= (string-length synopsis) 80)
 332       (emit-warning package
 333                     (_ "synopsis should be less than 80 characters long")
 334                     'synopsis)))
 335
 336   (define (check-proper-start synopsis)
 337     (unless (properly-starts-sentence? synopsis)
 338       (emit-warning package
 339                     (_ "synopsis should start with an upper-case letter or digit")
 340                     'synopsis)))
 341
 342   (define (check-start-with-package-name synopsis)
 343     (when (and (regexp-exec (package-name-regexp package) synopsis)
 344                (not (starts-with-abbreviation? synopsis)))
 345       (emit-warning package
 346                     (_ "synopsis should not start with the package name")
 347                     'synopsis)))
 348
 349   (define checks
 350     (list check-not-empty check-proper-start check-final-period
 351           check-start-article check-start-with-package-name
 352           check-synopsis-length))
 353
 354   (match (package-synopsis package)
 355     ((? string? synopsis)
 356      (for-each (lambda (proc)
 357                  (proc synopsis))
 358                checks))
 359     (invalid
 360      (emit-warning package (format #f (_ "invalid synopsis: ~s") invalid)
 361                    'synopsis))))
 362
 363 (define* (probe-uri uri #:key timeout)
 364   "Probe URI, a URI object, and return two values: a symbol denoting the
 365 probing status, such as 'http-response' when we managed to get an HTTP
 366 response from URI, and additional details, such as the actual HTTP response.
 367
 368 TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
 369 for connections to complete; when TIMEOUT is #f, wait as long as needed."
 370   (define headers
 371     '((User-Agent . "GNU Guile")
 372       (Accept . "*/*")))
 373
 374   (let loop ((uri     uri)
 375              (visited '()))
 376     (match (uri-scheme uri)
 377       ((or 'http 'https)
 378        (catch #t
 379          (lambda ()
 380            (let ((port    (open-connection-for-uri uri #:timeout timeout))
 381                  (request (build-request uri #:headers headers)))
 382              (define response
 383                (dynamic-wind
 384                  (const #f)
 385                  (lambda ()
 386                    (write-request request port)
 387                    (force-output port)
 388                    (read-response port))
 389                  (lambda ()
 390                    (close-connection port))))
 391
 392              (case (response-code response)
 393                ((301 302 307)
 394                 (let ((location (response-location response)))
 395                   (if (or (not location) (member location visited))
 396                       (values 'http-response response)
 397                       (loop location (cons location visited))))) ;follow the redirect
 398                (else
 399                 (values 'http-response response)))))
 400          (lambda (key . args)
 401            (case key
 402              ((bad-header bad-header-component)
 403               ;; This can happen if the server returns an invalid HTTP header,
 404               ;; as is the case with the 'Date' header at sqlite.org.
 405               (values 'invalid-http-response #f))
 406              ((getaddrinfo-error system-error
 407                gnutls-error tls-certificate-error)
 408               (values key args))
 409              (else
 410               (apply throw key args))))))
 411       ('ftp
 412        (catch #t
 413          (lambda ()
 414            (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
 415              (define response
 416                (dynamic-wind
 417                  (const #f)
 418                  (lambda ()
 419                    (ftp-chdir conn (dirname (uri-path uri)))
 420                    (ftp-size conn (basename (uri-path uri))))
 421                  (lambda ()
 422                    (ftp-close conn))))
 423              (values 'ftp-response '(ok))))
 424          (lambda (key . args)
 425            (case key
 426              ((ftp-error)
 427               (values 'ftp-response `(error ,@args)))
 428              ((getaddrinfo-error system-error gnutls-error)
 429               (values key args))
 430              (else
 431               (apply throw key args))))))
 432       (_
 433        (values 'unknown-protocol #f)))))
 434
 435 (define (tls-certificate-error-string args)
 436   "Return a string explaining the 'tls-certificate-error' arguments ARGS."
 437   (call-with-output-string
 438     (lambda (port)
 439       (print-exception port #f
 440                        'tls-certificate-error args))))
 441
 442 (define (validate-uri uri package field)
 443   "Return #t if the given URI can be reached, otherwise return #f and emit a
 444 warning for PACKAGE mentionning the FIELD."
 445   (let-values (((status argument)
 446                 (probe-uri uri #:timeout 3)))     ;wait at most 3 seconds
 447     (case status
 448       ((http-response)
 449        (if (= 200 (response-code argument))
 450            (match (response-content-length argument)
 451              ((? number? length)
 452               ;; As of July 2016, SourceForge returns 200 (instead of 404)
 453               ;; with a small HTML page upon failure.  Attempt to detect such
 454               ;; malicious behavior.
 455               (or (> length 1000)
 456                   (begin
 457                     (emit-warning package
 458                                   (format #f
 459                                           (_ "URI ~a returned \
 460 suspiciously small file (~a bytes)")
 461                                           (uri->string uri)
 462                                           length))
 463                     #f)))
 464              (_ #t))
 465            (begin
 466              (emit-warning package
 467                            (format #f
 468                                    (_ "URI ~a not reachable: ~a (~s)")
 469                                    (uri->string uri)
 470                                    (response-code argument)
 471                                    (response-reason-phrase argument))
 472                            field)
 473              #f)))
 474       ((ftp-response)
 475        (match argument
 476          (('ok) #t)
 477          (('error port command code message)
 478           (emit-warning package
 479                         (format #f
 480                                 (_ "URI ~a not reachable: ~a (~s)")
 481                                 (uri->string uri)
 482                                 code (string-trim-both message)))
 483           #f)))
 484       ((getaddrinfo-error)
 485        (emit-warning package
 486                      (format #f
 487                              (_ "URI ~a domain not found: ~a")
 488                              (uri->string uri)
 489                              (gai-strerror (car argument)))
 490                      field)
 491        #f)
 492       ((system-error)
 493        (emit-warning package
 494                      (format #f
 495                              (_ "URI ~a unreachable: ~a")
 496                              (uri->string uri)
 497                              (strerror
 498                               (system-error-errno
 499                                (cons status argument))))
 500                      field)
 501        #f)
 502       ((tls-certificate-error)
 503        (emit-warning package
 504                      (format #f (_ "TLS certificate error: ~a")
 505                              (tls-certificate-error-string argument))))
 506       ((invalid-http-response gnutls-error)
 507        ;; Probably a misbehaving server; ignore.
 508        #f)
 509       ((unknown-protocol)                             ;nothing we can do
 510        #f)
 511       (else
 512        (error "internal linter error" status)))))
 513
 514 (define (check-home-page package)
 515   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 516 'home-page' is not reachable."
 517   (let ((uri (and=> (package-home-page package) string->uri)))
 518     (cond
 519      ((uri? uri)
 520       (validate-uri uri package 'home-page))
 521      ((not (package-home-page package))
 522       (unless (or (string-contains (package-name package) "bootstrap")
 523                   (string=? (package-name package) "ld-wrapper"))
 524         (emit-warning package
 525                       (_ "invalid value for home page")
 526                       'home-page)))
 527      (else
 528       (emit-warning package (format #f (_ "invalid home page URL: ~s")
 529                                     (package-home-page package))
 530                     'home-page)))))
 531
 532 (define (check-patch-file-names package)
 533   "Emit a warning if the patches requires by PACKAGE are badly named or if the
 534 patch could not be found."
 535   (guard (c ((message-condition? c)     ;raised by 'search-patch'
 536              (emit-warning package (condition-message c)
 537                            'patch-file-names)))
 538     (unless (every (match-lambda        ;patch starts with package name?
 539                      ((? string? patch)
 540                       (and=> (string-contains (basename patch)
 541                                               (package-name package))
 542                              zero?))
 543                      (_  #f))     ;must be an <origin> or something like that.
 544                    (or (and=> (package-source package) origin-patches)
 545                        '()))
 546       (emit-warning
 547        package
 548        (_ "file names of patches should start with the package name")
 549        'patch-file-names))))
 550
 551 (define (escape-quotes str)
 552   "Replace any quote character in STR by an escaped quote character."
 553   (list->string
 554    (string-fold-right (lambda (chr result)
 555                         (match chr
 556                           (#\" (cons* #\\ #\"result))
 557                           (_   (cons chr result))))
 558                       '()
 559                       str)))
 560
 561 (define official-gnu-packages*
 562   (mlambda ()
 563     "A memoizing version of 'official-gnu-packages' that returns the empty
 564 list when something goes wrong, such as a networking issue."
 565     (let ((gnus (false-if-exception (official-gnu-packages))))
 566       (or gnus '()))))
 567
 568 (define (check-gnu-synopsis+description package)
 569   "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
 570 descriptions maintained upstream."
 571   (match (find (lambda (descriptor)
 572                  (string=? (gnu-package-name descriptor)
 573                            (package-name package)))
 574                (official-gnu-packages*))
 575     (#f                                   ;not a GNU package, so nothing to do
 576      #t)
 577     (descriptor                                   ;a genuine GNU package
 578      (let ((upstream   (gnu-package-doc-summary descriptor))
 579            (downstream (package-synopsis package))
 580            (loc        (or (package-field-location package 'synopsis)
 581                            (package-location package))))
 582        (when (and upstream
 583                   (or (not (string? downstream))
 584                       (not (string=? upstream downstream))))
 585          (format (guix-warning-port)
 586                  (_ "~a: ~a: proposed synopsis: ~s~%")
 587                  (location->string loc) (package-full-name package)
 588                  upstream)))
 589
 590      (let ((upstream   (gnu-package-doc-description descriptor))
 591            (downstream (package-description package))
 592            (loc        (or (package-field-location package 'description)
 593                            (package-location package))))
 594        (when (and upstream
 595                   (or (not (string? downstream))
 596                       (not (string=? (fill-paragraph upstream 100)
 597                                      (fill-paragraph downstream 100)))))
 598          (format (guix-warning-port)
 599                  (_ "~a: ~a: proposed description:~%     \"~a\"~%")
 600                  (location->string loc) (package-full-name package)
 601                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 602
 603 (define (origin-uris origin)
 604   "Return the list of URIs (strings) for ORIGIN."
 605   (match (origin-uri origin)
 606     ((? string? uri)
 607      (list uri))
 608     ((uris ...)
 609      uris)))
 610
 611 (define (check-source package)
 612   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 613 'source' is not reachable."
 614   (define (try-uris uris)
 615     (run-with-state
 616         (anym %state-monad
 617               (lambda (uri)
 618                 (with-accumulated-warnings
 619                  (validate-uri uri package 'source)))
 620               (append-map (cut maybe-expand-mirrors <> %mirrors)
 621                           uris))
 622       '()))
 623
 624   (let ((origin (package-source package)))
 625     (when (and origin
 626                (eqv? (origin-method origin) url-fetch))
 627       (let ((uris (map string->uri (origin-uris origin))))
 628
 629         ;; Just make sure that at least one of the URIs is valid.
 630         (call-with-values
 631             (lambda () (try-uris uris))
 632           (lambda (success? warnings)
 633             ;; When everything fails, report all of WARNINGS, otherwise don't
 634             ;; report anything.
 635             ;;
 636             ;; XXX: Ideally we'd still allow warnings to be raised if *some*
 637             ;; URIs are unreachable, but distinguish that from the error case
 638             ;; where *all* the URIs are unreachable.
 639             (unless success?
 640               (emit-warning package
 641                             (_ "all the source URIs are unreachable:")
 642                             'source)
 643               (for-each (lambda (warning)
 644                           (display warning (guix-warning-port)))
 645                         (reverse warnings)))))))))
 646
 647 (define (check-source-file-name package)
 648   "Emit a warning if PACKAGE's origin has no meaningful file name."
 649   (define (origin-file-name-valid? origin)
 650     ;; Return #t if the source file name contains only a version or is #f;
 651     ;; indicates that the origin needs a 'file-name' field.
 652     (let ((file-name (origin-actual-file-name origin))
 653           (version (package-version package)))
 654       (and file-name
 655            (not (or (string-prefix? version file-name)
 656                     ;; Common in many projects is for the filename to start
 657                     ;; with a "v" followed by the version,
 658                     ;; e.g. "v3.2.0.tar.gz".
 659                     (string-prefix? (string-append "v" version) file-name))))))
 660
 661   (let ((origin (package-source package)))
 662     (unless (or (not origin) (origin-file-name-valid? origin))
 663       (emit-warning package
 664                     (_ "the source file name should contain the package name")
 665                     'source))))
 666
 667 (define (check-mirror-url package)
 668   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
 669   (define (check-mirror-uri uri)                  ;XXX: could be optimized
 670     (let loop ((mirrors %mirrors))
 671       (match mirrors
 672         (()
 673          #t)
 674         (((mirror-id mirror-urls ...) rest ...)
 675          (match (find (cut string-prefix? <> uri) mirror-urls)
 676            (#f
 677             (loop rest))
 678            (prefix
 679             (emit-warning package
 680                           (format #f (_ "URL should be \
 681 'mirror://~a/~a'")
 682                                   mirror-id
 683                                   (string-drop uri (string-length prefix)))
 684                           'source)))))))
 685
 686   (let ((origin (package-source package)))
 687     (when (and (origin? origin)
 688                (eqv? (origin-method origin) url-fetch))
 689       (let ((uris (origin-uris origin)))
 690         (for-each check-mirror-uri uris)))))
 691
 692 (define (check-derivation package)
 693   "Emit a warning if we fail to compile PACKAGE to a derivation."
 694   (catch #t
 695     (lambda ()
 696       (guard (c ((nix-protocol-error? c)
 697                  (emit-warning package
 698                                (format #f (_ "failed to create derivation: ~a")
 699                                        (nix-protocol-error-message c))))
 700                 ((message-condition? c)
 701                  (emit-warning package
 702                                (format #f (_ "failed to create derivation: ~a")
 703                                        (condition-message c)))))
 704         (with-store store
 705           ;; Disable grafts since it can entail rebuilds.
 706           (package-derivation store package #:graft? #f)
 707
 708           ;; If there's a replacement, make sure we can compute its
 709           ;; derivation.
 710           (match (package-replacement package)
 711             (#f #t)
 712             (replacement
 713              (package-derivation store replacement #:graft? #f))))))
 714     (lambda args
 715       (emit-warning package
 716                     (format #f (_ "failed to create derivation: ~s~%")
 717                             args)))))
 718
 719 (define (check-license package)
 720   "Warn about type errors of the 'license' field of PACKAGE."
 721   (match (package-license package)
 722     ((or (? license?)
 723          ((? license?) ...))
 724      #t)
 725     (x
 726      (emit-warning package (_ "invalid license field")
 727                    'license))))
 728
 729 (define (patch-file-name patch)
 730   "Return the basename of PATCH's file name, or #f if the file name could not
 731 be determined."
 732   (match patch
 733     ((? string?)
 734      (basename patch))
 735     ((? origin?)
 736      (and=> (origin-actual-file-name patch) basename))))
 737
 738 (define (current-vulnerabilities*)
 739   "Like 'current-vulnerabilities', but return the empty list upon networking
 740 or HTTP errors.  This allows network-less operation and makes problems with
 741 the NIST server non-fatal.."
 742   (guard (c ((http-get-error? c)
 743              (warning (_ "failed to retrieve CVE vulnerabilities \
 744 from ~s: ~a (~s)~%")
 745                       (uri->string (http-get-error-uri c))
 746                       (http-get-error-code c)
 747                       (http-get-error-reason c))
 748              (warning (_ "assuming no CVE vulnerabilities~%"))
 749              '()))
 750     (catch #t
 751       (lambda ()
 752         (current-vulnerabilities))
 753       (match-lambda*
 754         (('getaddrinfo-error errcode)
 755          (warning (_ "failed to lookup NIST host: ~a~%")
 756                   (gai-strerror errcode))
 757          (warning (_ "assuming no CVE vulnerabilities~%"))
 758          '())
 759         (('tls-certificate-error args ...)
 760          (warning (_ "TLS certificate error: ~a")
 761                   (tls-certificate-error-string args))
 762          (warning (_ "assuming no CVE vulnerabilities~%"))
 763          '())
 764         (args
 765          (apply throw args))))))
 766
 767 (define package-vulnerabilities
 768   (let ((lookup (delay (vulnerabilities->lookup-proc
 769                         (current-vulnerabilities*)))))
 770     (lambda (package)
 771       "Return a list of vulnerabilities affecting PACKAGE."
 772       ;; First we retrieve the Common Platform Enumeration (CPE) name and
 773       ;; version for PACKAGE, then we can pass them to LOOKUP.
 774       (let ((name    (or (assoc-ref (package-properties package)
 775                                     'cpe-name)
 776                          (package-name package)))
 777             (version (or (assoc-ref (package-properties package)
 778                                     'cpe-version)
 779                          (package-version package))))
 780         ((force lookup) name version)))))
 781
 782 (define (check-vulnerabilities package)
 783   "Check for known vulnerabilities for PACKAGE."
 784   (let ((package (or (package-replacement package) package)))
 785     (match (package-vulnerabilities package)
 786       (()
 787        #t)
 788       ((vulnerabilities ...)
 789        (let* ((patches   (filter-map patch-file-name
 790                                      (or (and=> (package-source package)
 791                                                 origin-patches)
 792                                          '())))
 793               (unpatched (remove (lambda (vuln)
 794                                    (find (cute string-contains
 795                                            <> (vulnerability-id vuln))
 796                                          patches))
 797                                  vulnerabilities)))
 798          (unless (null? unpatched)
 799            (emit-warning package
 800                          (format #f (_ "probably vulnerable to ~a")
 801                                  (string-join (map vulnerability-id unpatched)
 802                                               ", ")))))))))
 803
 804 \f
 805 ;;;
 806 ;;; Source code formatting.
 807 ;;;
 808
 809 (define (report-tabulations package line line-number)
 810   "Warn about tabulations found in LINE."
 811   (match (string-index line #\tab)
 812     (#f #t)
 813     (index
 814      (emit-warning package
 815                    (format #f (_ "tabulation on line ~a, column ~a")
 816                            line-number index)))))
 817
 818 (define (report-trailing-white-space package line line-number)
 819   "Warn about trailing white space in LINE."
 820   (unless (or (string=? line (string-trim-right line))
 821               (string=? line (string #\page)))
 822     (emit-warning package
 823                   (format #f
 824                           (_ "trailing white space on line ~a")
 825                           line-number))))
 826
 827 (define (report-long-line package line line-number)
 828   "Emit a warning if LINE is too long."
 829   ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
 830   ;; make it hard to fit within that limit and we want to avoid making too
 831   ;; much noise.
 832   (when (> (string-length line) 90)
 833     (emit-warning package
 834                   (format #f (_ "line ~a is way too long (~a characters)")
 835                           line-number (string-length line)))))
 836
 837 (define %hanging-paren-rx
 838   (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
 839
 840 (define (report-lone-parentheses package line line-number)
 841   "Emit a warning if LINE contains hanging parentheses."
 842   (when (regexp-exec %hanging-paren-rx line)
 843     (emit-warning package
 844                   (format #f
 845                           (_ "line ~a: parentheses feel lonely, \
 846 move to the previous or next line")
 847                           line-number))))
 848
 849 (define %formatting-reporters
 850   ;; List of procedures that report formatting issues.  These are not separate
 851   ;; checkers because they would need to re-read the file.
 852   (list report-tabulations
 853         report-trailing-white-space
 854         report-long-line
 855         report-lone-parentheses))
 856
 857 (define* (report-formatting-issues package file starting-line
 858                                    #:key (reporters %formatting-reporters))
 859   "Report white-space issues in FILE starting from STARTING-LINE, and report
 860 them for PACKAGE."
 861   (define last-line
 862     ;; Number of the presumed last line.
 863     ;; XXX: Ideally we'd stop at the boundaries of the surrounding sexp, but
 864     ;; for now just use this simple heuristic.
 865     (+ starting-line 60))
 866
 867   (call-with-input-file file
 868     (lambda (port)
 869       (let loop ((line-number 1))
 870         (let ((line (read-line port)))
 871           (or (eof-object? line)
 872               (> line-number last-line)
 873               (begin
 874                 (unless (< line-number starting-line)
 875                   (for-each (lambda (report)
 876                               (report package line line-number))
 877                             reporters))
 878                 (loop (+ 1 line-number)))))))))
 879
 880 (define (check-formatting package)
 881   "Check the formatting of the source code of PACKAGE."
 882   (let ((location (package-location package)))
 883     (when location
 884       (and=> (search-path %load-path (location-file location))
 885              (lambda (file)
 886                ;; Report issues starting from the line before the 'package'
 887                ;; form, which usually contains the 'define' form.
 888                (report-formatting-issues package file
 889                                          (- (location-line location) 1)))))))
 890
 891 \f
 892 ;;;
 893 ;;; List of checkers.
 894 ;;;
 895
 896 (define %checkers
 897   (list
 898    (lint-checker
 899      (name        'description)
 900      (description "Validate package descriptions")
 901      (check       check-description-style))
 902    (lint-checker
 903      (name        'gnu-description)
 904      (description "Validate synopsis & description of GNU packages")
 905      (check       check-gnu-synopsis+description))
 906    (lint-checker
 907      (name        'inputs-should-be-native)
 908      (description "Identify inputs that should be native inputs")
 909      (check       check-inputs-should-be-native))
 910    (lint-checker
 911      (name        'inputs-should-not-be-input)
 912      (description "Identify inputs that should be inputs at all")
 913      (check       check-inputs-should-not-be-an-input-at-all))
 914    (lint-checker
 915      (name        'patch-file-names)
 916      (description "Validate file names and availability of patches")
 917      (check       check-patch-file-names))
 918    (lint-checker
 919      (name        'home-page)
 920      (description "Validate home-page URLs")
 921      (check       check-home-page))
 922    (lint-checker
 923      (name        'license)
 924      ;; TRANSLATORS: <license> is the name of a data type and must not be
 925      ;; translated.
 926      (description "Make sure the 'license' field is a <license> \
 927 or a list thereof")
 928      (check       check-license))
 929    (lint-checker
 930      (name        'source)
 931      (description "Validate source URLs")
 932      (check       check-source))
 933    (lint-checker
 934      (name        'mirror-url)
 935      (description "Suggest 'mirror://' URLs")
 936      (check       check-mirror-url))
 937    (lint-checker
 938      (name        'source-file-name)
 939      (description "Validate file names of sources")
 940      (check       check-source-file-name))
 941    (lint-checker
 942      (name        'derivation)
 943      (description "Report failure to compile a package to a derivation")
 944      (check       check-derivation))
 945    (lint-checker
 946      (name        'synopsis)
 947      (description "Validate package synopses")
 948      (check       check-synopsis-style))
 949    (lint-checker
 950      (name        'cve)
 951      (description "Check the Common Vulnerabilities and Exposures\
 952  (CVE) database")
 953      (check       check-vulnerabilities))
 954    (lint-checker
 955      (name        'formatting)
 956      (description "Look for formatting issues in the source")
 957      (check       check-formatting))))
 958
 959 (define* (run-checkers package #:optional (checkers %checkers))
 960   "Run the given CHECKERS on PACKAGE."
 961   (let ((tty? (isatty? (current-error-port))))
 962     (for-each (lambda (checker)
 963                 (when tty?
 964                   (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r"
 965                           (package-name package) (package-version package)
 966                           (lint-checker-name checker))
 967                   (force-output (current-error-port)))
 968                 ((lint-checker-check checker) package))
 969               checkers)
 970     (when tty?
 971       (format (current-error-port) "\x1b[K")
 972       (force-output (current-error-port)))))
 973
 974 \f
 975 ;;;
 976 ;;; Command-line options.
 977 ;;;
 978
 979 (define %default-options
 980   ;; Alist of default option values.
 981   '())
 982
 983 (define (show-help)
 984   (display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
 985 Run a set of checkers on the specified package; if none is specified,
 986 run the checkers on all packages.\n"))
 987   (display (_ "
 988   -c, --checkers=CHECKER1,CHECKER2...
 989                          only run the specified checkers"))
 990   (display (_ "
 991   -h, --help             display this help and exit"))
 992   (display (_ "
 993   -l, --list-checkers    display the list of available lint checkers"))
 994   (display (_ "
 995   -V, --version          display version information and exit"))
 996   (newline)
 997   (show-bug-report-information))
 998
 999
1000 (define %options
1001   ;; Specification of the command-line options.
1002   ;; TODO: add some options:
1003   ;; * --certainty=[low,medium,high]: only run checkers that have at least this
1004   ;;                                  'certainty'.
1005   (list (option '(#\c "checkers") #t #f
1006                 (lambda (opt name arg result)
1007                   (let ((names (map string->symbol (string-split arg #\,))))
1008                     (for-each (lambda (c)
1009                                 (unless (memq c
1010                                               (map lint-checker-name
1011                                                    %checkers))
1012                                   (leave (_ "~a: invalid checker~%") c)))
1013                               names)
1014                     (alist-cons 'checkers
1015                                 (filter (lambda (checker)
1016                                           (member (lint-checker-name checker)
1017                                                   names))
1018                                         %checkers)
1019                                 result))))
1020         (option '(#\h "help") #f #f
1021                 (lambda args
1022                   (show-help)
1023                   (exit 0)))
1024         (option '(#\l "list-checkers") #f #f
1025                 (lambda args
1026                    (list-checkers-and-exit)))
1027         (option '(#\V "version") #f #f
1028                 (lambda args
1029                   (show-version-and-exit "guix lint")))))
1030
1031 \f
1032 ;;;
1033 ;;; Entry Point
1034 ;;;
1035
1036 (define (guix-lint . args)
1037   (define (parse-options)
1038     ;; Return the alist of option values.
1039     (args-fold* args %options
1040                 (lambda (opt name arg result)
1041                   (leave (_ "~A: unrecognized option~%") name))
1042                 (lambda (arg result)
1043                   (alist-cons 'argument arg result))
1044                 %default-options))
1045
1046   (let* ((opts (parse-options))
1047          (args (filter-map (match-lambda
1048                             (('argument . value)
1049                              value)
1050                             (_ #f))
1051                            (reverse opts)))
1052          (checkers (or (assoc-ref opts 'checkers) %checkers)))
1053      (if (null? args)
1054           (fold-packages (lambda (p r) (run-checkers p checkers)) '())
1055           (for-each (lambda (spec)
1056                       (run-checkers (specification->package spec) checkers))
1057                     args))))