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