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
  22 (define-module (test-packages)
  23   #:use-module (guix tests)
  24   #:use-module (guix 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-patches pkg)))
 306      "file names of patches should start with the package name")))
 307
 308 (test-assert "home-page: wrong home-page"
 309   (->bool
 310    (string-contains
 311     (with-warnings
 312       (let ((pkg (package
 313                    (inherit (dummy-package "x"))
 314                    (home-page #f))))
 315         (check-home-page pkg)))
 316     "invalid")))
 317
 318 (test-assert "home-page: invalid URI"
 319   (->bool
 320    (string-contains
 321     (with-warnings
 322       (let ((pkg (package
 323                    (inherit (dummy-package "x"))
 324                    (home-page "foobar"))))
 325         (check-home-page pkg)))
 326     "invalid home page URL")))
 327
 328 (test-assert "home-page: host not found"
 329   (->bool
 330    (string-contains
 331     (with-warnings
 332       (let ((pkg (package
 333                    (inherit (dummy-package "x"))
 334                    (home-page "http://does-not-exist"))))
 335         (check-home-page pkg)))
 336     "domain not found")))
 337
 338 (test-skip (if %http-server-socket 0 1))
 339 (test-assert "home-page: Connection refused"
 340   (->bool
 341    (string-contains
 342     (with-warnings
 343       (let ((pkg (package
 344                    (inherit (dummy-package "x"))
 345                    (home-page %local-url))))
 346         (check-home-page pkg)))
 347     "Connection refused")))
 348
 349 (test-skip (if %http-server-socket 0 1))
 350 (test-equal "home-page: 200"
 351   ""
 352   (with-warnings
 353    (with-http-server 200
 354      (let ((pkg (package
 355                   (inherit (dummy-package "x"))
 356                   (home-page %local-url))))
 357        (check-home-page pkg)))))
 358
 359 (test-skip (if %http-server-socket 0 1))
 360 (test-assert "home-page: 404"
 361   (->bool
 362    (string-contains
 363     (with-warnings
 364       (with-http-server 404
 365         (let ((pkg (package
 366                      (inherit (dummy-package "x"))
 367                      (home-page %local-url))))
 368           (check-home-page pkg))))
 369     "not reachable: 404")))
 370
 371 (test-skip (if %http-server-socket 0 1))
 372 (test-equal "source: 200"
 373   ""
 374   (with-warnings
 375    (with-http-server 200
 376      (let ((pkg (package
 377                   (inherit (dummy-package "x"))
 378                   (source (origin
 379                             (method url-fetch)
 380                             (uri %local-url)
 381                             (sha256 %null-sha256))))))
 382        (check-source pkg)))))
 383
 384 (test-skip (if %http-server-socket 0 1))
 385 (test-assert "source: 404"
 386   (->bool
 387    (string-contains
 388     (with-warnings
 389       (with-http-server 404
 390         (let ((pkg (package
 391                      (inherit (dummy-package "x"))
 392                      (source (origin
 393                                (method url-fetch)
 394                                (uri %local-url)
 395                                (sha256 %null-sha256))))))
 396           (check-source pkg))))
 397     "not reachable: 404")))
 398
 399 (test-end "lint")
 400
 401 \f
 402 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 403
 404 ;; Local Variables:
 405 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
 406 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 407 ;; End: