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