Merge branch 'master' into core-updates
[jackhill/guix/guix.git] / tests / lint.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
3 ;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
4 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
5 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
6 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
7 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
8 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
9 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
10 ;;;
11 ;;; This file is part of GNU Guix.
12 ;;;
13 ;;; GNU Guix is free software; you can redistribute it and/or modify it
14 ;;; under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 3 of the License, or (at
16 ;;; your option) any later version.
17 ;;;
18 ;;; GNU Guix is distributed in the hope that it will be useful, but
19 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
25
26 ;; Avoid interference.
27 (unsetenv "http_proxy")
28
29 (define-module (test-lint)
30 #:use-module (guix tests)
31 #:use-module (guix tests http)
32 #:use-module (guix download)
33 #:use-module (guix git-download)
34 #:use-module (guix build-system gnu)
35 #:use-module (guix packages)
36 #:use-module (guix lint)
37 #:use-module (guix ui)
38 #:use-module (gnu packages)
39 #:use-module (gnu packages glib)
40 #:use-module (gnu packages pkg-config)
41 #:use-module (gnu packages python-xyz)
42 #:use-module (web uri)
43 #:use-module (web server)
44 #:use-module (web server http)
45 #:use-module (web response)
46 #:use-module (ice-9 match)
47 #:use-module (ice-9 regex)
48 #:use-module (ice-9 getopt-long)
49 #:use-module (ice-9 pretty-print)
50 #:use-module (srfi srfi-1)
51 #:use-module (srfi srfi-9 gnu)
52 #:use-module (srfi srfi-26)
53 #:use-module (srfi srfi-64))
54
55 ;; Test the linter.
56
57 ;; Avoid collisions with other tests.
58 (%http-server-port 9999)
59
60 (define %null-sha256
61 ;; SHA256 of the empty string.
62 (base32
63 "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
64
65 (define %long-string
66 (make-string 2000 #\a))
67
68 (define (string-match-or-error pattern str)
69 (or (string-match pattern str)
70 (error str "did not match" pattern)))
71
72 (define single-lint-warning-message
73 (match-lambda
74 (((and (? lint-warning?) warning))
75 (lint-warning-message warning))))
76
77 (define (warning-contains? str warnings)
78 "Return true if WARNINGS is a singleton with a warning that contains STR."
79 (match warnings
80 (((? lint-warning? warning))
81 (string-contains (lint-warning-message warning) str))))
82
83 \f
84 (test-begin "lint")
85
86 (test-equal "description: not a string"
87 "invalid description: foobar"
88 (single-lint-warning-message
89 (check-description-style
90 (dummy-package "x" (description 'foobar)))))
91
92 (test-equal "description: not empty"
93 "description should not be empty"
94 (single-lint-warning-message
95 (check-description-style
96 (dummy-package "x" (description "")))))
97
98 (test-equal "description: invalid Texinfo markup"
99 "Texinfo markup in description is invalid"
100 (single-lint-warning-message
101 (check-description-style
102 (dummy-package "x" (description "f{oo}b@r")))))
103
104 (test-equal "description: does not start with an upper-case letter"
105 "description should start with an upper-case letter or digit"
106 (single-lint-warning-message
107 (let ((pkg (dummy-package "x"
108 (description "bad description."))))
109 (check-description-style pkg))))
110
111 (test-equal "description: may start with a digit"
112 '()
113 (let ((pkg (dummy-package "x"
114 (description "2-component library."))))
115 (check-description-style pkg)))
116
117 (test-equal "description: may start with lower-case package name"
118 '()
119 (let ((pkg (dummy-package "x"
120 (description "x is a dummy package."))))
121 (check-description-style pkg)))
122
123 (test-equal "description: two spaces after end of sentence"
124 "sentences in description should be followed by two spaces; possible infraction at 3"
125 (single-lint-warning-message
126 (let ((pkg (dummy-package "x"
127 (description "Bad. Quite bad."))))
128 (check-description-style pkg))))
129
130 (test-equal "description: end-of-sentence detection with abbreviations"
131 '()
132 (let ((pkg (dummy-package "x"
133 (description
134 "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
135 (check-description-style pkg)))
136
137 (test-equal "description: may not contain trademark signs: ™"
138 "description should not contain trademark sign '™' at 20"
139 (single-lint-warning-message
140 (let ((pkg (dummy-package "x"
141 (description "Does The Right Thing™"))))
142 (check-description-style pkg))))
143
144 (test-equal "description: may not contain trademark signs: ®"
145 "description should not contain trademark sign '®' at 17"
146 (single-lint-warning-message
147 (let ((pkg (dummy-package "x"
148 (description "Works with Format®"))))
149 (check-description-style pkg))))
150
151 (test-equal "description: suggest ornament instead of quotes"
152 "use @code or similar ornament instead of quotes"
153 (single-lint-warning-message
154 (let ((pkg (dummy-package "x"
155 (description "This is a 'quoted' thing."))))
156 (check-description-style pkg))))
157
158 (test-equal "synopsis: not a string"
159 "invalid synopsis: #f"
160 (single-lint-warning-message
161 (let ((pkg (dummy-package "x"
162 (synopsis #f))))
163 (check-synopsis-style pkg))))
164
165 (test-equal "synopsis: not empty"
166 "synopsis should not be empty"
167 (single-lint-warning-message
168 (let ((pkg (dummy-package "x"
169 (synopsis ""))))
170 (check-synopsis-style pkg))))
171
172 (test-equal "synopsis: valid Texinfo markup"
173 "Texinfo markup in synopsis is invalid"
174 (single-lint-warning-message
175 (check-synopsis-style
176 (dummy-package "x" (synopsis "Bad $@ texinfo")))))
177
178 (test-equal "synopsis: does not start with an upper-case letter"
179 "synopsis should start with an upper-case letter or digit"
180 (single-lint-warning-message
181 (let ((pkg (dummy-package "x"
182 (synopsis "bad synopsis"))))
183 (check-synopsis-style pkg))))
184
185 (test-equal "synopsis: may start with a digit"
186 '()
187 (let ((pkg (dummy-package "x"
188 (synopsis "5-dimensional frobnicator"))))
189 (check-synopsis-style pkg)))
190
191 (test-equal "synopsis: ends with a period"
192 "no period allowed at the end of the synopsis"
193 (single-lint-warning-message
194 (let ((pkg (dummy-package "x"
195 (synopsis "Bad synopsis."))))
196 (check-synopsis-style pkg))))
197
198 (test-equal "synopsis: ends with 'etc.'"
199 '()
200 (let ((pkg (dummy-package "x"
201 (synopsis "Foo, bar, etc."))))
202 (check-synopsis-style pkg)))
203
204 (test-equal "synopsis: starts with 'A'"
205 "no article allowed at the beginning of the synopsis"
206 (single-lint-warning-message
207 (let ((pkg (dummy-package "x"
208 (synopsis "A bad synopŝis"))))
209 (check-synopsis-style pkg))))
210
211 (test-equal "synopsis: starts with 'An'"
212 "no article allowed at the beginning of the synopsis"
213 (single-lint-warning-message
214 (let ((pkg (dummy-package "x"
215 (synopsis "An awful synopsis"))))
216 (check-synopsis-style pkg))))
217
218 (test-equal "synopsis: starts with 'a'"
219 '("no article allowed at the beginning of the synopsis"
220 "synopsis should start with an upper-case letter or digit")
221 (sort
222 (map
223 lint-warning-message
224 (let ((pkg (dummy-package "x"
225 (synopsis "a bad synopsis"))))
226 (check-synopsis-style pkg)))
227 string<?))
228
229 (test-equal "synopsis: starts with 'an'"
230 '("no article allowed at the beginning of the synopsis"
231 "synopsis should start with an upper-case letter or digit")
232 (sort
233 (map
234 lint-warning-message
235 (let ((pkg (dummy-package "x"
236 (synopsis "an awful synopsis"))))
237 (check-synopsis-style pkg)))
238 string<?))
239
240 (test-equal "synopsis: too long"
241 "synopsis should be less than 80 characters long"
242 (single-lint-warning-message
243 (let ((pkg (dummy-package "x"
244 (synopsis (make-string 80 #\X)))))
245 (check-synopsis-style pkg))))
246
247 (test-equal "synopsis: start with package name"
248 "synopsis should not start with the package name"
249 (single-lint-warning-message
250 (let ((pkg (dummy-package "x"
251 (name "Foo")
252 (synopsis "Foo, a nice package"))))
253 (check-synopsis-style pkg))))
254
255 (test-equal "synopsis: start with package name prefix"
256 '()
257 (let ((pkg (dummy-package "arb"
258 (synopsis "Arbitrary precision"))))
259 (check-synopsis-style pkg)))
260
261 (test-equal "synopsis: start with abbreviation"
262 '()
263 (let ((pkg (dummy-package "uucp"
264 ;; Same problem with "APL interpreter", etc.
265 (synopsis "UUCP implementation")
266 (description "Imagine this is Taylor UUCP."))))
267 (check-synopsis-style pkg)))
268
269 (test-equal "inputs: pkg-config is probably a native input"
270 "'pkg-config' should probably be a native input"
271 (single-lint-warning-message
272 (let ((pkg (dummy-package "x"
273 (inputs `(("pkg-config" ,pkg-config))))))
274 (check-inputs-should-be-native pkg))))
275
276 (test-equal "inputs: glib:bin is probably a native input"
277 "'glib:bin' should probably be a native input"
278 (single-lint-warning-message
279 (let ((pkg (dummy-package "x"
280 (inputs `(("glib" ,glib "bin"))))))
281 (check-inputs-should-be-native pkg))))
282
283 (test-equal
284 "inputs: python-setuptools should not be an input at all (input)"
285 "'python-setuptools' should probably not be an input at all"
286 (single-lint-warning-message
287 (let ((pkg (dummy-package "x"
288 (inputs `(("python-setuptools"
289 ,python-setuptools))))))
290 (check-inputs-should-not-be-an-input-at-all pkg))))
291
292 (test-equal
293 "inputs: python-setuptools should not be an input at all (native-input)"
294 "'python-setuptools' should probably not be an input at all"
295 (single-lint-warning-message
296 (let ((pkg (dummy-package "x"
297 (native-inputs
298 `(("python-setuptools"
299 ,python-setuptools))))))
300 (check-inputs-should-not-be-an-input-at-all pkg))))
301
302 (test-equal
303 "inputs: python-setuptools should not be an input at all (propagated-input)"
304 "'python-setuptools' should probably not be an input at all"
305 (single-lint-warning-message
306 (let ((pkg (dummy-package "x"
307 (propagated-inputs
308 `(("python-setuptools" ,python-setuptools))))))
309 (check-inputs-should-not-be-an-input-at-all pkg))))
310
311 (test-equal "patches: file names"
312 "file names of patches should start with the package name"
313 (single-lint-warning-message
314 (let ((pkg (dummy-package "x"
315 (source
316 (dummy-origin
317 (patches (list "/path/to/y.patch")))))))
318 (check-patch-file-names pkg))))
319
320 (test-equal "patches: file name too long"
321 (string-append "x-"
322 (make-string 100 #\a)
323 ".patch: file name is too long")
324 (single-lint-warning-message
325 (let ((pkg (dummy-package
326 "x"
327 (source
328 (dummy-origin
329 (patches (list (string-append "x-"
330 (make-string 100 #\a)
331 ".patch"))))))))
332 (check-patch-file-names pkg))))
333
334 (test-equal "patches: not found"
335 "this-patch-does-not-exist!: patch not found"
336 (single-lint-warning-message
337 (let ((pkg (dummy-package
338 "x"
339 (source
340 (dummy-origin
341 (patches
342 (list (search-patch "this-patch-does-not-exist!"))))))))
343 (check-patch-file-names pkg))))
344
345 (test-equal "derivation: invalid arguments"
346 "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())"
347 (match (let ((pkg (dummy-package "x"
348 (arguments
349 '(#:imported-modules (invalid-module))))))
350 (check-derivation pkg))
351 (((and (? lint-warning?) first-warning) others ...)
352 (lint-warning-message first-warning))))
353
354 (test-equal "license: invalid license"
355 "invalid license field"
356 (single-lint-warning-message
357 (check-license (dummy-package "x" (license #f)))))
358
359 (test-equal "home-page: wrong home-page"
360 "invalid value for home page"
361 (let ((pkg (package
362 (inherit (dummy-package "x"))
363 (home-page #f))))
364 (single-lint-warning-message
365 (check-home-page pkg))))
366
367 (test-equal "home-page: invalid URI"
368 "invalid home page URL: \"foobar\""
369 (let ((pkg (package
370 (inherit (dummy-package "x"))
371 (home-page "foobar"))))
372 (single-lint-warning-message
373 (check-home-page pkg))))
374
375 (test-assert "home-page: host not found"
376 (let ((pkg (package
377 (inherit (dummy-package "x"))
378 (home-page "http://does-not-exist"))))
379 (warning-contains? "domain not found" (check-home-page pkg))))
380
381 (test-skip (if (http-server-can-listen?) 0 1))
382 (test-equal "home-page: Connection refused"
383 "URI http://localhost:9999/foo/bar unreachable: Connection refused"
384 (let ((pkg (package
385 (inherit (dummy-package "x"))
386 (home-page (%local-url)))))
387 (single-lint-warning-message
388 (check-home-page pkg))))
389
390 (test-skip (if (http-server-can-listen?) 0 1))
391 (test-equal "home-page: 200"
392 '()
393 (with-http-server 200 %long-string
394 (let ((pkg (package
395 (inherit (dummy-package "x"))
396 (home-page (%local-url)))))
397 (check-home-page pkg))))
398
399 (test-skip (if (http-server-can-listen?) 0 1))
400 (test-equal "home-page: 200 but short length"
401 "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
402 (with-http-server 200 "This is too small."
403 (let ((pkg (package
404 (inherit (dummy-package "x"))
405 (home-page (%local-url)))))
406
407 (single-lint-warning-message
408 (check-home-page pkg)))))
409
410 (test-skip (if (http-server-can-listen?) 0 1))
411 (test-equal "home-page: 404"
412 "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
413 (with-http-server 404 %long-string
414 (let ((pkg (package
415 (inherit (dummy-package "x"))
416 (home-page (%local-url)))))
417 (single-lint-warning-message
418 (check-home-page pkg)))))
419
420 (test-skip (if (http-server-can-listen?) 0 1))
421 (test-equal "home-page: 301, invalid"
422 "invalid permanent redirect from http://localhost:9999/foo/bar"
423 (with-http-server 301 %long-string
424 (let ((pkg (package
425 (inherit (dummy-package "x"))
426 (home-page (%local-url)))))
427 (single-lint-warning-message
428 (check-home-page pkg)))))
429
430 (test-skip (if (http-server-can-listen?) 0 1))
431 (test-equal "home-page: 301 -> 200"
432 "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
433 (with-http-server 200 %long-string
434 (let ((initial-url (%local-url)))
435 (parameterize ((%http-server-port (+ 1 (%http-server-port))))
436 (with-http-server (301 `((location
437 . ,(string->uri initial-url))))
438 ""
439 (let ((pkg (package
440 (inherit (dummy-package "x"))
441 (home-page (%local-url)))))
442 (single-lint-warning-message
443 (check-home-page pkg))))))))
444
445 (test-skip (if (http-server-can-listen?) 0 1))
446 (test-equal "home-page: 301 -> 404"
447 "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
448 (with-http-server 404 "booh!"
449 (let ((initial-url (%local-url)))
450 (parameterize ((%http-server-port (+ 1 (%http-server-port))))
451 (with-http-server (301 `((location
452 . ,(string->uri initial-url))))
453 ""
454 (let ((pkg (package
455 (inherit (dummy-package "x"))
456 (home-page (%local-url)))))
457 (single-lint-warning-message
458 (check-home-page pkg))))))))
459
460
461 (test-equal "source-file-name"
462 "the source file name should contain the package name"
463 (let ((pkg (dummy-package "x"
464 (version "3.2.1")
465 (source
466 (origin
467 (method url-fetch)
468 (uri "http://www.example.com/3.2.1.tar.gz")
469 (sha256 %null-sha256))))))
470 (single-lint-warning-message
471 (check-source-file-name pkg))))
472
473 (test-equal "source-file-name: v prefix"
474 "the source file name should contain the package name"
475 (let ((pkg (dummy-package "x"
476 (version "3.2.1")
477 (source
478 (origin
479 (method url-fetch)
480 (uri "http://www.example.com/v3.2.1.tar.gz")
481 (sha256 %null-sha256))))))
482 (single-lint-warning-message
483 (check-source-file-name pkg))))
484
485 (test-equal "source-file-name: bad checkout"
486 "the source file name should contain the package name"
487 (let ((pkg (dummy-package "x"
488 (version "3.2.1")
489 (source
490 (origin
491 (method git-fetch)
492 (uri (git-reference
493 (url "http://www.example.com/x.git")
494 (commit "0")))
495 (sha256 %null-sha256))))))
496 (single-lint-warning-message
497 (check-source-file-name pkg))))
498
499 (test-equal "source-file-name: good checkout"
500 '()
501 (let ((pkg (dummy-package "x"
502 (version "3.2.1")
503 (source
504 (origin
505 (method git-fetch)
506 (uri (git-reference
507 (url "http://git.example.com/x.git")
508 (commit "0")))
509 (file-name (string-append "x-" version))
510 (sha256 %null-sha256))))))
511 (check-source-file-name pkg)))
512
513 (test-equal "source-file-name: valid"
514 '()
515 (let ((pkg (dummy-package "x"
516 (version "3.2.1")
517 (source
518 (origin
519 (method url-fetch)
520 (uri "http://www.example.com/x-3.2.1.tar.gz")
521 (sha256 %null-sha256))))))
522 (check-source-file-name pkg)))
523
524 (test-equal "source-unstable-tarball"
525 "the source URI should not be an autogenerated tarball"
526 (let ((pkg (dummy-package "x"
527 (source
528 (origin
529 (method url-fetch)
530 (uri "https://github.com/example/example/archive/v0.0.tar.gz")
531 (sha256 %null-sha256))))))
532 (single-lint-warning-message
533 (check-source-unstable-tarball pkg))))
534
535 (test-equal "source-unstable-tarball: source #f"
536 '()
537 (let ((pkg (dummy-package "x"
538 (source #f))))
539 (check-source-unstable-tarball pkg)))
540
541 (test-equal "source-unstable-tarball: valid"
542 '()
543 (let ((pkg (dummy-package "x"
544 (source
545 (origin
546 (method url-fetch)
547 (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
548 (sha256 %null-sha256))))))
549 (check-source-unstable-tarball pkg)))
550
551 (test-equal "source-unstable-tarball: package named archive"
552 '()
553 (let ((pkg (dummy-package "x"
554 (source
555 (origin
556 (method url-fetch)
557 (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
558 (sha256 %null-sha256))))))
559 (check-source-unstable-tarball pkg)))
560
561 (test-equal "source-unstable-tarball: not-github"
562 '()
563 (let ((pkg (dummy-package "x"
564 (source
565 (origin
566 (method url-fetch)
567 (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
568 (sha256 %null-sha256))))))
569 (check-source-unstable-tarball pkg)))
570
571 (test-equal "source-unstable-tarball: git-fetch"
572 '()
573 (let ((pkg (dummy-package "x"
574 (source
575 (origin
576 (method git-fetch)
577 (uri (git-reference
578 (url "https://github.com/archive/example.git")
579 (commit "0")))
580 (sha256 %null-sha256))))))
581 (check-source-unstable-tarball pkg)))
582
583 (test-skip (if (http-server-can-listen?) 0 1))
584 (test-equal "source: 200"
585 '()
586 (with-http-server 200 %long-string
587 (let ((pkg (package
588 (inherit (dummy-package "x"))
589 (source (origin
590 (method url-fetch)
591 (uri (%local-url))
592 (sha256 %null-sha256))))))
593 (check-source pkg))))
594
595 (test-skip (if (http-server-can-listen?) 0 1))
596 (test-equal "source: 200 but short length"
597 "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
598 (with-http-server 200 "This is too small."
599 (let ((pkg (package
600 (inherit (dummy-package "x"))
601 (source (origin
602 (method url-fetch)
603 (uri (%local-url))
604 (sha256 %null-sha256))))))
605 (match (check-source pkg)
606 ((first-warning ; All source URIs are unreachable
607 (and (? lint-warning?) second-warning))
608 (lint-warning-message second-warning))))))
609
610 (test-skip (if (http-server-can-listen?) 0 1))
611 (test-equal "source: 404"
612 "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
613 (with-http-server 404 %long-string
614 (let ((pkg (package
615 (inherit (dummy-package "x"))
616 (source (origin
617 (method url-fetch)
618 (uri (%local-url))
619 (sha256 %null-sha256))))))
620 (match (check-source pkg)
621 ((first-warning ; All source URIs are unreachable
622 (and (? lint-warning?) second-warning))
623 (lint-warning-message second-warning))))))
624
625 (test-skip (if (http-server-can-listen?) 0 1))
626 (test-equal "source: 404 and 200"
627 '()
628 (with-http-server 404 %long-string
629 (let ((bad-url (%local-url)))
630 (parameterize ((%http-server-port (+ 1 (%http-server-port))))
631 (with-http-server 200 %long-string
632 (let ((pkg (package
633 (inherit (dummy-package "x"))
634 (source (origin
635 (method url-fetch)
636 (uri (list bad-url (%local-url)))
637 (sha256 %null-sha256))))))
638 ;; Since one of the two URLs is good, this should return the empty
639 ;; list.
640 (check-source pkg)))))))
641
642 (test-skip (if (http-server-can-listen?) 0 1))
643 (test-equal "source: 301 -> 200"
644 "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
645 (with-http-server 200 %long-string
646 (let ((initial-url (%local-url)))
647 (parameterize ((%http-server-port (+ 1 (%http-server-port))))
648 (with-http-server (301 `((location . ,(string->uri initial-url))))
649 ""
650 (let ((pkg (package
651 (inherit (dummy-package "x"))
652 (source (origin
653 (method url-fetch)
654 (uri (%local-url))
655 (sha256 %null-sha256))))))
656 (match (check-source pkg)
657 ((first-warning ; All source URIs are unreachable
658 (and (? lint-warning?) second-warning))
659 (lint-warning-message second-warning)))))))))
660
661 (test-skip (if (http-server-can-listen?) 0 1))
662 (test-equal "source: 301 -> 404"
663 "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
664 (with-http-server 404 "booh!"
665 (let ((initial-url (%local-url)))
666 (parameterize ((%http-server-port (+ 1 (%http-server-port))))
667 (with-http-server (301 `((location . ,(string->uri initial-url))))
668 ""
669 (let ((pkg (package
670 (inherit (dummy-package "x"))
671 (source (origin
672 (method url-fetch)
673 (uri (%local-url))
674 (sha256 %null-sha256))))))
675 (match (check-source pkg)
676 ((first-warning ; The first warning says that all URI's are
677 ; unreachable
678 (and (? lint-warning?) second-warning))
679 (lint-warning-message second-warning)))))))))
680
681 (test-equal "mirror-url"
682 '()
683 (let ((source (origin
684 (method url-fetch)
685 (uri "http://example.org/foo/bar.tar.gz")
686 (sha256 %null-sha256))))
687 (check-mirror-url (dummy-package "x" (source source)))))
688
689 (test-equal "mirror-url: one suggestion"
690 "URL should be 'mirror://gnu/foo/foo.tar.gz'"
691 (let ((source (origin
692 (method url-fetch)
693 (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
694 (sha256 %null-sha256))))
695 (single-lint-warning-message
696 (check-mirror-url (dummy-package "x" (source source))))))
697
698 (test-equal "github-url"
699 '()
700 (with-http-server 200 %long-string
701 (check-github-url
702 (dummy-package "x" (source
703 (origin
704 (method url-fetch)
705 (uri (%local-url))
706 (sha256 %null-sha256)))))))
707
708 (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
709 (test-equal "github-url: one suggestion"
710 (string-append
711 "URL should be '" github-url "'")
712 (with-http-server (301 `((location . ,(string->uri github-url)))) ""
713 (let ((initial-uri (%local-url)))
714 (parameterize ((%http-server-port (+ 1 (%http-server-port))))
715 (with-http-server (302 `((location . ,(string->uri initial-uri)))) ""
716 (single-lint-warning-message
717 (check-github-url
718 (dummy-package "x" (source
719 (origin
720 (method url-fetch)
721 (uri (%local-url))
722 (sha256 %null-sha256)))))))))))
723 (test-equal "github-url: already the correct github url"
724 '()
725 (check-github-url
726 (dummy-package "x" (source
727 (origin
728 (method url-fetch)
729 (uri github-url)
730 (sha256 %null-sha256)))))))
731
732 (test-equal "cve"
733 '()
734 (mock ((guix lint) package-vulnerabilities (const '()))
735 (check-vulnerabilities (dummy-package "x"))))
736
737 (test-equal "cve: one vulnerability"
738 "probably vulnerable to CVE-2015-1234"
739 (mock ((guix lint) package-vulnerabilities
740 (lambda (package)
741 (list (make-struct (@@ (guix cve) <vulnerability>) 0
742 "CVE-2015-1234"
743 (list (cons (package-name package)
744 (package-version package)))))))
745 (single-lint-warning-message
746 (check-vulnerabilities (dummy-package "pi" (version "3.14"))))))
747
748 (test-equal "cve: one patched vulnerability"
749 '()
750 (mock ((guix lint) package-vulnerabilities
751 (lambda (package)
752 (list (make-struct (@@ (guix cve) <vulnerability>) 0
753 "CVE-2015-1234"
754 (list (cons (package-name package)
755 (package-version package)))))))
756 (check-vulnerabilities
757 (dummy-package "pi"
758 (version "3.14")
759 (source
760 (dummy-origin
761 (patches
762 (list "/a/b/pi-CVE-2015-1234.patch"))))))))
763
764 (test-equal "cve: known safe from vulnerability"
765 '()
766 (mock ((guix lint) package-vulnerabilities
767 (lambda (package)
768 (list (make-struct (@@ (guix cve) <vulnerability>) 0
769 "CVE-2015-1234"
770 (list (cons (package-name package)
771 (package-version package)))))))
772 (check-vulnerabilities
773 (dummy-package "pi"
774 (version "3.14")
775 (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))
776
777 (test-equal "cve: vulnerability fixed in replacement version"
778 '()
779 (mock ((guix lint) package-vulnerabilities
780 (lambda (package)
781 (match (package-version package)
782 ("0"
783 (list (make-struct (@@ (guix cve) <vulnerability>) 0
784 "CVE-2015-1234"
785 (list (cons (package-name package)
786 (package-version package))))))
787 ("1"
788 '()))))
789 (check-vulnerabilities
790 (dummy-package
791 "foo" (version "0")
792 (replacement (dummy-package "foo" (version "1")))))))
793
794 (test-equal "cve: patched vulnerability in replacement"
795 '()
796 (mock ((guix lint) package-vulnerabilities
797 (lambda (package)
798 (list (make-struct (@@ (guix cve) <vulnerability>) 0
799 "CVE-2015-1234"
800 (list (cons (package-name package)
801 (package-version package)))))))
802 (check-vulnerabilities
803 (dummy-package
804 "pi" (version "3.14") (source (dummy-origin))
805 (replacement (dummy-package
806 "pi" (version "3.14")
807 (source
808 (dummy-origin
809 (patches
810 (list "/a/b/pi-CVE-2015-1234.patch"))))))))))
811
812 (test-equal "formatting: lonely parentheses"
813 "parentheses feel lonely, move to the previous or next line"
814 (single-lint-warning-message
815 (check-formatting
816 (dummy-package "ugly as hell!"
817 )
818 )))
819
820 (test-assert "formatting: tabulation"
821 (string-match-or-error
822 "tabulation on line [0-9]+, column [0-9]+"
823 (single-lint-warning-message
824 (check-formatting (dummy-package "leave the tab here: ")))))
825
826 (test-assert "formatting: trailing white space"
827 (string-match-or-error
828 "trailing white space .*"
829 ;; Leave the trailing white space on the next line!
830 (single-lint-warning-message
831 (check-formatting (dummy-package "x")))))
832
833 (test-assert "formatting: long line"
834 (string-match-or-error
835 "line [0-9]+ is way too long \\([0-9]+ characters\\)"
836 (single-lint-warning-message (check-formatting
837 (dummy-package "x")) ;here is a stupid comment just to make a long line
838 )))
839
840 (test-equal "formatting: alright"
841 '()
842 (check-formatting (dummy-package "x")))
843
844 (test-end "lint")
845
846 ;; Local Variables:
847 ;; eval: (put 'with-http-server 'scheme-indent-function 2)
848 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
849 ;; End: