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: