tests/lint.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
   3 ;;; Copyright © 2014 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 build-system gnu)
  25   #:use-module (guix packages)
  26   #:use-module (guix scripts lint)
  27   #:use-module (guix ui)
  28   #:use-module (gnu packages)
  29   #:use-module (gnu packages pkg-config)
  30   #:use-module (web server)
  31   #:use-module (web server http)
  32   #:use-module (web response)
  33   #:use-module (ice-9 threads)
  34   #:use-module (srfi srfi-9 gnu)
  35   #:use-module (srfi srfi-64))
  36
  37 ;; Test the linter.
  38
  39 (define %http-server-port
  40   ;; TCP port to use for the stub HTTP server.
  41   9999)
  42
  43 (define %local-url
  44   ;; URL to use for 'home-page' tests.
  45   (string-append "http://localhost:" (number->string %http-server-port)
  46                  "/foo/bar"))
  47
  48 (define %null-sha256
  49   ;; SHA256 of the empty string.
  50   (base32
  51    "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
  52
  53 (define %http-server-socket
  54   ;; Socket used by the Web server.
  55   (catch 'system-error
  56     (lambda ()
  57       (let ((sock (socket PF_INET SOCK_STREAM 0)))
  58         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  59         (bind sock
  60               (make-socket-address AF_INET INADDR_LOOPBACK
  61                                    %http-server-port))
  62         sock))
  63     (lambda args
  64       (let ((err (system-error-errno args)))
  65         (format (current-error-port)
  66                 "warning: cannot run Web server for tests: ~a~%"
  67                 (strerror err))
  68         #f))))
  69
  70 (define (http-write server client response body)
  71   "Write RESPONSE."
  72   (let* ((response (write-response response client))
  73          (port     (response-port response)))
  74     (cond
  75      ((not body))                                 ;pass
  76      (else
  77       (write-response-body response body)))
  78     (close-port port)
  79     (quit #t)                                     ;exit the server thread
  80     (values)))
  81
  82 ;; Mutex and condition variable to synchronize with the HTTP server.
  83 (define %http-server-lock (make-mutex))
  84 (define %http-server-ready (make-condition-variable))
  85
  86 (define (http-open . args)
  87   "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
  88   (with-mutex %http-server-lock
  89     (let ((result (apply (@@ (web server http) http-open) args)))
  90       (signal-condition-variable %http-server-ready)
  91       result)))
  92
  93 (define-server-impl stub-http-server
  94   ;; Stripped-down version of Guile's built-in HTTP server.
  95   http-open
  96   (@@ (web server http) http-read)
  97   http-write
  98   (@@ (web server http) http-close))
  99
 100 (define (call-with-http-server code thunk)
 101   "Call THUNK with an HTTP server running and returning CODE on HTTP
 102 requests."
 103   (define (server-body)
 104     (define (handle request body)
 105       (values (build-response #:code code
 106                               #:reason-phrase "Such is life")
 107               "Hello, world."))
 108
 109     (catch 'quit
 110       (lambda ()
 111         (run-server handle stub-http-server
 112                     `(#:socket ,%http-server-socket)))
 113       (const #t)))
 114
 115   (with-mutex %http-server-lock
 116     (let ((server (make-thread server-body)))
 117       (wait-condition-variable %http-server-ready %http-server-lock)
 118       ;; Normally SERVER exits automatically once it has received a request.
 119       (thunk))))
 120
 121 (define-syntax-rule (with-http-server code body ...)
 122   (call-with-http-server code (lambda () body ...)))
 123
 124 \f
 125 (test-begin "lint")
 126
 127 (define (call-with-warnings thunk)
 128   (let ((port (open-output-string)))
 129     (parameterize ((guix-warning-port port))
 130       (thunk))
 131     (get-output-string port)))
 132
 133 (define-syntax-rule (with-warnings body ...)
 134   (call-with-warnings (lambda () body ...)))
 135
 136 (test-assert "description: not empty"
 137   (->bool
 138    (string-contains (with-warnings
 139                       (let ((pkg (dummy-package "x"
 140                                    (description ""))))
 141                         (check-description-style pkg)))
 142                     "description should not be empty")))
 143
 144 (test-assert "description: does not start with an upper-case letter"
 145   (->bool
 146    (string-contains (with-warnings
 147                       (let ((pkg (dummy-package "x"
 148                                    (description "bad description."))))
 149                         (check-description-style pkg)))
 150                     "description should start with an upper-case letter")))
 151
 152 (test-assert "description: may start with a digit"
 153   (string-null?
 154    (with-warnings
 155      (let ((pkg (dummy-package "x"
 156                   (description "2-component library."))))
 157        (check-description-style pkg)))))
 158
 159 (test-assert "description: may start with lower-case package name"
 160   (string-null?
 161    (with-warnings
 162      (let ((pkg (dummy-package "x"
 163                   (description "x is a dummy package."))))
 164        (check-description-style pkg)))))
 165
 166 (test-assert "description: two spaces after end of sentence"
 167   (->bool
 168    (string-contains (with-warnings
 169                       (let ((pkg (dummy-package "x"
 170                                    (description "Bad. Quite bad."))))
 171                         (check-description-style pkg)))
 172                     "sentences in description should be followed by two spaces")))
 173
 174 (test-assert "description: end-of-sentence detection with abbreviations"
 175   (string-null?
 176    (with-warnings
 177      (let ((pkg (dummy-package "x"
 178                   (description
 179                    "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
 180        (check-description-style pkg)))))
 181
 182 (test-assert "synopsis: not empty"
 183   (->bool
 184    (string-contains (with-warnings
 185                       (let ((pkg (dummy-package "x"
 186                                    (synopsis ""))))
 187                         (check-synopsis-style pkg)))
 188                     "synopsis should not be empty")))
 189
 190 (test-assert "synopsis: does not start with an upper-case letter"
 191   (->bool
 192    (string-contains (with-warnings
 193                       (let ((pkg (dummy-package "x"
 194                                    (synopsis "bad synopsis."))))
 195                         (check-synopsis-style pkg)))
 196                     "synopsis should start with an upper-case letter")))
 197
 198 (test-assert "synopsis: may start with a digit"
 199   (string-null?
 200    (with-warnings
 201      (let ((pkg (dummy-package "x"
 202                   (synopsis "5-dimensional frobnicator"))))
 203        (check-synopsis-style pkg)))))
 204
 205 (test-assert "synopsis: ends with a period"
 206   (->bool
 207    (string-contains (with-warnings
 208                       (let ((pkg (dummy-package "x"
 209                                    (synopsis "Bad synopsis."))))
 210                         (check-synopsis-style pkg)))
 211                     "no period allowed at the end of the synopsis")))
 212
 213 (test-assert "synopsis: ends with 'etc.'"
 214   (string-null? (with-warnings
 215                   (let ((pkg (dummy-package "x"
 216                                (synopsis "Foo, bar, etc."))))
 217                     (check-synopsis-style pkg)))))
 218
 219 (test-assert "synopsis: starts with 'A'"
 220   (->bool
 221    (string-contains (with-warnings
 222                       (let ((pkg (dummy-package "x"
 223                                    (synopsis "A bad synopŝis"))))
 224                         (check-synopsis-style pkg)))
 225                     "no article allowed at the beginning of the synopsis")))
 226
 227 (test-assert "synopsis: starts with 'An'"
 228   (->bool
 229    (string-contains (with-warnings
 230                       (let ((pkg (dummy-package "x"
 231                                    (synopsis "An awful synopsis"))))
 232                         (check-synopsis-style pkg)))
 233                     "no article allowed at the beginning of the synopsis")))
 234
 235 (test-assert "synopsis: starts with 'a'"
 236   (->bool
 237    (string-contains (with-warnings
 238                       (let ((pkg (dummy-package "x"
 239                                    (synopsis "a bad synopsis"))))
 240                         (check-synopsis-style pkg)))
 241                     "no article allowed at the beginning of the synopsis")))
 242
 243 (test-assert "synopsis: starts with 'an'"
 244   (->bool
 245    (string-contains (with-warnings
 246                       (let ((pkg (dummy-package "x"
 247                                    (synopsis "an awful synopsis"))))
 248                         (check-synopsis-style pkg)))
 249                     "no article allowed at the beginning of the synopsis")))
 250
 251 (test-assert "synopsis: too long"
 252   (->bool
 253    (string-contains (with-warnings
 254                       (let ((pkg (dummy-package "x"
 255                                    (synopsis (make-string 80 #\x)))))
 256                         (check-synopsis-style pkg)))
 257                     "synopsis should be less than 80 characters long")))
 258
 259 (test-assert "synopsis: start with package name"
 260   (->bool
 261    (string-contains (with-warnings
 262                       (let ((pkg (dummy-package "x"
 263                                    (name "foo")
 264                                    (synopsis "foo, a nice package"))))
 265                         (check-synopsis-style pkg)))
 266                     "synopsis should not start with the package name")))
 267
 268 (test-assert "synopsis: start with package name prefix"
 269   (string-null?
 270    (with-warnings
 271      (let ((pkg (dummy-package "arb"
 272                   (synopsis "Arbitrary precision"))))
 273        (check-synopsis-style pkg)))))
 274
 275 (test-assert "synopsis: start with abbreviation"
 276   (string-null?
 277    (with-warnings
 278      (let ((pkg (dummy-package "uucp"
 279                   ;; Same problem with "APL interpreter", etc.
 280                   (synopsis "UUCP implementation")
 281                   (description "Imagine this is Taylor UUCP."))))
 282        (check-synopsis-style pkg)))))
 283
 284 (test-assert "inputs: pkg-config is probably a native input"
 285   (->bool
 286    (string-contains
 287      (with-warnings
 288        (let ((pkg (dummy-package "x"
 289                     (inputs `(("pkg-config" ,pkg-config))))))
 290          (check-inputs-should-be-native pkg)))
 291          "pkg-config should probably be a native input")))
 292
 293 (test-assert "patches: file names"
 294   (->bool
 295    (string-contains
 296      (with-warnings
 297        (let ((pkg (dummy-package "x"
 298                     (source
 299                      (origin
 300                        (method url-fetch)
 301                        (uri "someurl")
 302                        (sha256 "somesha")
 303                        (patches (list "/path/to/y.patch")))))))
 304          (check-patch-file-names pkg)))
 305      "file names of patches should start with the package name")))
 306
 307 (test-assert "patches: not found"
 308   (->bool
 309    (string-contains
 310      (with-warnings
 311        (let ((pkg (dummy-package "x"
 312                     (source
 313                      (origin
 314                        (method url-fetch)
 315                        (uri "someurl")
 316                        (sha256 "somesha")
 317                        (patches
 318                         (list (search-patch "this-patch-does-not-exist!"))))))))
 319          (check-patch-file-names pkg)))
 320      "patch not found")))
 321
 322 (test-assert "derivation: invalid arguments"
 323   (->bool
 324    (string-contains
 325     (with-warnings
 326       (let ((pkg (dummy-package "x"
 327                    (arguments
 328                     '(#:imported-modules (invalid-module))))))
 329         (check-derivation pkg)))
 330     "failed to create derivation")))
 331
 332 (test-assert "home-page: wrong home-page"
 333   (->bool
 334    (string-contains
 335     (with-warnings
 336       (let ((pkg (package
 337                    (inherit (dummy-package "x"))
 338                    (home-page #f))))
 339         (check-home-page pkg)))
 340     "invalid")))
 341
 342 (test-assert "home-page: invalid URI"
 343   (->bool
 344    (string-contains
 345     (with-warnings
 346       (let ((pkg (package
 347                    (inherit (dummy-package "x"))
 348                    (home-page "foobar"))))
 349         (check-home-page pkg)))
 350     "invalid home page URL")))
 351
 352 (test-assert "home-page: host not found"
 353   (->bool
 354    (string-contains
 355     (with-warnings
 356       (let ((pkg (package
 357                    (inherit (dummy-package "x"))
 358                    (home-page "http://does-not-exist"))))
 359         (check-home-page pkg)))
 360     "domain not found")))
 361
 362 (test-skip (if %http-server-socket 0 1))
 363 (test-assert "home-page: Connection refused"
 364   (->bool
 365    (string-contains
 366     (with-warnings
 367       (let ((pkg (package
 368                    (inherit (dummy-package "x"))
 369                    (home-page %local-url))))
 370         (check-home-page pkg)))
 371     "Connection refused")))
 372
 373 (test-skip (if %http-server-socket 0 1))
 374 (test-equal "home-page: 200"
 375   ""
 376   (with-warnings
 377    (with-http-server 200
 378      (let ((pkg (package
 379                   (inherit (dummy-package "x"))
 380                   (home-page %local-url))))
 381        (check-home-page pkg)))))
 382
 383 (test-skip (if %http-server-socket 0 1))
 384 (test-assert "home-page: 404"
 385   (->bool
 386    (string-contains
 387     (with-warnings
 388       (with-http-server 404
 389         (let ((pkg (package
 390                      (inherit (dummy-package "x"))
 391                      (home-page %local-url))))
 392           (check-home-page pkg))))
 393     "not reachable: 404")))
 394
 395 (test-skip (if %http-server-socket 0 1))
 396 (test-equal "source: 200"
 397   ""
 398   (with-warnings
 399    (with-http-server 200
 400      (let ((pkg (package
 401                   (inherit (dummy-package "x"))
 402                   (source (origin
 403                             (method url-fetch)
 404                             (uri %local-url)
 405                             (sha256 %null-sha256))))))
 406        (check-source pkg)))))
 407
 408 (test-skip (if %http-server-socket 0 1))
 409 (test-assert "source: 404"
 410   (->bool
 411    (string-contains
 412     (with-warnings
 413       (with-http-server 404
 414         (let ((pkg (package
 415                      (inherit (dummy-package "x"))
 416                      (source (origin
 417                                (method url-fetch)
 418                                (uri %local-url)
 419                                (sha256 %null-sha256))))))
 420           (check-source pkg))))
 421     "not reachable: 404")))
 422
 423 (test-end "lint")
 424
 425 \f
 426 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 427
 428 ;; Local Variables:
 429 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
 430 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 431 ;; End: