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            (redirect    (build-response #:code 301
 436                                         #:headers
 437                                         `((location
 438                                            . ,(string->uri initial-url))))))
 439       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 440         (with-http-server `((,redirect ""))
 441           (let ((pkg (package
 442                        (inherit (dummy-package "x"))
 443                        (home-page (%local-url)))))
 444             (single-lint-warning-message
 445              (check-home-page pkg))))))))
 446
 447 (test-skip (if (http-server-can-listen?) 0 1))
 448 (test-equal "home-page: 301 -> 404"
 449   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
 450   (with-http-server '((404 "booh!"))
 451     (let* ((initial-url (%local-url))
 452            (redirect    (build-response #:code 301
 453                                         #:headers
 454                                         `((location
 455                                            . ,(string->uri initial-url))))))
 456       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 457         (with-http-server `((,redirect ""))
 458           (let ((pkg (package
 459                        (inherit (dummy-package "x"))
 460                        (home-page (%local-url)))))
 461             (single-lint-warning-message
 462              (check-home-page pkg))))))))
 463
 464
 465 (test-equal "source-file-name"
 466   "the source file name should contain the package name"
 467   (let ((pkg (dummy-package "x"
 468                             (version "3.2.1")
 469                             (source
 470                              (origin
 471                                (method url-fetch)
 472                                (uri "http://www.example.com/3.2.1.tar.gz")
 473                                (sha256 %null-sha256))))))
 474     (single-lint-warning-message
 475      (check-source-file-name pkg))))
 476
 477 (test-equal "source-file-name: v prefix"
 478   "the source file name should contain the package name"
 479   (let ((pkg (dummy-package "x"
 480                             (version "3.2.1")
 481                             (source
 482                              (origin
 483                                (method url-fetch)
 484                                (uri "http://www.example.com/v3.2.1.tar.gz")
 485                                (sha256 %null-sha256))))))
 486     (single-lint-warning-message
 487      (check-source-file-name pkg))))
 488
 489 (test-equal "source-file-name: bad checkout"
 490   "the source file name should contain the package name"
 491   (let ((pkg (dummy-package "x"
 492                             (version "3.2.1")
 493                             (source
 494                              (origin
 495                                (method git-fetch)
 496                                (uri (git-reference
 497                                      (url "http://www.example.com/x.git")
 498                                      (commit "0")))
 499                                (sha256 %null-sha256))))))
 500     (single-lint-warning-message
 501      (check-source-file-name pkg))))
 502
 503 (test-equal "source-file-name: good checkout"
 504   '()
 505   (let ((pkg (dummy-package "x"
 506                             (version "3.2.1")
 507                             (source
 508                              (origin
 509                                (method git-fetch)
 510                                (uri (git-reference
 511                                      (url "http://git.example.com/x.git")
 512                                      (commit "0")))
 513                                (file-name (string-append "x-" version))
 514                                (sha256 %null-sha256))))))
 515     (check-source-file-name pkg)))
 516
 517 (test-equal "source-file-name: valid"
 518   '()
 519   (let ((pkg (dummy-package "x"
 520                             (version "3.2.1")
 521                             (source
 522                              (origin
 523                                (method url-fetch)
 524                                (uri "http://www.example.com/x-3.2.1.tar.gz")
 525                                (sha256 %null-sha256))))))
 526     (check-source-file-name pkg)))
 527
 528 (test-equal "source-unstable-tarball"
 529   "the source URI should not be an autogenerated tarball"
 530   (let ((pkg (dummy-package "x"
 531                             (source
 532                              (origin
 533                                (method url-fetch)
 534                                (uri "https://github.com/example/example/archive/v0.0.tar.gz")
 535                                (sha256 %null-sha256))))))
 536     (single-lint-warning-message
 537      (check-source-unstable-tarball pkg))))
 538
 539 (test-equal "source-unstable-tarball: source #f"
 540   '()
 541   (let ((pkg (dummy-package "x"
 542                             (source #f))))
 543     (check-source-unstable-tarball pkg)))
 544
 545 (test-equal "source-unstable-tarball: valid"
 546   '()
 547   (let ((pkg (dummy-package "x"
 548                             (source
 549                              (origin
 550                                (method url-fetch)
 551                                (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
 552                                (sha256 %null-sha256))))))
 553     (check-source-unstable-tarball pkg)))
 554
 555 (test-equal "source-unstable-tarball: package named archive"
 556   '()
 557   (let ((pkg (dummy-package "x"
 558                             (source
 559                              (origin
 560                                (method url-fetch)
 561                                (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
 562                                (sha256 %null-sha256))))))
 563     (check-source-unstable-tarball pkg)))
 564
 565 (test-equal "source-unstable-tarball: not-github"
 566   '()
 567   (let ((pkg (dummy-package "x"
 568                             (source
 569                              (origin
 570                                (method url-fetch)
 571                                (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
 572                                (sha256 %null-sha256))))))
 573     (check-source-unstable-tarball pkg)))
 574
 575 (test-equal "source-unstable-tarball: git-fetch"
 576   '()
 577   (let ((pkg (dummy-package "x"
 578                             (source
 579                              (origin
 580                                (method git-fetch)
 581                                (uri (git-reference
 582                                      (url "https://github.com/archive/example.git")
 583                                      (commit "0")))
 584                                (sha256 %null-sha256))))))
 585     (check-source-unstable-tarball pkg)))
 586
 587 (test-skip (if (http-server-can-listen?) 0 1))
 588 (test-equal "source: 200"
 589   '()
 590   (with-http-server `((200 ,%long-string))
 591     (let ((pkg (package
 592                  (inherit (dummy-package "x"))
 593                  (source (origin
 594                            (method url-fetch)
 595                            (uri (%local-url))
 596                            (sha256 %null-sha256))))))
 597       (check-source pkg))))
 598
 599 (test-skip (if (http-server-can-listen?) 0 1))
 600 (test-equal "source: 200 but short length"
 601   "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
 602   (with-http-server '((200 "This is too small."))
 603     (let ((pkg (package
 604                  (inherit (dummy-package "x"))
 605                  (source (origin
 606                            (method url-fetch)
 607                            (uri (%local-url))
 608                            (sha256 %null-sha256))))))
 609       (match (check-source pkg)
 610         ((first-warning ; All source URIs are unreachable
 611           (and (? lint-warning?) second-warning))
 612          (lint-warning-message second-warning))))))
 613
 614 (test-skip (if (http-server-can-listen?) 0 1))
 615 (test-equal "source: 404"
 616   "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
 617   (with-http-server `((404 ,%long-string))
 618     (let ((pkg (package
 619                  (inherit (dummy-package "x"))
 620                  (source (origin
 621                            (method url-fetch)
 622                            (uri (%local-url))
 623                            (sha256 %null-sha256))))))
 624       (match (check-source pkg)
 625         ((first-warning ; All source URIs are unreachable
 626           (and (? lint-warning?) second-warning))
 627          (lint-warning-message second-warning))))))
 628
 629 (test-skip (if (http-server-can-listen?) 0 1))
 630 (test-equal "source: 404 and 200"
 631   '()
 632   (with-http-server `((404 ,%long-string))
 633     (let ((bad-url (%local-url)))
 634       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 635         (with-http-server `((200 ,%long-string))
 636           (let ((pkg (package
 637                        (inherit (dummy-package "x"))
 638                        (source (origin
 639                                  (method url-fetch)
 640                                  (uri (list bad-url (%local-url)))
 641                                  (sha256 %null-sha256))))))
 642             ;; Since one of the two URLs is good, this should return the empty
 643             ;; list.
 644             (check-source pkg)))))))
 645
 646 (test-skip (if (http-server-can-listen?) 0 1))
 647 (test-equal "source: 301 -> 200"
 648   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
 649   (with-http-server `((200 ,%long-string))
 650     (let* ((initial-url (%local-url))
 651            (redirect    (build-response #:code 301
 652                                         #:headers
 653                                         `((location
 654                                            . ,(string->uri initial-url))))))
 655       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 656         (with-http-server `((,redirect ""))
 657           (let ((pkg (package
 658                        (inherit (dummy-package "x"))
 659                        (source (origin
 660                                  (method url-fetch)
 661                                  (uri (%local-url))
 662                                  (sha256 %null-sha256))))))
 663             (match (check-source pkg)
 664               ((first-warning ; All source URIs are unreachable
 665                 (and (? lint-warning?) second-warning))
 666                (lint-warning-message second-warning)))))))))
 667
 668 (test-skip (if (http-server-can-listen?) 0 1))
 669 (test-equal "source: 301 -> 404"
 670   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
 671   (with-http-server '((404 "booh!"))
 672     (let* ((initial-url (%local-url))
 673            (redirect    (build-response #:code 301
 674                                         #:headers
 675                                         `((location
 676                                            . ,(string->uri initial-url))))))
 677       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 678         (with-http-server `((,redirect ""))
 679           (let ((pkg (package
 680                        (inherit (dummy-package "x"))
 681                        (source (origin
 682                                  (method url-fetch)
 683                                  (uri (%local-url))
 684                                  (sha256 %null-sha256))))))
 685             (match (check-source pkg)
 686               ((first-warning ; The first warning says that all URI's are
 687                               ; unreachable
 688                 (and (? lint-warning?) second-warning))
 689                (lint-warning-message second-warning)))))))))
 690
 691 (test-equal "mirror-url"
 692   '()
 693   (let ((source (origin
 694                   (method url-fetch)
 695                   (uri "http://example.org/foo/bar.tar.gz")
 696                   (sha256 %null-sha256))))
 697     (check-mirror-url (dummy-package "x" (source source)))))
 698
 699 (test-equal "mirror-url: one suggestion"
 700   "URL should be 'mirror://gnu/foo/foo.tar.gz'"
 701   (let ((source (origin
 702                   (method url-fetch)
 703                   (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
 704                   (sha256 %null-sha256))))
 705     (single-lint-warning-message
 706      (check-mirror-url (dummy-package "x" (source source))))))
 707
 708 (test-equal "github-url"
 709   '()
 710   (with-http-server `((200 ,%long-string))
 711     (check-github-url
 712      (dummy-package "x" (source
 713                          (origin
 714                            (method url-fetch)
 715                            (uri (%local-url))
 716                            (sha256 %null-sha256)))))))
 717
 718 (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
 719   (test-equal "github-url: one suggestion"
 720     (string-append
 721      "URL should be '" github-url "'")
 722     (let ((redirect (build-response #:code 301
 723                                     #:headers
 724                                     `((location
 725                                        . ,(string->uri github-url))))))
 726       (with-http-server `((,redirect ""))
 727         (let* ((initial-url (%local-url))
 728                (redirect    (build-response #:code 302
 729                                             #:headers
 730                                             `((location
 731                                                . ,(string->uri initial-url))))))
 732           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 733             (with-http-server `((,redirect ""))
 734               (single-lint-warning-message
 735                (check-github-url
 736                 (dummy-package "x" (source
 737                                     (origin
 738                                       (method url-fetch)
 739                                       (uri (%local-url))
 740                                       (sha256 %null-sha256))))))))))))
 741   (test-equal "github-url: already the correct github url"
 742     '()
 743     (check-github-url
 744      (dummy-package "x" (source
 745                          (origin
 746                            (method url-fetch)
 747                            (uri github-url)
 748                            (sha256 %null-sha256)))))))
 749
 750 (test-equal "cve"
 751   '()
 752   (mock ((guix lint) package-vulnerabilities (const '()))
 753         (check-vulnerabilities (dummy-package "x"))))
 754
 755 (test-equal "cve: one vulnerability"
 756   "probably vulnerable to CVE-2015-1234"
 757   (mock ((guix lint) package-vulnerabilities
 758          (lambda (package)
 759            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 760                               "CVE-2015-1234"
 761                               (list (cons (package-name package)
 762                                           (package-version package)))))))
 763         (single-lint-warning-message
 764          (check-vulnerabilities (dummy-package "pi" (version "3.14"))))))
 765
 766 (test-equal "cve: one patched vulnerability"
 767   '()
 768   (mock ((guix lint) package-vulnerabilities
 769          (lambda (package)
 770            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 771                               "CVE-2015-1234"
 772                               (list (cons (package-name package)
 773                                           (package-version package)))))))
 774         (check-vulnerabilities
 775          (dummy-package "pi"
 776                         (version "3.14")
 777                         (source
 778                          (dummy-origin
 779                           (patches
 780                            (list "/a/b/pi-CVE-2015-1234.patch"))))))))
 781
 782 (test-equal "cve: known safe from vulnerability"
 783   '()
 784   (mock ((guix lint) package-vulnerabilities
 785          (lambda (package)
 786            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 787                               "CVE-2015-1234"
 788                               (list (cons (package-name package)
 789                                           (package-version package)))))))
 790         (check-vulnerabilities
 791          (dummy-package "pi"
 792                         (version "3.14")
 793                         (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))
 794
 795 (test-equal "cve: vulnerability fixed in replacement version"
 796   '()
 797   (mock ((guix lint) package-vulnerabilities
 798          (lambda (package)
 799            (match (package-version package)
 800              ("0"
 801               (list (make-struct (@@ (guix cve) <vulnerability>) 0
 802                                  "CVE-2015-1234"
 803                                  (list (cons (package-name package)
 804                                              (package-version package))))))
 805              ("1"
 806               '()))))
 807         (check-vulnerabilities
 808          (dummy-package
 809           "foo" (version "0")
 810           (replacement (dummy-package "foo" (version "1")))))))
 811
 812 (test-equal "cve: patched vulnerability in replacement"
 813   '()
 814   (mock ((guix lint) package-vulnerabilities
 815          (lambda (package)
 816            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 817                               "CVE-2015-1234"
 818                               (list (cons (package-name package)
 819                                           (package-version package)))))))
 820         (check-vulnerabilities
 821          (dummy-package
 822           "pi" (version "3.14") (source (dummy-origin))
 823           (replacement (dummy-package
 824                         "pi" (version "3.14")
 825                         (source
 826                          (dummy-origin
 827                           (patches
 828                            (list "/a/b/pi-CVE-2015-1234.patch"))))))))))
 829
 830 (test-equal "formatting: lonely parentheses"
 831   "parentheses feel lonely, move to the previous or next line"
 832   (single-lint-warning-message
 833    (check-formatting
 834     (dummy-package "ugly as hell!"
 835                    )
 836     )))
 837
 838 (test-assert "formatting: tabulation"
 839   (string-match-or-error
 840    "tabulation on line [0-9]+, column [0-9]+"
 841    (single-lint-warning-message
 842     (check-formatting (dummy-package "leave the tab here:       ")))))
 843
 844 (test-assert "formatting: trailing white space"
 845   (string-match-or-error
 846    "trailing white space .*"
 847    ;; Leave the trailing white space on the next line!
 848    (single-lint-warning-message
 849     (check-formatting (dummy-package "x")))))
 850
 851 (test-assert "formatting: long line"
 852   (string-match-or-error
 853    "line [0-9]+ is way too long \\([0-9]+ characters\\)"
 854    (single-lint-warning-message (check-formatting
 855            (dummy-package "x"))                                     ;here is a stupid comment just to make a long line
 856      )))
 857
 858 (test-equal "formatting: alright"
 859   '()
 860   (check-formatting (dummy-package "x")))
 861
 862 (test-end "lint")
 863
 864 ;; Local Variables:
 865 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
 866 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 867 ;; End: