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, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   5 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
   6 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
   7 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
   8 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
   9 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
  10 ;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
  11 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
  12 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
  13 ;;;
  14 ;;; This file is part of GNU Guix.
  15 ;;;
  16 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  17 ;;; under the terms of the GNU General Public License as published by
  18 ;;; the Free Software Foundation; either version 3 of the License, or (at
  19 ;;; your option) any later version.
  20 ;;;
  21 ;;; GNU Guix is distributed in the hope that it will be useful, but
  22 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;;; GNU General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  28
  29 (define-module (guix scripts lint)
  30   #:use-module (guix packages)
  31   #:use-module (guix lint)
  32   #:use-module (guix ui)
  33   #:use-module (guix store)
  34   #:use-module (guix scripts)
  35   #:use-module (guix scripts build)
  36   #:use-module (gnu packages)
  37   #:use-module (ice-9 match)
  38   #:use-module (ice-9 format)
  39   #:use-module (srfi srfi-1)
  40   #:use-module (srfi srfi-37)
  41   #:export (guix-lint
  42             run-checkers))
  43
  44 (define (emit-warnings warnings)
  45   ;; Emit a warning about PACKAGE, printing the location of FIELD if it is
  46   ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
  47   ;; provided MESSAGE.
  48   (for-each
  49    (lambda (lint-warning)
  50      (let ((package (lint-warning-package lint-warning))
  51            (loc     (lint-warning-location lint-warning)))
  52        (info loc (G_ "~a@~a: ~a~%")
  53              (package-name package) (package-version package)
  54              (lint-warning-message lint-warning))))
  55    warnings))
  56
  57 (define* (run-checkers package checkers #:key store)
  58   "Run the given CHECKERS on PACKAGE."
  59   (let ((tty? (isatty? (current-error-port))))
  60     (for-each (lambda (checker)
  61                 (when tty?
  62                   (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r"
  63                           (package-name package) (package-version package)
  64                           (lint-checker-name checker))
  65                   (force-output (current-error-port)))
  66                 (emit-warnings
  67                  (if (lint-checker-requires-store? checker)
  68                      ((lint-checker-check checker) package #:store store)
  69                      ((lint-checker-check checker) package))))
  70               checkers)
  71     (when tty?
  72       (format (current-error-port) "\x1b[K")
  73       (force-output (current-error-port)))))
  74
  75 (define (list-checkers-and-exit checkers)
  76   ;; Print information about all available checkers and exit.
  77   (format #t (G_ "Available checkers:~%"))
  78   (for-each (lambda (checker)
  79               (format #t "- ~a: ~a~%"
  80                       (lint-checker-name checker)
  81                       (G_ (lint-checker-description checker))))
  82             checkers)
  83   (exit 0))
  84
  85 \f
  86 ;;;
  87 ;;; Command-line options.
  88 ;;;
  89
  90 (define %default-options
  91   ;; Alist of default option values.
  92   '())
  93
  94 (define (show-help)
  95   (display (G_ "Usage: guix lint [OPTION]... [PACKAGE]...
  96 Run a set of checkers on the specified package; if none is specified,
  97 run the checkers on all packages.\n"))
  98   (display (G_ "
  99   -c, --checkers=CHECKER1,CHECKER2...
 100                          only run the specified checkers"))
 101   (display (G_ "
 102   -L, --load-path=DIR    prepend DIR to the package module search path"))
 103   (newline)
 104   (display (G_ "
 105   -h, --help             display this help and exit"))
 106   (display (G_ "
 107   -l, --list-checkers    display the list of available lint checkers"))
 108   (display (G_ "
 109   -V, --version          display version information and exit"))
 110   (newline)
 111   (show-bug-report-information))
 112
 113
 114 (define %options
 115   ;; Specification of the command-line options.
 116   ;; TODO: add some options:
 117   ;; * --certainty=[low,medium,high]: only run checkers that have at least this
 118   ;;                                  'certainty'.
 119   (list (option '(#\c "checkers") #t #f
 120                 (lambda (opt name arg result)
 121                   (let ((names (map string->symbol (string-split arg #\,)))
 122                         (checker-names (map lint-checker-name %all-checkers)))
 123                     (for-each (lambda (c)
 124                                 (unless (memq c checker-names)
 125                                   (leave (G_ "~a: invalid checker~%") c)))
 126                               names)
 127                     (alist-cons 'checkers
 128                                 (filter (lambda (checker)
 129                                           (member (lint-checker-name checker)
 130                                                   names))
 131                                         %all-checkers)
 132                                 result))))
 133         (option '(#\n "no-network") #f #f
 134                 (lambda (opt name arg result)
 135                   (alist-cons 'checkers
 136                               %local-checkers
 137                               (alist-delete 'checkers
 138                                             result))))
 139         (find (lambda (option)
 140                 (member "load-path" (option-names option)))
 141               %standard-build-options)
 142         (option '(#\h "help") #f #f
 143                 (lambda args
 144                   (show-help)
 145                   (exit 0)))
 146         (option '(#\l "list-checkers") #f #f
 147                 (lambda (opt name arg result)
 148                   (alist-cons 'list?
 149                               #t
 150                               result)))
 151         (option '(#\V "version") #f #f
 152                 (lambda args
 153                   (show-version-and-exit "guix lint")))))
 154
 155 \f
 156 ;;;
 157 ;;; Entry Point
 158 ;;;
 159
 160 (define-command (guix-lint . args)
 161   (category packaging)
 162   (synopsis "validate package definitions")
 163
 164   (define (parse-options)
 165     ;; Return the alist of option values.
 166     (parse-command-line args %options (list %default-options)
 167                         #:build-options? #f))
 168
 169   (let* ((opts (parse-options))
 170          (args (filter-map (match-lambda
 171                              (('argument . value)
 172                               value)
 173                              (_ #f))
 174                            (reverse opts)))
 175          (checkers (or (assoc-ref opts 'checkers) %all-checkers)))
 176
 177     (when (assoc-ref opts 'list?)
 178       (list-checkers-and-exit checkers))
 179
 180     (with-error-handling
 181       (let ((any-lint-checker-requires-store?
 182              (any lint-checker-requires-store? checkers)))
 183
 184         (define (call-maybe-with-store proc)
 185           (if any-lint-checker-requires-store?
 186               (with-store store
 187                 (proc store))
 188               (proc #f)))
 189
 190         (call-maybe-with-store
 191          (lambda (store)
 192            (cond
 193             ((null? args)
 194              (fold-packages (lambda (p r) (run-checkers p checkers
 195                                                         #:store store)) '()))
 196             (else
 197              (for-each (lambda (spec)
 198                          (run-checkers (specification->package spec) checkers
 199                                        #:store store))
 200                        args)))))))))