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>
6 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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))
40 (define %http-server-port
41 ;; TCP port to use for the stub HTTP server.
45 ;; URL to use for 'home-page' tests.
46 (string-append "http://localhost:" (number->string %http-server-port)
49 (define %http-server-socket
50 ;; Socket used by the Web server.
53 (let ((sock (socket PF_INET SOCK_STREAM 0)))
54 (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
56 (make-socket-address AF_INET INADDR_LOOPBACK
60 (let ((err (system-error-errno args)))
61 (format (current-error-port)
62 "warning: cannot run Web server for tests: ~a~%"
66 (define (http-write server client response body)
68 (let* ((response (write-response response client))
69 (port (response-port response)))
73 (write-response-body response body)))
75 (quit #t) ;exit the server thread
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))
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)
89 (define-server-impl stub-http-server
90 ;; Stripped-down version of Guile's built-in HTTP server.
92 (@@ (web server http) http-read)
94 (@@ (web server http) http-close))
96 (define (call-with-http-server code thunk)
97 "Call THUNK with an HTTP server running and returning CODE on HTTP
100 (define (handle request body)
101 (values (build-response #:code code
102 #:reason-phrase "Such is life")
107 (run-server handle stub-http-server
108 `(#:socket ,%http-server-socket)))
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.
117 (define-syntax-rule (with-http-server code body ...)
118 (call-with-http-server code (lambda () body ...)))
123 (define (call-with-warnings thunk)
124 (let ((port (open-output-string)))
125 (parameterize ((guix-warning-port port))
127 (get-output-string port)))
129 (define-syntax-rule (with-warnings body ...)
130 (call-with-warnings (lambda () body ...)))
132 (test-assert "description: not empty"
134 (string-contains (with-warnings
135 (let ((pkg (dummy-package "x"
137 (check-description-style pkg)))
138 "description should not be empty")))
140 (test-assert "description: does not start with an upper-case letter"
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")))
148 (test-assert "description: may start with a digit"
151 (let ((pkg (dummy-package "x"
152 (description "2-component library."))))
153 (check-description-style pkg)))))
155 (test-assert "description: may start with lower-case package name"
158 (let ((pkg (dummy-package "x"
159 (description "x is a dummy package."))))
160 (check-description-style pkg)))))
162 (test-assert "description: two spaces after end of sentence"
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")))
170 (test-assert "description: end-of-sentence detection with abbreviations"
173 (let ((pkg (dummy-package "x"
175 "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
176 (check-description-style pkg)))))
178 (test-assert "synopsis: not empty"
180 (string-contains (with-warnings
181 (let ((pkg (dummy-package "x"
183 (check-synopsis-style pkg)))
184 "synopsis should not be empty")))
186 (test-assert "synopsis: does not start with an upper-case letter"
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")))
194 (test-assert "synopsis: may start with a digit"
197 (let ((pkg (dummy-package "x"
198 (synopsis "5-dimensional frobnicator"))))
199 (check-synopsis-style pkg)))))
201 (test-assert "synopsis: ends with a period"
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")))
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)))))
215 (test-assert "synopsis: starts with 'A'"
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")))
223 (test-assert "synopsis: starts with 'An'"
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")))
231 (test-assert "synopsis: starts with 'a'"
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")))
239 (test-assert "synopsis: starts with 'an'"
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")))
247 (test-assert "synopsis: too long"
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")))
255 (test-assert "synopsis: start with package name"
257 (string-contains (with-warnings
258 (let ((pkg (dummy-package "x"
260 (synopsis "foo, a nice package"))))
261 (check-synopsis-style pkg)))
262 "synopsis should not start with the package name")))
264 (test-assert "synopsis: start with package name prefix"
267 (let ((pkg (dummy-package "arb"
268 (synopsis "Arbitrary precision"))))
269 (check-synopsis-style pkg)))))
271 (test-assert "synopsis: start with abbreviation"
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)))))
280 (test-assert "inputs: pkg-config is probably a native input"
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")))
289 (test-assert "patches: file names"
293 (let ((pkg (dummy-package "x"
299 (patches (list "/path/to/y.patch")))))))
300 (check-patches pkg)))
301 "file names of patches should start with the package name")))
303 (test-assert "home-page: wrong home-page"
308 (inherit (dummy-package "x"))
310 (check-home-page pkg)))
313 (test-assert "home-page: invalid URI"
318 (inherit (dummy-package "x"))
319 (home-page "foobar"))))
320 (check-home-page pkg)))
321 "invalid home page URL")))
323 (test-assert "home-page: host not found"
328 (inherit (dummy-package "x"))
329 (home-page "http://does-not-exist"))))
330 (check-home-page pkg)))
331 "domain not found")))
333 (test-skip (if %http-server-socket 0 1))
334 (test-assert "home-page: Connection refused"
339 (inherit (dummy-package "x"))
340 (home-page %local-url))))
341 (check-home-page pkg)))
342 "Connection refused")))
344 (test-skip (if %http-server-socket 0 1))
345 (test-equal "home-page: 200"
348 (with-http-server 200
350 (inherit (dummy-package "x"))
351 (home-page %local-url))))
352 (check-home-page pkg)))))
354 (test-skip (if %http-server-socket 0 1))
355 (test-assert "home-page: 404"
359 (with-http-server 404
361 (inherit (dummy-package "x"))
362 (home-page %local-url))))
363 (check-home-page pkg))))
364 "not reachable: 404")))
369 (exit (= (test-runner-fail-count (test-runner-current)) 0))
372 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
373 ;; eval: (put 'with-warnings 'scheme-indent-function 0)