tests/lint.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
   3 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
   4 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (test-lint)
  22   #:use-module (guix tests)
  23   #:use-module (guix download)
  24   #:use-module (guix git-download)
  25   #:use-module (guix build-system gnu)
  26   #:use-module (guix packages)
  27   #:use-module (guix scripts lint)
  28   #:use-module (guix ui)
  29   #:use-module (gnu packages)
  30   #:use-module (gnu packages pkg-config)
  31   #:use-module (web server)
  32   #:use-module (web server http)
  33   #:use-module (web response)
  34   #:use-module (ice-9 threads)
  35   #:use-module (srfi srfi-9 gnu)
  36   #:use-module (srfi srfi-64))
  37
  38 ;; Test the linter.
  39
  40 (define %http-server-port
  41   ;; TCP port to use for the stub HTTP server.
  42   9999)
  43
  44 (define %local-url
  45   ;; URL to use for 'home-page' tests.
  46   (string-append "http://localhost:" (number->string %http-server-port)
  47                  "/foo/bar"))
  48
  49 (define %null-sha256
  50   ;; SHA256 of the empty string.
  51   (base32
  52    "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
  53
  54 (define %http-server-socket
  55   ;; Socket used by the Web server.
  56   (catch 'system-error
  57     (lambda ()
  58       (let ((sock (socket PF_INET SOCK_STREAM 0)))
  59         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  60         (bind sock
  61               (make-socket-address AF_INET INADDR_LOOPBACK
  62                                    %http-server-port))
  63         sock))
  64     (lambda args
  65       (let ((err (system-error-errno args)))
  66         (format (current-error-port)
  67                 "warning: cannot run Web server for tests: ~a~%"
  68                 (strerror err))
  69         #f))))
  70
  71 (define (http-write server client response body)
  72   "Write RESPONSE."
  73   (let* ((response (write-response response client))
  74          (port     (response-port response)))
  75     (cond
  76      ((not body))                                 ;pass
  77      (else
  78       (write-response-body response body)))
  79     (close-port port)
  80     (quit #t)                                     ;exit the server thread
  81     (values)))
  82
  83 ;; Mutex and condition variable to synchronize with the HTTP server.
  84 (define %http-server-lock (make-mutex))
  85 (define %http-server-ready (make-condition-variable))
  86
  87 (define (http-open . args)
  88   "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
  89   (with-mutex %http-server-lock
  90     (let ((result (apply (@@ (web server http) http-open) args)))
  91       (signal-condition-variable %http-server-ready)
  92       result)))
  93
  94 (define-server-impl stub-http-server
  95   ;; Stripped-down version of Guile's built-in HTTP server.
  96   http-open
  97   (@@ (web server http) http-read)
  98   http-write
  99   (@@ (web server http) http-close))
 100
 101 (define (call-with-http-server code thunk)
 102   "Call THUNK with an HTTP server running and returning CODE on HTTP
 103 requests."
 104   (define (server-body)
 105     (define (handle request body)
 106       (values (build-response #:code code
 107                               #:reason-phrase "Such is life")
 108               "Hello, world."))
 109
 110     (catch 'quit
 111       (lambda ()
 112         (run-server handle stub-http-server
 113                     `(#:socket ,%http-server-socket)))
 114       (const #t)))
 115
 116   (with-mutex %http-server-lock
 117     (let ((server (make-thread server-body)))
 118       (wait-condition-variable %http-server-ready %http-server-lock)
 119       ;; Normally SERVER exits automatically once it has received a request.
 120       (thunk))))
 121
 122 (define-syntax-rule (with-http-server code body ...)
 123   (call-with-http-server code (lambda () body ...)))
 124
 125 \f
 126 (test-begin "lint")
 127
 128 (define (call-with-warnings thunk)
 129   (let ((port (open-output-string)))
 130     (parameterize ((guix-warning-port port))
 131       (thunk))
 132     (get-output-string port)))
 133
 134 (define-syntax-rule (with-warnings body ...)
 135   (call-with-warnings (lambda () body ...)))
 136
 137 (test-assert "description: not empty"
 138   (->bool
 139    (string-contains (with-warnings
 140                       (let ((pkg (dummy-package "x"
 141                                    (description ""))))
 142                         (check-description-style pkg)))
 143                     "description should not be empty")))
 144
 145 (test-assert "description: does not start with an upper-case letter"
 146   (->bool
 147    (string-contains (with-warnings
 148                       (let ((pkg (dummy-package "x"
 149                                    (description "bad description."))))
 150                         (check-description-style pkg)))
 151                     "description should start with an upper-case letter")))
 152
 153 (test-assert "description: may start with a digit"
 154   (string-null?
 155    (with-warnings
 156      (let ((pkg (dummy-package "x"
 157                   (description "2-component library."))))
 158        (check-description-style pkg)))))
 159
 160 (test-assert "description: may start with lower-case package name"
 161   (string-null?
 162    (with-warnings
 163      (let ((pkg (dummy-package "x"
 164                   (description "x is a dummy package."))))
 165        (check-description-style pkg)))))
 166
 167 (test-assert "description: two spaces after end of sentence"
 168   (->bool
 169    (string-contains (with-warnings
 170                       (let ((pkg (dummy-package "x"
 171                                    (description "Bad. Quite bad."))))
 172                         (check-description-style pkg)))
 173                     "sentences in description should be followed by two spaces")))
 174
 175 (test-assert "description: end-of-sentence detection with abbreviations"
 176   (string-null?
 177    (with-warnings
 178      (let ((pkg (dummy-package "x"
 179                   (description
 180                    "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
 181        (check-description-style pkg)))))
 182
 183 (test-assert "synopsis: not empty"
 184   (->bool
 185    (string-contains (with-warnings
 186                       (let ((pkg (dummy-package "x"
 187                                    (synopsis ""))))
 188                         (check-synopsis-style pkg)))
 189                     "synopsis should not be empty")))
 190
 191 (test-assert "synopsis: does not start with an upper-case letter"
 192   (->bool
 193    (string-contains (with-warnings
 194                       (let ((pkg (dummy-package "x"
 195                                    (synopsis "bad synopsis."))))
 196                         (check-synopsis-style pkg)))
 197                     "synopsis should start with an upper-case letter")))
 198
 199 (test-assert "synopsis: may start with a digit"
 200   (string-null?
 201    (with-warnings
 202      (let ((pkg (dummy-package "x"
 203                   (synopsis "5-dimensional frobnicator"))))
 204        (check-synopsis-style pkg)))))
 205
 206 (test-assert "synopsis: ends with a period"
 207   (->bool
 208    (string-contains (with-warnings
 209                       (let ((pkg (dummy-package "x"
 210                                    (synopsis "Bad synopsis."))))
 211                         (check-synopsis-style pkg)))
 212                     "no period allowed at the end of the synopsis")))
 213
 214 (test-assert "synopsis: ends with 'etc.'"
 215   (string-null? (with-warnings
 216                   (let ((pkg (dummy-package "x"
 217                                (synopsis "Foo, bar, etc."))))
 218                     (check-synopsis-style pkg)))))
 219
 220 (test-assert "synopsis: starts with 'A'"
 221   (->bool
 222    (string-contains (with-warnings
 223                       (let ((pkg (dummy-package "x"
 224                                    (synopsis "A bad synopŝis"))))
 225                         (check-synopsis-style pkg)))
 226                     "no article allowed at the beginning of the synopsis")))
 227
 228 (test-assert "synopsis: starts with 'An'"
 229   (->bool
 230    (string-contains (with-warnings
 231                       (let ((pkg (dummy-package "x"
 232                                    (synopsis "An awful synopsis"))))
 233                         (check-synopsis-style pkg)))
 234                     "no article allowed at the beginning of the synopsis")))
 235
 236 (test-assert "synopsis: starts with 'a'"
 237   (->bool
 238    (string-contains (with-warnings
 239                       (let ((pkg (dummy-package "x"
 240                                    (synopsis "a bad synopsis"))))
 241                         (check-synopsis-style pkg)))
 242                     "no article allowed at the beginning of the synopsis")))
 243
 244 (test-assert "synopsis: starts with 'an'"
 245   (->bool
 246    (string-contains (with-warnings
 247                       (let ((pkg (dummy-package "x"
 248                                    (synopsis "an awful synopsis"))))
 249                         (check-synopsis-style pkg)))
 250                     "no article allowed at the beginning of the synopsis")))
 251
 252 (test-assert "synopsis: too long"
 253   (->bool
 254    (string-contains (with-warnings
 255                       (let ((pkg (dummy-package "x"
 256                                    (synopsis (make-string 80 #\x)))))
 257                         (check-synopsis-style pkg)))
 258                     "synopsis should be less than 80 characters long")))
 259
 260 (test-assert "synopsis: start with package name"
 261   (->bool
 262    (string-contains (with-warnings
 263                       (let ((pkg (dummy-package "x"
 264                                    (name "foo")
 265                                    (synopsis "foo, a nice package"))))
 266                         (check-synopsis-style pkg)))
 267                     "synopsis should not start with the package name")))
 268
 269 (test-assert "synopsis: start with package name prefix"
 270   (string-null?
 271    (with-warnings
 272      (let ((pkg (dummy-package "arb"
 273                   (synopsis "Arbitrary precision"))))
 274        (check-synopsis-style pkg)))))
 275
 276 (test-assert "synopsis: start with abbreviation"
 277   (string-null?
 278    (with-warnings
 279      (let ((pkg (dummy-package "uucp"
 280                   ;; Same problem with "APL interpreter", etc.
 281                   (synopsis "UUCP implementation")
 282                   (description "Imagine this is Taylor UUCP."))))
 283        (check-synopsis-style pkg)))))
 284
 285 (test-assert "inputs: pkg-config is probably a native input"
 286   (->bool
 287    (string-contains
 288      (with-warnings
 289        (let ((pkg (dummy-package "x"
 290                     (inputs `(("pkg-config" ,pkg-config))))))
 291          (check-inputs-should-be-native pkg)))
 292          "pkg-config should probably be a native input")))
 293
 294 (test-assert "patches: file names"
 295   (->bool
 296    (string-contains
 297      (with-warnings
 298        (let ((pkg (dummy-package "x"
 299                     (source
 300                      (origin
 301                        (method url-fetch)
 302                        (uri "someurl")
 303                        (sha256 "somesha")
 304                        (patches (list "/path/to/y.patch")))))))
 305          (check-patch-file-names pkg)))
 306      "file names of patches should start with the package name")))
 307
 308 (test-assert "patches: not found"
 309   (->bool
 310    (string-contains
 311      (with-warnings
 312        (let ((pkg (dummy-package "x"
 313                     (source
 314                      (origin
 315                        (method url-fetch)
 316                        (uri "someurl")
 317                        (sha256 "somesha")
 318                        (patches
 319                         (list (search-patch "this-patch-does-not-exist!"))))))))
 320          (check-patch-file-names pkg)))
 321      "patch not found")))
 322
 323 (test-assert "derivation: invalid arguments"
 324   (->bool
 325    (string-contains
 326     (with-warnings
 327       (let ((pkg (dummy-package "x"
 328                    (arguments
 329                     '(#:imported-modules (invalid-module))))))
 330         (check-derivation pkg)))
 331     "failed to create derivation")))
 332
 333 (test-assert "license: invalid license"
 334   (string-contains
 335    (with-warnings
 336      (check-license (dummy-package "x" (license #f))))
 337    "invalid license"))
 338
 339 (test-assert "home-page: wrong home-page"
 340   (->bool
 341    (string-contains
 342     (with-warnings
 343       (let ((pkg (package
 344                    (inherit (dummy-package "x"))
 345                    (home-page #f))))
 346         (check-home-page pkg)))
 347     "invalid")))
 348
 349 (test-assert "home-page: invalid URI"
 350   (->bool
 351    (string-contains
 352     (with-warnings
 353       (let ((pkg (package
 354                    (inherit (dummy-package "x"))
 355                    (home-page "foobar"))))
 356         (check-home-page pkg)))
 357     "invalid home page URL")))
 358
 359 (test-assert "home-page: host not found"
 360   (->bool
 361    (string-contains
 362     (with-warnings
 363       (let ((pkg (package
 364                    (inherit (dummy-package "x"))
 365                    (home-page "http://does-not-exist"))))
 366         (check-home-page pkg)))
 367     "domain not found")))
 368
 369 (test-skip (if %http-server-socket 0 1))
 370 (test-assert "home-page: Connection refused"
 371   (->bool
 372    (string-contains
 373     (with-warnings
 374       (let ((pkg (package
 375                    (inherit (dummy-package "x"))
 376                    (home-page %local-url))))
 377         (check-home-page pkg)))
 378     "Connection refused")))
 379
 380 (test-skip (if %http-server-socket 0 1))
 381 (test-equal "home-page: 200"
 382   ""
 383   (with-warnings
 384    (with-http-server 200
 385      (let ((pkg (package
 386                   (inherit (dummy-package "x"))
 387                   (home-page %local-url))))
 388        (check-home-page pkg)))))
 389
 390 (test-skip (if %http-server-socket 0 1))
 391 (test-assert "home-page: 404"
 392   (->bool
 393    (string-contains
 394     (with-warnings
 395       (with-http-server 404
 396         (let ((pkg (package
 397                      (inherit (dummy-package "x"))
 398                      (home-page %local-url))))
 399           (check-home-page pkg))))
 400     "not reachable: 404")))
 401
 402 (test-assert "source-file-name"
 403   (->bool
 404    (string-contains
 405     (with-warnings
 406       (let ((pkg (dummy-package "x"
 407                    (version "3.2.1")
 408                    (source
 409                     (origin
 410                       (method url-fetch)
 411                       (uri "http://www.example.com/3.2.1.tar.gz")
 412                       (sha256 %null-sha256))))))
 413         (check-source-file-name pkg)))
 414     "file name should contain the package name")))
 415
 416 (test-assert "source-file-name: v prefix"
 417   (->bool
 418    (string-contains
 419     (with-warnings
 420       (let ((pkg (dummy-package "x"
 421                    (version "3.2.1")
 422                    (source
 423                     (origin
 424                       (method url-fetch)
 425                       (uri "http://www.example.com/v3.2.1.tar.gz")
 426                       (sha256 %null-sha256))))))
 427         (check-source-file-name pkg)))
 428     "file name should contain the package name")))
 429
 430 (test-assert "source-file-name: bad checkout"
 431   (->bool
 432    (string-contains
 433     (with-warnings
 434       (let ((pkg (dummy-package "x"
 435                    (version "3.2.1")
 436                    (source
 437                     (origin
 438                       (method git-fetch)
 439                       (uri (git-reference
 440                             (url "http://www.example.com/x.git")
 441                             (commit "0")))
 442                       (sha256 %null-sha256))))))
 443         (check-source-file-name pkg)))
 444     "file name should contain the package name")))
 445
 446 (test-assert "source-file-name: good checkout"
 447   (not
 448    (->bool
 449     (string-contains
 450      (with-warnings
 451        (let ((pkg (dummy-package "x"
 452                     (version "3.2.1")
 453                     (source
 454                      (origin
 455                        (method git-fetch)
 456                        (uri (git-reference
 457                              (url "http://git.example.com/x.git")
 458                              (commit "0")))
 459                        (file-name (string-append "x-" version))
 460                        (sha256 %null-sha256))))))
 461          (check-source-file-name pkg)))
 462      "file name should contain the package name"))))
 463
 464 (test-assert "source-file-name: valid"
 465   (not
 466    (->bool
 467     (string-contains
 468      (with-warnings
 469        (let ((pkg (dummy-package "x"
 470                     (version "3.2.1")
 471                     (source
 472                      (origin
 473                        (method url-fetch)
 474                        (uri "http://www.example.com/x-3.2.1.tar.gz")
 475                        (sha256 %null-sha256))))))
 476          (check-source-file-name pkg)))
 477      "file name should contain the package name"))))
 478
 479 (test-skip (if %http-server-socket 0 1))
 480 (test-equal "source: 200"
 481   ""
 482   (with-warnings
 483    (with-http-server 200
 484      (let ((pkg (package
 485                   (inherit (dummy-package "x"))
 486                   (source (origin
 487                             (method url-fetch)
 488                             (uri %local-url)
 489                             (sha256 %null-sha256))))))
 490        (check-source pkg)))))
 491
 492 (test-skip (if %http-server-socket 0 1))
 493 (test-assert "source: 404"
 494   (->bool
 495    (string-contains
 496     (with-warnings
 497       (with-http-server 404
 498         (let ((pkg (package
 499                      (inherit (dummy-package "x"))
 500                      (source (origin
 501                                (method url-fetch)
 502                                (uri %local-url)
 503                                (sha256 %null-sha256))))))
 504           (check-source pkg))))
 505     "not reachable: 404")))
 506
 507 (test-assert "formatting: tabulation"
 508   (string-contains
 509    (with-warnings
 510      (check-formatting (dummy-package "leave the tab here:      ")))
 511    "tabulation"))
 512
 513 (test-assert "formatting: trailing white space"
 514   (string-contains
 515    (with-warnings
 516      ;; Leave the trailing white space on the next line!
 517      (check-formatting (dummy-package "x")))
 518    "trailing white space"))
 519
 520 (test-assert "formatting: long line"
 521   (string-contains
 522    (with-warnings
 523      (check-formatting
 524       (dummy-package "x"                          ;here is a stupid comment just to make a long line
 525                      )))
 526    "too long"))
 527
 528 (test-assert "formatting: alright"
 529   (string-null?
 530    (with-warnings
 531      (check-formatting (dummy-package "x")))))
 532
 533 (test-end "lint")
 534
 535 \f
 536 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 537
 538 ;; Local Variables:
 539 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
 540 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 541 ;; End: