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