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-2022 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, 2022 Efraim Flashner <efraim@flashner.co.il>
   9 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
  10 ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
  11 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
  12 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
  13 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
  14 ;;;
  15 ;;; This file is part of GNU Guix.
  16 ;;;
  17 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  18 ;;; under the terms of the GNU General Public License as published by
  19 ;;; the Free Software Foundation; either version 3 of the License, or (at
  20 ;;; your option) any later version.
  21 ;;;
  22 ;;; GNU Guix is distributed in the hope that it will be useful, but
  23 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25 ;;; GNU General Public License for more details.
  26 ;;;
  27 ;;; You should have received a copy of the GNU General Public License
  28 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  29
  30 ;; Avoid interference.
  31 (unsetenv "http_proxy")
  32
  33 (define-module (test-lint)
  34   #:use-module (guix tests)
  35   #:use-module (guix tests http)
  36   #:use-module (guix download)
  37   #:use-module (guix git-download)
  38   #:use-module (guix svn-download)
  39   #:use-module (guix build-system texlive)
  40   #:use-module (guix build-system emacs)
  41   #:use-module (guix build-system gnu)
  42   #:use-module (guix packages)
  43   #:use-module (guix lint)
  44   #:use-module (guix ui)
  45   #:use-module (guix swh)
  46   #:use-module ((guix gexp) #:select (gexp local-file gexp?))
  47   #:use-module ((guix utils) #:select (call-with-temporary-directory))
  48   #:use-module ((guix import hackage) #:select (%hackage-url))
  49   #:use-module ((guix import stackage) #:select (%stackage-url))
  50   #:use-module (gnu packages)
  51   #:use-module (gnu packages glib)
  52   #:use-module (gnu packages pkg-config)
  53   #:use-module (gnu packages python-build)
  54   #:use-module ((gnu packages bash) #:select (bash bash-minimal))
  55   #:use-module (web uri)
  56   #:use-module (web server)
  57   #:use-module (web server http)
  58   #:use-module (web response)
  59   #:use-module (ice-9 match)
  60   #:use-module (ice-9 regex)
  61   #:use-module (ice-9 getopt-long)
  62   #:use-module (ice-9 pretty-print)
  63   #:use-module (rnrs bytevectors)
  64   #:use-module (srfi srfi-1)
  65   #:use-module (srfi srfi-9 gnu)
  66   #:use-module (srfi srfi-26)
  67   #:use-module (srfi srfi-64))
  68
  69 ;; Test the linter.
  70
  71 (define %null-sha256
  72   ;; SHA256 of the empty string.
  73   (base32
  74    "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
  75
  76 (define %long-string
  77   (make-string 2000 #\a))
  78
  79 (define (string-match-or-error pattern str)
  80   (or (string-match pattern str)
  81       (error str "did not match" pattern)))
  82
  83 (define single-lint-warning-message
  84   (match-lambda
  85     (((and (? lint-warning?) warning))
  86      (lint-warning-message warning))))
  87
  88 (define (warning-contains? str warnings)
  89   "Return true if WARNINGS is a singleton with a warning that contains STR."
  90   (match warnings
  91     (((? lint-warning? warning))
  92      (string-contains (lint-warning-message warning) str))))
  93
  94 \f
  95 (test-begin "lint")
  96
  97 (test-equal "description: not a string"
  98   "invalid description: foobar"
  99   (single-lint-warning-message
 100    (check-description-style
 101     (dummy-package "x" (description 'foobar)))))
 102
 103 (test-equal "description: not empty"
 104   "description should not be empty"
 105   (single-lint-warning-message
 106    (check-description-style
 107     (dummy-package "x" (description "")))))
 108
 109 (test-equal "description: invalid Texinfo markup"
 110   "Texinfo markup in description is invalid"
 111   (single-lint-warning-message
 112    (check-description-style
 113     (dummy-package "x" (description (identity "f{oo}b@r"))))))
 114
 115 (test-equal "description: does not start with an upper-case letter"
 116   "description should start with an upper-case letter or digit"
 117   (single-lint-warning-message
 118    (let ((pkg (dummy-package "x"
 119                              (description "bad description."))))
 120      (check-description-style pkg))))
 121
 122 (test-equal "description: may start with a digit"
 123   '()
 124   (let ((pkg (dummy-package "x"
 125                             (description "2-component library."))))
 126     (check-description-style pkg)))
 127
 128 (test-equal "description: may start with lower-case package name"
 129   '()
 130   (let ((pkg (dummy-package "x"
 131                             (description "x is a dummy package."))))
 132     (check-description-style pkg)))
 133
 134 (test-equal "description: two spaces after end of sentence"
 135   "sentences in description should be followed by two spaces; possible infraction at 3"
 136   (single-lint-warning-message
 137    (let ((pkg (dummy-package "x"
 138                              (description "Bad. Quite bad."))))
 139      (check-description-style pkg))))
 140
 141 (test-equal "description: end-of-sentence detection with abbreviations"
 142   '()
 143   (let ((pkg (dummy-package "x"
 144                             (description
 145                              "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
 146     (check-description-style pkg)))
 147
 148 (test-equal "description: may not contain trademark signs: ™"
 149   "description should not contain trademark sign '™' at 20"
 150   (single-lint-warning-message
 151    (let ((pkg (dummy-package "x"
 152                              (description "Does The Right Thing™"))))
 153      (check-description-style pkg))))
 154
 155 (test-equal "description: may not contain trademark signs: ®"
 156   "description should not contain trademark sign '®' at 17"
 157   (single-lint-warning-message
 158    (let ((pkg (dummy-package "x"
 159                              (description "Works with Format®"))))
 160      (check-description-style pkg))))
 161
 162 (test-equal "description: suggest ornament instead of quotes"
 163   "use @code or similar ornament instead of quotes"
 164   (single-lint-warning-message
 165    (let ((pkg (dummy-package "x"
 166                              (description "This is a 'quoted' thing."))))
 167      (check-description-style pkg))))
 168
 169 (test-equal "description: leading whitespace"
 170   "description contains leading whitespace"
 171   (single-lint-warning-message
 172    (let ((pkg (dummy-package "x"
 173                               (description " Whitespace."))))
 174      (check-description-style pkg))))
 175
 176 (test-equal "description: trailing whitespace"
 177   "description contains trailing whitespace"
 178   (single-lint-warning-message
 179    (let ((pkg (dummy-package "x"
 180                               (description "Whitespace. "))))
 181      (check-description-style pkg))))
 182
 183 (test-equal "description: pluralized 'This package'"
 184   "description contains typo 'This packages', should be 'This package'"
 185   (single-lint-warning-message
 186    (let ((pkg (dummy-package "x"
 187                              (description "This packages is a typo."))))
 188      (check-description-style pkg))))
 189
 190 (test-equal "description: grammar 'allows to'"
 191   "description contains typo 'allows to'"
 192   (single-lint-warning-message
 193    (let ((pkg (dummy-package "x"
 194                              (description "This package allows to do stuff."))))
 195      (check-description-style pkg))))
 196
 197 (test-equal "synopsis: not a string"
 198   "invalid synopsis: #f"
 199   (single-lint-warning-message
 200    (let ((pkg (dummy-package "x"
 201                              (synopsis #f))))
 202      (check-synopsis-style pkg))))
 203
 204 (test-equal "synopsis: not empty"
 205   "synopsis should not be empty"
 206   (single-lint-warning-message
 207    (let ((pkg (dummy-package "x"
 208                              (synopsis ""))))
 209      (check-synopsis-style pkg))))
 210
 211 (test-equal "synopsis: valid Texinfo markup"
 212   "Texinfo markup in synopsis is invalid"
 213   (single-lint-warning-message
 214    (check-synopsis-style
 215     (dummy-package "x" (synopsis (identity "Bad $@ texinfo"))))))
 216
 217 (test-equal "synopsis: does not start with an upper-case letter"
 218   "synopsis should start with an upper-case letter or digit"
 219   (single-lint-warning-message
 220    (let ((pkg (dummy-package "x"
 221                              (synopsis "bad synopsis"))))
 222      (check-synopsis-style pkg))))
 223
 224 (test-equal "synopsis: may start with a digit"
 225   '()
 226   (let ((pkg (dummy-package "x"
 227                             (synopsis "5-dimensional frobnicator"))))
 228     (check-synopsis-style pkg)))
 229
 230 (test-equal "synopsis: ends with a period"
 231   "no period allowed at the end of the synopsis"
 232   (single-lint-warning-message
 233    (let ((pkg (dummy-package "x"
 234                              (synopsis "Bad synopsis."))))
 235      (check-synopsis-style pkg))))
 236
 237 (test-equal "synopsis: ends with 'etc.'"
 238   '()
 239   (let ((pkg (dummy-package "x"
 240                             (synopsis "Foo, bar, etc."))))
 241     (check-synopsis-style pkg)))
 242
 243 (test-equal "synopsis: starts with 'A'"
 244   "no article allowed at the beginning of the synopsis"
 245   (single-lint-warning-message
 246    (let ((pkg (dummy-package "x"
 247                              (synopsis "A bad synopŝis"))))
 248      (check-synopsis-style pkg))))
 249
 250 (test-equal "synopsis: starts with 'An'"
 251   "no article allowed at the beginning of the synopsis"
 252   (single-lint-warning-message
 253    (let ((pkg (dummy-package "x"
 254                              (synopsis "An awful synopsis"))))
 255      (check-synopsis-style pkg))))
 256
 257 (test-equal "synopsis: starts with 'a'"
 258   '("no article allowed at the beginning of the synopsis"
 259     "synopsis should start with an upper-case letter or digit")
 260   (sort
 261    (map
 262     lint-warning-message
 263     (let ((pkg (dummy-package "x"
 264                               (synopsis "a bad synopsis"))))
 265       (check-synopsis-style pkg)))
 266    string<?))
 267
 268 (test-equal "synopsis: starts with 'an'"
 269   '("no article allowed at the beginning of the synopsis"
 270     "synopsis should start with an upper-case letter or digit")
 271   (sort
 272    (map
 273     lint-warning-message
 274     (let ((pkg (dummy-package "x"
 275                               (synopsis "an awful synopsis"))))
 276       (check-synopsis-style pkg)))
 277    string<?))
 278
 279 (test-equal "synopsis: too long"
 280   "synopsis should be less than 80 characters long"
 281   (single-lint-warning-message
 282    (let ((pkg (dummy-package "x"
 283                              (synopsis (make-string 80 #\X)))))
 284      (check-synopsis-style pkg))))
 285
 286 (test-equal "synopsis: start with package name"
 287   "synopsis should not start with the package name"
 288   (single-lint-warning-message
 289    (let ((pkg (dummy-package "x"
 290                              (name "Foo")
 291                              (synopsis "Foo, a nice package"))))
 292      (check-synopsis-style pkg))))
 293
 294 (test-equal "synopsis: start with package name prefix"
 295   '()
 296   (let ((pkg (dummy-package "arb"
 297                             (synopsis "Arbitrary precision"))))
 298     (check-synopsis-style pkg)))
 299
 300 (test-equal "synopsis: start with abbreviation"
 301   '()
 302   (let ((pkg (dummy-package "uucp"
 303                             ;; Same problem with "APL interpreter", etc.
 304                             (synopsis "UUCP implementation")
 305                             (description "Imagine this is Taylor UUCP."))))
 306     (check-synopsis-style pkg)))
 307
 308 (test-equal "synopsis: contains trailing whitespace"
 309   "synopsis contains trailing whitespace"
 310   (single-lint-warning-message
 311    (let ((pkg (dummy-package "x"
 312                              (synopsis "Whitespace "))))
 313      (check-synopsis-style pkg))))
 314
 315 (test-equal "name: use underscore in package name"
 316   "name should use hyphens instead of underscores"
 317   (single-lint-warning-message
 318    (let ((pkg (dummy-package "under_score")))
 319      (check-name pkg))))
 320
 321 (test-equal "tests-true: #:tests? must not be set to #t"
 322   "#:tests? must not be explicitly set to #t"
 323   (single-lint-warning-message
 324    (let ((pkg (dummy-package "x" (arguments '(#:tests? #t)))))
 325      (check-tests-true pkg))))
 326
 327 (test-equal "tests-true: absent #:tests? is acceptable"
 328   '()
 329   (let ((pkg (dummy-package "x")))
 330     (check-tests-true pkg)))
 331
 332 (test-equal "tests-true: #:tests? #f is acceptable"
 333   '()
 334   (let ((pkg (dummy-package "x" (arguments '(#:tests? #f)))))
 335     (check-tests-true pkg)))
 336
 337 (test-equal "tests-true: #:tests? #t acceptable when compiling natively"
 338   '()
 339   (let ((pkg (dummy-package "x"
 340                             (arguments
 341                              `(#:tests? ,(not (%current-target-system)))))))
 342     (check-tests-true pkg)))
 343
 344 ;; The emacs-build-system sets #:tests? #f by default.
 345 (test-equal "tests-true: #:tests? #t acceptable for emacs packages"
 346   '()
 347   (let ((pkg (dummy-package "x"
 348                             (build-system emacs-build-system)
 349                             (arguments
 350                              `(#:tests? #t)))))
 351     (check-tests-true pkg)))
 352
 353 ;; Likewise, though the 'check' phase is deleted by default,
 354 ;; so #:tests? #t won't be useful by itself.
 355 (test-equal "tests-true: #:tests? #t acceptable for texlive packages"
 356   '()
 357   (let ((pkg (dummy-package "x"
 358                             (build-system texlive-build-system)
 359                             (arguments
 360                              `(#:tests? #t)))))
 361     (check-tests-true pkg)))
 362
 363 (test-equal "inputs: pkg-config is probably a native input"
 364   "'pkg-config' should probably be a native input"
 365   (single-lint-warning-message
 366    (let ((pkg (dummy-package "x"
 367                              (inputs `(("pkg-config" ,pkg-config))))))
 368      (check-inputs-should-be-native pkg))))
 369
 370 (test-equal "inputs: glib:bin is probably a native input"
 371   "'glib:bin' should probably be a native input"
 372   (single-lint-warning-message
 373    (let ((pkg (dummy-package "x"
 374                              (inputs `(("glib" ,glib "bin"))))))
 375      (check-inputs-should-be-native pkg))))
 376
 377 (test-equal
 378     "inputs: python-setuptools should not be an input at all (input)"
 379   "'python-setuptools' should probably not be an input at all"
 380   (single-lint-warning-message
 381    (let ((pkg (dummy-package "x"
 382                              (inputs `(("python-setuptools"
 383                                         ,python-setuptools))))))
 384      (check-inputs-should-not-be-an-input-at-all pkg))))
 385
 386 (test-equal
 387     "inputs: python-setuptools should not be an input at all (native-input)"
 388   "'python-setuptools' should probably not be an input at all"
 389   (single-lint-warning-message
 390    (let ((pkg (dummy-package "x"
 391                              (native-inputs
 392                               `(("python-setuptools"
 393                                  ,python-setuptools))))))
 394      (check-inputs-should-not-be-an-input-at-all pkg))))
 395
 396 (test-equal
 397     "inputs: python-setuptools should not be an input at all (propagated-input)"
 398   "'python-setuptools' should probably not be an input at all"
 399   (single-lint-warning-message
 400    (let ((pkg (dummy-package "x"
 401                              (propagated-inputs
 402                               `(("python-setuptools" ,python-setuptools))))))
 403      (check-inputs-should-not-be-an-input-at-all pkg))))
 404
 405 (test-assert "input labels: no warnings"
 406   (let ((pkg (dummy-package "x"
 407                (inputs `(("glib" ,glib)
 408                          ("pkg-config" ,pkg-config))))))
 409     (null? (check-input-labels pkg))))
 410
 411 (test-equal "input labels: one warning"
 412   "label 'pkgkonfig' does not match package name 'pkg-config'"
 413   (single-lint-warning-message
 414    (let ((pkg (dummy-package "x"
 415                 (inputs `(("glib" ,glib)
 416                           ("pkgkonfig" ,pkg-config))))))
 417      (check-input-labels pkg))))
 418
 419 (test-equal "explicit #:sh argument to 'wrap-program' is acceptable"
 420   '()
 421   (let* ((phases
 422           ;; Loosely based on the "catfish" package
 423           `(modify-phases %standard-phases
 424              (add-after 'install 'wrap
 425                (lambda* (#:key inputs outputs #:allow-other-keys)
 426                  (define catfish (string-append (assoc-ref outputs "out")
 427                                                 "/bin/catfish"))
 428                  (define hsab (string-append (assoc-ref inputs "hsab")
 429                                              "/bin/hsab"))
 430                  (wrap-program catfish #:sh hsab
 431                                `("PYTHONPATH" = (,"blabla")))))))
 432          (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
 433     (check-wrapper-inputs pkg)))
 434
 435 (test-equal
 436     "'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs"
 437   "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used"
 438   (let* ((phases
 439           `(modify-phases %standard-phases
 440              (add-after 'install 'wrap
 441                (lambda _
 442                  (wrap-program the-binary bla-bla)))))
 443          (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
 444     (single-lint-warning-message (check-wrapper-inputs pkg))))
 445
 446 (test-equal
 447     "'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs"
 448   "\"bash-minimal\" should be in 'inputs' when 'wrap-qt-program' is used"
 449   (let* ((phases
 450           `(modify-phases %standard-phases
 451              (add-after 'install 'qtwrap
 452                (lambda _
 453                  (wrap-qt-program the-binary bla-bla)))))
 454          (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
 455     (single-lint-warning-message (check-wrapper-inputs pkg))))
 456
 457 (test-equal "\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'"
 458   '()
 459   (let* ((phases
 460           `(modify-phases %standard-phases
 461              (add-after 'install 'wrap
 462                (lambda _
 463                  (wrap-program the-binary bla-bla)))))
 464          (pkg (dummy-package "x" (arguments `(#:phases ,phases))
 465                              (inputs `(("bash" ,bash))))))
 466     (check-wrapper-inputs pkg)))
 467
 468 (test-equal "\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'"
 469   '()
 470   (let* ((phases
 471           `(modify-phases %standard-phases
 472              (add-after 'install 'wrap
 473                (lambda _
 474                  (wrap-program THE-BINARY bla-bla)))))
 475          (pkg (dummy-package "x" (arguments `(#:phases ,phases))
 476                              (inputs `(("bash-minimal" ,bash-minimal))))))
 477     (check-wrapper-inputs pkg)))
 478
 479 (test-equal "'cut' doesn't hide bad usages of 'wrap-program'"
 480   "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used"
 481   (let* ((phases
 482           ;; Taken from the "straw-viewer" package
 483           `(modify-phases %standard-phases
 484              (add-after 'install 'wrap-program
 485                (lambda* (#:key outputs #:allow-other-keys)
 486                  (let* ((out (assoc-ref outputs "out"))
 487                         (bin-dir (string-append out "/bin/"))
 488                         (site-dir (string-append out "/lib/perl5/site_perl/"))
 489                         (lib-path (getenv "PERL5LIB")))
 490                    (for-each (cut wrap-program <>
 491                                   `("PERL5LIB" ":" prefix
 492                                     (,lib-path ,site-dir)))
 493                              (find-files bin-dir)))))))
 494          (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
 495     (single-lint-warning-message (check-wrapper-inputs pkg))))
 496
 497 (test-equal "bogus phase specifications don't crash the linter"
 498   "invalid phase clause"
 499   (let* ((phases
 500           `(modify-phases %standard-phases
 501              (add-invalid)))
 502          (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
 503     (single-lint-warning-message (check-wrapper-inputs pkg))))
 504
 505 (test-equal "file patches: different file name -> warning"
 506   "file names of patches should start with the package name"
 507   (single-lint-warning-message
 508    (let ((pkg (dummy-package "x"
 509                              (source
 510                               (dummy-origin
 511                                (patches (list "/path/to/y.patch")))))))
 512      (check-patch-file-names pkg))))
 513
 514 (test-equal "file patches: same file name -> no warnings"
 515   '()
 516   (let ((pkg (dummy-package "x"
 517                             (source
 518                              (dummy-origin
 519                               (patches (list "/path/to/x.patch")))))))
 520     (check-patch-file-names pkg)))
 521
 522 (test-equal "<origin> patches: different file name -> warning"
 523   "file names of patches should start with the package name"
 524   (single-lint-warning-message
 525    (let ((pkg (dummy-package "x"
 526                              (source
 527                               (dummy-origin
 528                                (patches
 529                                 (list
 530                                  (dummy-origin
 531                                   (file-name "y.patch")))))))))
 532      (check-patch-file-names pkg))))
 533
 534 (test-equal "<origin> patches: same file name -> no warnings"
 535   '()
 536   (let ((pkg (dummy-package "x"
 537                             (source
 538                              (dummy-origin
 539                               (patches
 540                                (list
 541                                 (dummy-origin
 542                                  (file-name "x.patch")))))))))
 543     (check-patch-file-names pkg)))
 544
 545 (test-equal "patches: file name too long, which may break 'make dist'"
 546   (string-append "x-"
 547                  (make-string 152 #\a)
 548                  ".patch: file name is too long, which may break 'make dist'")
 549   (single-lint-warning-message
 550    (let ((pkg (dummy-package
 551                "x"
 552                (source
 553                 (dummy-origin
 554                  (patches (list (string-append "x-"
 555                                                (make-string 152 #\a)
 556                                                ".patch"))))))))
 557      (check-patch-file-names pkg))))
 558
 559 (test-equal "patches: not found"
 560   "this-patch-does-not-exist!: patch not found\n"
 561   (single-lint-warning-message
 562    (let ((pkg (dummy-package
 563                "x"
 564                (source
 565                 (dummy-origin
 566                  (patches
 567                   (list (search-patch "this-patch-does-not-exist!"))))))))
 568      (check-patch-file-names pkg))))
 569
 570 (test-assert "patch headers: no warnings"
 571   (call-with-temporary-directory
 572    (lambda (directory)
 573      (call-with-output-file (string-append directory "/t.patch")
 574        (lambda (port)
 575          (display "This is a patch.\n\n--- a\n+++ b\n"
 576                   port)))
 577
 578      (parameterize ((%patch-path (list directory)))
 579        (let ((pkg (dummy-package "x"
 580                     (source (dummy-origin
 581                              (patches (search-patches "t.patch")))))))
 582          (null? (check-patch-headers pkg)))))))
 583
 584 (test-equal "patch headers: missing comment"
 585   "t.patch: patch lacks comment and upstream status"
 586   (call-with-temporary-directory
 587    (lambda (directory)
 588      (call-with-output-file (string-append directory "/t.patch")
 589        (lambda (port)
 590          (display "\n--- a\n+++ b\n"
 591                   port)))
 592
 593      (parameterize ((%patch-path (list directory)))
 594        (let ((pkg (dummy-package "x"
 595                     (source (dummy-origin
 596                              (patches (search-patches "t.patch")))))))
 597          (single-lint-warning-message (check-patch-headers pkg)))))))
 598
 599 (test-equal "patch headers: empty"
 600   "t.patch: empty patch"
 601   (call-with-temporary-directory
 602    (lambda (directory)
 603      (call-with-output-file (string-append directory "/t.patch")
 604        (const #t))
 605
 606      (parameterize ((%patch-path '()))
 607        (let ((pkg (dummy-package "x"
 608                     (source (dummy-origin
 609                              (patches
 610                               (list (local-file
 611                                      (string-append directory
 612                                                     "/t.patch")))))))))
 613          (single-lint-warning-message (check-patch-headers pkg)))))))
 614
 615 (test-equal "patch headers: patch not found"
 616   "does-not-exist.patch: patch not found\n"
 617   (parameterize ((%patch-path '()))
 618     (let ((pkg (dummy-package "x"
 619                  (source (dummy-origin
 620                           (patches
 621                            (search-patches "does-not-exist.patch")))))))
 622       (single-lint-warning-message (check-patch-headers pkg)))))
 623
 624 (test-equal "derivation: invalid arguments"
 625   "failed to create x86_64-linux derivation: (match-error \"match\" \"no matching pattern\" invalid-module)"
 626   (match (let ((pkg (dummy-package "x"
 627                                    (arguments
 628                                     '(#:imported-modules (invalid-module))))))
 629            (check-derivation pkg))
 630     (((and (? lint-warning?) first-warning) others ...)
 631      (lint-warning-message first-warning))))
 632
 633 (test-equal "profile-collisions: no warnings"
 634   '()
 635   (check-profile-collisions (dummy-package "x")))
 636
 637 (test-equal "profile-collisions: propagated inputs collide"
 638   "propagated inputs p0@1 and p0@2 collide"
 639   (let* ((p0  (dummy-package "p0" (version "1")))
 640          (p0* (dummy-package "p0" (version "2")))
 641          (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
 642          (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
 643          (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
 644          (p4  (dummy-package "p4" (propagated-inputs
 645                                    `(("p2" ,p2) ("p3", p3))))))
 646     (single-lint-warning-message
 647      (check-profile-collisions p4))))
 648
 649 (test-assert "profile-collisions: propagated inputs collide, store items"
 650   (string-match-or-error
 651    "propagated inputs /[[:graph:]]+-p0-1 and /[[:graph:]]+-p0-1 collide"
 652    (let* ((p0  (dummy-package "p0" (version "1")))
 653           (p0* (dummy-package "p0" (version "1")
 654                               (inputs `(("x" ,(dummy-package "x"))))))
 655           (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
 656           (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
 657           (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
 658           (p4  (dummy-package "p4" (propagated-inputs
 659                                     `(("p2" ,p2) ("p3", p3))))))
 660      (single-lint-warning-message
 661       (check-profile-collisions p4)))))
 662
 663 (test-equal "license: invalid license"
 664   "invalid license field"
 665   (single-lint-warning-message
 666    (check-license (dummy-package "x" (license #f)))))
 667
 668 (test-equal "home-page: wrong home-page"
 669   "invalid value for home page"
 670   (let ((pkg (package
 671                (inherit (dummy-package "x"))
 672                (home-page #f))))
 673     (single-lint-warning-message
 674      (check-home-page pkg))))
 675
 676 (test-equal "home-page: invalid URI"
 677   "invalid home page URL: \"foobar\""
 678   (let ((pkg (package
 679                (inherit (dummy-package "x"))
 680                (home-page "foobar"))))
 681     (single-lint-warning-message
 682      (check-home-page pkg))))
 683
 684 (test-assert "home-page: host not found"
 685   (let ((pkg (package
 686                (inherit (dummy-package "x"))
 687                (home-page "http://does-not-exist"))))
 688     (warning-contains? "domain not found" (check-home-page pkg))))
 689
 690 (parameterize ((%http-server-port 9999))
 691   ;; TODO skip this test if some process is currently listening at 9999
 692   (test-equal "home-page: Connection refused"
 693     "URI http://localhost:9999/foo/bar unreachable: Connection refused"
 694     (let ((pkg (package
 695                  (inherit (dummy-package "x"))
 696                  (home-page (%local-url)))))
 697       (single-lint-warning-message
 698        (check-home-page pkg)))))
 699
 700 (test-equal "home-page: 200"
 701   '()
 702   (with-http-server `((200 ,%long-string))
 703     (let ((pkg (package
 704                  (inherit (dummy-package "x"))
 705                  (home-page (%local-url)))))
 706       (check-home-page pkg))))
 707
 708 (with-http-server `((200 "This is too small."))
 709   (test-equal "home-page: 200 but short length"
 710     (format #f "URI ~a returned suspiciously small file (18 bytes)"
 711             (%local-url))
 712     (let ((pkg (package
 713                  (inherit (dummy-package "x"))
 714                  (home-page (%local-url)))))
 715
 716       (single-lint-warning-message
 717        (check-home-page pkg)))))
 718
 719 (with-http-server `((404 ,%long-string))
 720   (test-equal "home-page: 404"
 721     (format #f "URI ~a not reachable: 404 (\"Such is life\")" (%local-url))
 722     (let ((pkg (package
 723                  (inherit (dummy-package "x"))
 724                  (home-page (%local-url)))))
 725       (single-lint-warning-message
 726        (check-home-page pkg)))))
 727
 728 (with-http-server `((301 ,%long-string))
 729   (test-equal "home-page: 301, invalid"
 730     (format #f "invalid permanent redirect from ~a" (%local-url))
 731     (let ((pkg (package
 732                  (inherit (dummy-package "x"))
 733                  (home-page (%local-url)))))
 734       (single-lint-warning-message
 735        (check-home-page pkg)))))
 736
 737 (with-http-server `((200 ,%long-string))
 738   (let* ((initial-url (%local-url))
 739          (redirect (build-response #:code 301
 740                                    #:headers
 741                                    `((location
 742                                       . ,(string->uri initial-url))))))
 743     (parameterize ((%http-server-port 0))
 744       (with-http-server `((,redirect ""))
 745         (test-equal "home-page: 301 -> 200"
 746           (format #f "permanent redirect from ~a to ~a"
 747                   (%local-url) initial-url)
 748           (let ((pkg (package
 749                        (inherit (dummy-package "x"))
 750                        (home-page (%local-url)))))
 751             (single-lint-warning-message
 752              (check-home-page pkg))))))))
 753
 754 (with-http-server `((404 "booh!"))
 755   (let* ((initial-url (%local-url))
 756          (redirect    (build-response #:code 301
 757                                       #:headers
 758                                       `((location
 759                                          . ,(string->uri initial-url))))))
 760     (parameterize ((%http-server-port 0))
 761       (with-http-server `((,redirect ""))
 762         (test-equal "home-page: 301 -> 404"
 763           (format #f "URI ~a not reachable: 404 (\"Such is life\")" (%local-url))
 764           (let ((pkg (package
 765                        (inherit (dummy-package "x"))
 766                        (home-page (%local-url)))))
 767             (single-lint-warning-message
 768              (check-home-page pkg))))))))
 769
 770
 771 (test-equal "source-file-name"
 772   "the source file name should contain the package name"
 773   (let ((pkg (dummy-package "x"
 774                             (version "3.2.1")
 775                             (source
 776                              (origin
 777                                (method url-fetch)
 778                                (uri "http://www.example.com/3.2.1.tar.gz")
 779                                (sha256 %null-sha256))))))
 780     (single-lint-warning-message
 781      (check-source-file-name pkg))))
 782
 783 (test-equal "source-file-name: v prefix"
 784   "the source file name should contain the package name"
 785   (let ((pkg (dummy-package "x"
 786                             (version "3.2.1")
 787                             (source
 788                              (origin
 789                                (method url-fetch)
 790                                (uri "http://www.example.com/v3.2.1.tar.gz")
 791                                (sha256 %null-sha256))))))
 792     (single-lint-warning-message
 793      (check-source-file-name pkg))))
 794
 795 (test-equal "source-file-name: bad checkout"
 796   "the source file name should contain the package name"
 797   (let ((pkg (dummy-package "x"
 798                             (version "3.2.1")
 799                             (source
 800                              (origin
 801                                (method git-fetch)
 802                                (uri (git-reference
 803                                      (url "http://www.example.com/x.git")
 804                                      (commit "0")))
 805                                (sha256 %null-sha256))))))
 806     (single-lint-warning-message
 807      (check-source-file-name pkg))))
 808
 809 (test-equal "source-file-name: good checkout"
 810   '()
 811   (let ((pkg (dummy-package "x"
 812                             (version "3.2.1")
 813                             (source
 814                              (origin
 815                                (method git-fetch)
 816                                (uri (git-reference
 817                                      (url "http://git.example.com/x.git")
 818                                      (commit "0")))
 819                                (file-name (string-append "x-" version))
 820                                (sha256 %null-sha256))))))
 821     (check-source-file-name pkg)))
 822
 823 (test-equal "source-file-name: valid"
 824   '()
 825   (let ((pkg (dummy-package "x"
 826                             (version "3.2.1")
 827                             (source
 828                              (origin
 829                                (method url-fetch)
 830                                (uri "http://www.example.com/x-3.2.1.tar.gz")
 831                                (sha256 %null-sha256))))))
 832     (check-source-file-name pkg)))
 833
 834 (test-equal "source-unstable-tarball"
 835   "the source URI should not be an autogenerated tarball"
 836   (let ((pkg (dummy-package "x"
 837                             (source
 838                              (origin
 839                                (method url-fetch)
 840                                (uri "https://github.com/example/example/archive/v0.0.tar.gz")
 841                                (sha256 %null-sha256))))))
 842     (single-lint-warning-message
 843      (check-source-unstable-tarball pkg))))
 844
 845 (test-equal "source-unstable-tarball: source #f"
 846   '()
 847   (let ((pkg (dummy-package "x"
 848                             (source #f))))
 849     (check-source-unstable-tarball pkg)))
 850
 851 (test-equal "source-unstable-tarball: valid"
 852   '()
 853   (let ((pkg (dummy-package "x"
 854                             (source
 855                              (origin
 856                                (method url-fetch)
 857                                (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
 858                                (sha256 %null-sha256))))))
 859     (check-source-unstable-tarball pkg)))
 860
 861 (test-equal "source-unstable-tarball: package named archive"
 862   '()
 863   (let ((pkg (dummy-package "x"
 864                             (source
 865                              (origin
 866                                (method url-fetch)
 867                                (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
 868                                (sha256 %null-sha256))))))
 869     (check-source-unstable-tarball pkg)))
 870
 871 (test-equal "source-unstable-tarball: not-github"
 872   '()
 873   (let ((pkg (dummy-package "x"
 874                             (source
 875                              (origin
 876                                (method url-fetch)
 877                                (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
 878                                (sha256 %null-sha256))))))
 879     (check-source-unstable-tarball pkg)))
 880
 881 (test-equal "source-unstable-tarball: git-fetch"
 882   '()
 883   (let ((pkg (dummy-package "x"
 884                             (source
 885                              (origin
 886                                (method git-fetch)
 887                                (uri (git-reference
 888                                      (url "https://github.com/archive/example")
 889                                      (commit "0")))
 890                                (sha256 %null-sha256))))))
 891     (check-source-unstable-tarball pkg)))
 892
 893 (define (package-with-phase-changes changes)
 894   (dummy-package "x"
 895                  (arguments `(#:phases
 896                               ,(if (gexp? changes)
 897                                    #~(modify-phases %standard-phases
 898                                        #$@changes)
 899                                    `(modify-phases %standard-phases
 900                                       ,@changes))))))
 901
 902 (test-equal "optional-tests: no check phase"
 903   '()
 904   (let ((pkg (package-with-phase-changes '())))
 905     (check-optional-tests pkg)))
 906
 907 (test-equal "optional-tests: check phase respects #:tests?"
 908   '()
 909   (let ((pkg (package-with-phase-changes
 910               '((replace 'check
 911                   (lambda* (#:key tests? #:allow-other-keys?)
 912                     (when tests?
 913                       (invoke "./the-test-suite"))))))))
 914     (check-optional-tests pkg)))
 915
 916 (test-equal "optional-tests: check phase ignores #:tests?"
 917   "the 'check' phase should respect #:tests?"
 918   (let ((pkg (package-with-phase-changes
 919               '((replace 'check
 920                   (lambda _
 921                     (invoke "./the-test-suite")))))))
 922     (single-lint-warning-message
 923      (check-optional-tests pkg))))
 924
 925 (test-equal "optional-tests: do not crash when #:phases is invalid"
 926   "incorrect call to ‘modify-phases’"
 927   (let ((pkg (package-with-phase-changes 'this-is-not-a-list)))
 928     (single-lint-warning-message
 929      (check-optional-tests pkg))))
 930
 931 (test-equal "optional-tests: allow G-exps (no warning)"
 932   '()
 933   (let ((pkg (package-with-phase-changes #~())))
 934     (check-optional-tests pkg)))
 935
 936 (test-equal "optional-tests: allow G-exps (warning)"
 937   "the 'check' phase should respect #:tests?"
 938   (let ((pkg (package-with-phase-changes
 939               #~((replace 'check
 940                    (lambda _
 941                      (invoke "/the-test-suite")))))))
 942     (single-lint-warning-message
 943      (check-optional-tests pkg))))
 944
 945 (test-equal "optional-tests: complicated 'check' phase"
 946   "the 'check' phase should respect #:tests?"
 947   (let ((pkg (package-with-phase-changes
 948               '((replace 'check
 949                   (lambda* (#:key inputs tests? #:allow-other-keys)
 950                     (let ((something (stuff from inputs or native-inputs)))
 951                       (delete-file "dateutil/test/test_utils.py")
 952                       (invoke "pytest" "-vv"))))))))
 953     (single-lint-warning-message
 954      (check-optional-tests pkg))))
 955
 956 (test-equal "optional-tests: 'check' phase is not first phase"
 957   "the 'check' phase should respect #:tests?"
 958   (let ((pkg (package-with-phase-changes
 959               '((add-after 'unpack
 960                     (lambda _
 961                       (chdir "libtestcase-0.0.0")))
 962                 (replace 'check
 963                   (lambda _ (invoke "./test-suite")))))))
 964     (single-lint-warning-message
 965      (check-optional-tests pkg))))
 966
 967 (test-equal "source: 200"
 968   '()
 969   (with-http-server `((200 ,%long-string))
 970     (let ((pkg (package
 971                  (inherit (dummy-package "x"))
 972                  (source (origin
 973                            (method url-fetch)
 974                            (uri (%local-url))
 975                            (sha256 %null-sha256))))))
 976       (check-source pkg))))
 977
 978 (with-http-server '((200 "This is too small."))
 979   (test-equal "source: 200 but short length"
 980     (format #f "URI ~a returned suspiciously small file (18 bytes)"
 981             (%local-url))
 982     (let ((pkg (package
 983                  (inherit (dummy-package "x"))
 984                  (source (origin
 985                            (method url-fetch)
 986                            (uri (%local-url))
 987                            (sha256 %null-sha256))))))
 988       (match (check-source pkg)
 989         ((first-warning ; All source URIs are unreachable
 990           (and (? lint-warning?) second-warning))
 991          (lint-warning-message second-warning))))))
 992
 993 (with-http-server `((404 ,%long-string))
 994   (test-equal "source: 404"
 995     (format #f "URI ~a not reachable: 404 (\"Such is life\")"
 996             (%local-url))
 997     (let ((pkg (package
 998                  (inherit (dummy-package "x"))
 999                  (source (origin
1000                            (method url-fetch)
1001                            (uri (%local-url))
1002                            (sha256 %null-sha256))))))
1003       (match (check-source pkg)
1004         ((first-warning ; All source URIs are unreachable
1005           (and (? lint-warning?) second-warning))
1006          (lint-warning-message second-warning))))))
1007
1008 (test-equal "source: 404 and 200"
1009   '()
1010   (with-http-server `((404 ,%long-string))
1011     (let ((bad-url (%local-url)))
1012       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
1013         (with-http-server `((200 ,%long-string))
1014           (let ((pkg (package
1015                        (inherit (dummy-package "x"))
1016                        (source (origin
1017                                  (method url-fetch)
1018                                  (uri (list bad-url (%local-url)))
1019                                  (sha256 %null-sha256))))))
1020             ;; Since one of the two URLs is good, this should return the empty
1021             ;; list.
1022             (check-source pkg)))))))
1023
1024 (with-http-server `((200 ,%long-string))
1025   (let* ((initial-url (%local-url))
1026          (redirect    (build-response #:code 301
1027                                       #:headers
1028                                       `((location
1029                                          . ,(string->uri initial-url))))))
1030     (parameterize ((%http-server-port 0))
1031       (with-http-server `((,redirect ""))
1032         (test-equal "source: 301 -> 200"
1033           (format #f "permanent redirect from ~a to ~a"
1034                   (%local-url) initial-url)
1035           (let ((pkg (package
1036                        (inherit (dummy-package "x"))
1037                        (source (origin
1038                                  (method url-fetch)
1039                                  (uri (%local-url))
1040                                  (sha256 %null-sha256))))))
1041             (match (check-source pkg)
1042               ((first-warning ; All source URIs are unreachable
1043                 (and (? lint-warning?) second-warning))
1044                (lint-warning-message second-warning)))))))))
1045
1046 (with-http-server `((200 ,%long-string))
1047   (let* ((initial-url (%local-url))
1048          (redirect    (build-response #:code 301
1049                                       #:headers
1050                                       `((location
1051                                          . ,(string->uri initial-url))))))
1052     (parameterize ((%http-server-port 0))
1053       (with-http-server `((,redirect ""))
1054         (test-equal "source, git-reference: 301 -> 200"
1055           (format #f "permanent redirect from ~a to ~a"
1056                   (%local-url) initial-url)
1057           (let ((pkg (dummy-package
1058                       "x"
1059                       (source (origin
1060                                 (method git-fetch)
1061                                 (uri (git-reference (url (%local-url))
1062                                                     (commit "v1.0.0")))
1063                                 (sha256 %null-sha256))))))
1064             (single-lint-warning-message (check-source pkg))))))))
1065
1066 (with-http-server '((404 "booh!"))
1067   (let* ((initial-url (%local-url))
1068          (redirect    (build-response #:code 301
1069                                       #:headers
1070                                       `((location
1071                                          . ,(string->uri initial-url))))))
1072     (parameterize ((%http-server-port 0))
1073       (with-http-server `((,redirect ""))
1074         (test-equal "source: 301 -> 404"
1075           (format #f "URI ~a not reachable: 404 (\"Such is life\")"
1076                   (%local-url))
1077           (let ((pkg (package
1078                        (inherit (dummy-package "x"))
1079                        (source (origin
1080                                  (method url-fetch)
1081                                  (uri (%local-url))
1082                                  (sha256 %null-sha256))))))
1083             (match (check-source pkg)
1084               ((first-warning ; The first warning says that all URI's are
1085                               ; unreachable
1086                 (and (? lint-warning?) second-warning))
1087                (lint-warning-message second-warning)))))))))
1088
1089 (test-equal "source: svn-reference, HTTP 200"
1090   '()
1091   (with-http-server `((200 ,%long-string))
1092     (let ((pkg (package
1093                  (inherit (dummy-package "x"))
1094                  (source (origin
1095                            (method svn-fetch)
1096                            (uri (svn-reference
1097                                  (url (%local-url))
1098                                  (revision 1234)))
1099                            (sha256 %null-sha256))))))
1100       (check-source pkg))))
1101
1102 (with-http-server `((404 ,%long-string))
1103   (test-equal "source: svn-reference, HTTP 404"
1104     (format #f "URI ~a not reachable: 404 (\"Such is life\")"
1105             (%local-url))
1106     (let ((pkg (package
1107                  (inherit (dummy-package "x"))
1108                  (source (origin
1109                            (method svn-fetch)
1110                            (uri (svn-reference
1111                                  (url (%local-url))
1112                                  (revision 1234)))
1113                            (sha256 %null-sha256))))))
1114       (match (check-source pkg)
1115         ((warning)
1116          (lint-warning-message warning))))))
1117
1118 (test-equal "mirror-url"
1119   '()
1120   (let ((source (origin
1121                   (method url-fetch)
1122                   (uri "http://example.org/foo/bar.tar.gz")
1123                   (sha256 %null-sha256))))
1124     (check-mirror-url (dummy-package "x" (source source)))))
1125
1126 (test-equal "mirror-url: one suggestion"
1127   "URL should be 'mirror://gnu/foo/foo.tar.gz'"
1128   (let ((source (origin
1129                   (method url-fetch)
1130                   (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
1131                   (sha256 %null-sha256))))
1132     (single-lint-warning-message
1133      (check-mirror-url (dummy-package "x" (source source))))))
1134
1135 (test-equal "mirror-url: kde suggestion"
1136   "URL should be 'mirror://kde/stable/gcompris/qt/src/gcompris-qt-2.3.tar.xz'"
1137   (let ((source (origin
1138                   (method url-fetch)
1139                   (uri "https://download.kde.org/stable/gcompris/qt/src/gcompris-qt-2.3.tar.xz")
1140                   (sha256 %null-sha256))))
1141     (single-lint-warning-message
1142      (check-mirror-url (dummy-package "x" (source source))))))
1143
1144 (test-equal "github-url"
1145   '()
1146   (with-http-server `((200 ,%long-string))
1147     (check-github-url
1148      (dummy-package "x" (source
1149                          (origin
1150                            (method url-fetch)
1151                            (uri (%local-url))
1152                            (sha256 %null-sha256)))))))
1153
1154 (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
1155   (test-equal "github-url: one suggestion"
1156     (string-append
1157      "URL should be '" github-url "'")
1158     (let ((redirect (build-response #:code 301
1159                                     #:headers
1160                                     `((location
1161                                        . ,(string->uri github-url))))))
1162       (with-http-server `((,redirect ""))
1163         (let* ((initial-url (%local-url))
1164                (redirect    (build-response #:code 302
1165                                             #:headers
1166                                             `((location
1167                                                . ,(string->uri initial-url))))))
1168           (parameterize ((%http-server-port 0))
1169             (with-http-server `((,redirect ""))
1170               (single-lint-warning-message
1171                (check-github-url
1172                 (dummy-package "x" (source
1173                                     (origin
1174                                       (method url-fetch)
1175                                       (uri (%local-url))
1176                                       (sha256 %null-sha256))))))))))))
1177
1178   (test-equal "github-url: already the correct github url"
1179     '()
1180     (check-github-url
1181      (dummy-package "x" (source
1182                          (origin
1183                            (method url-fetch)
1184                            (uri github-url)
1185                            (sha256 %null-sha256)))))))
1186
1187 (test-equal "cve"
1188   '()
1189   (mock ((guix lint) package-vulnerabilities (const '()))
1190         (check-vulnerabilities (dummy-package "x"))))
1191
1192 (test-equal "cve: one vulnerability"
1193   "probably vulnerable to CVE-2015-1234"
1194   (let ((dummy-vulnerabilities
1195          (lambda (package)
1196            (list (make-struct/no-tail
1197                   (@@ (guix cve) <vulnerability>)
1198                   "CVE-2015-1234"
1199                   (list (cons (package-name package)
1200                               (package-version package))))))))
1201     (single-lint-warning-message
1202      (check-vulnerabilities (dummy-package "pi" (version "3.14"))
1203                             dummy-vulnerabilities))))
1204
1205 (test-equal "cve: one patched vulnerability"
1206   '()
1207   (mock ((guix lint) package-vulnerabilities
1208          (lambda (package)
1209            (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
1210                                       "CVE-2015-1234"
1211                                       (list (cons (package-name package)
1212                                                   (package-version package)))))))
1213         (check-vulnerabilities
1214          (dummy-package "pi"
1215                         (version "3.14")
1216                         (source
1217                          (dummy-origin
1218                           (patches
1219                            (list "/a/b/pi-CVE-2015-1234.patch"))))))))
1220
1221 (test-equal "cve: known safe from vulnerability"
1222   '()
1223   (mock ((guix lint) package-vulnerabilities
1224          (lambda (package)
1225            (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
1226                                       "CVE-2015-1234"
1227                                       (list (cons (package-name package)
1228                                                   (package-version package)))))))
1229         (check-vulnerabilities
1230          (dummy-package "pi"
1231                         (version "3.14")
1232                         (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))
1233
1234 (test-equal "cve: vulnerability fixed in replacement version"
1235   '()
1236   (mock ((guix lint) package-vulnerabilities
1237          (lambda (package)
1238            (match (package-version package)
1239              ("0"
1240               (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
1241                                          "CVE-2015-1234"
1242                                          (list (cons (package-name package)
1243                                                      (package-version package))))))
1244              ("1"
1245               '()))))
1246         (check-vulnerabilities
1247          (dummy-package
1248           "foo" (version "0")
1249           (replacement (dummy-package "foo" (version "1")))))))
1250
1251 (test-equal "cve: patched vulnerability in replacement"
1252   '()
1253   (mock ((guix lint) package-vulnerabilities
1254          (lambda (package)
1255            (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
1256                                       "CVE-2015-1234"
1257                                       (list (cons (package-name package)
1258                                                   (package-version package)))))))
1259         (check-vulnerabilities
1260          (dummy-package
1261           "pi" (version "3.14") (source (dummy-origin))
1262           (replacement (dummy-package
1263                         "pi" (version "3.14")
1264                         (source
1265                          (dummy-origin
1266                           (patches
1267                            (list "/a/b/pi-CVE-2015-1234.patch"))))))))))
1268
1269 (test-equal "formatting: lonely parentheses"
1270   "parentheses feel lonely, move to the previous or next line"
1271   (single-lint-warning-message
1272    (check-formatting
1273     (dummy-package "ugly as hell!"
1274                    )
1275     )))
1276
1277 (test-assert "formatting: tabulation"
1278   (string-match-or-error
1279    "tabulation on line [0-9]+, column [0-9]+"
1280    (single-lint-warning-message
1281     (check-formatting (dummy-package "leave the tab here:       ")))))
1282
1283 (test-assert "formatting: trailing white space"
1284   (string-match-or-error
1285    "trailing white space .*"
1286    ;; Leave the trailing white space on the next line!
1287    (single-lint-warning-message
1288     (check-formatting (dummy-package "x")))))
1289
1290 (test-assert "formatting: long line"
1291   (string-match-or-error
1292    "line [0-9]+ is way too long \\([0-9]+ characters\\)"
1293    (single-lint-warning-message (check-formatting
1294            (dummy-package "x"))                                     ;here is a stupid comment just to make a long line
1295      )))
1296
1297 (test-equal "formatting: alright"
1298   '()
1299   (check-formatting (dummy-package "x")))
1300
1301 (test-assert "archival: missing content"
1302   (let* ((origin   (origin
1303                      (method url-fetch)
1304                      (uri "http://example.org/foo.tgz")
1305                      (sha256 (make-bytevector 32))))
1306          (warnings (with-http-server '((404 "Not archived.")
1307                                        (404 "Not in Disarchive database."))
1308                      (parameterize ((%swh-base-url (%local-url)))
1309                        (mock ((guix download) %disarchive-mirrors
1310                               (list (%local-url)))
1311                              (check-archival (dummy-package "x"
1312                                                             (source origin))))))))
1313     (warning-contains? "not archived" warnings)))
1314
1315 (test-equal "archival: content available"
1316   '()
1317   (let* ((origin   (origin
1318                      (method url-fetch)
1319                      (uri "http://example.org/foo.tgz")
1320                      (sha256 (make-bytevector 32))))
1321          ;; https://archive.softwareheritage.org/api/1/content/
1322          (content  "{ \"checksums\": {}, \"data_url\": \"xyz\",
1323                       \"length\": 42 }"))
1324     (with-http-server `((200 ,content))
1325       (parameterize ((%swh-base-url (%local-url)))
1326         (check-archival (dummy-package "x" (source origin)))))))
1327
1328 (test-equal "archival: content unavailable but disarchive available"
1329   '()
1330   (let* ((origin   (origin
1331                      (method url-fetch)
1332                      (uri "http://example.org/foo.tgz")
1333                      (sha256 (make-bytevector 32))))
1334          (disarchive (object->string
1335                       '(disarchive (version 0)
1336                                    ...
1337                                    "swh:1:dir:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
1338          ;; https://archive.softwareheritage.org/api/1/directory/
1339          (directory "[ { \"checksums\": {},
1340                          \"dir_id\": \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\",
1341                          \"type\": \"file\",
1342                          \"name\": \"README\"
1343                          \"length\": 42 } ]"))
1344     (with-http-server `((404 "")                  ;lookup-content
1345                         (200 ,disarchive)         ;Disarchive database lookup
1346                         (200 ,directory))         ;lookup-directory
1347       (mock ((guix download) %disarchive-mirrors (list (%local-url)))
1348             (parameterize ((%swh-base-url (%local-url)))
1349               (check-archival (dummy-package "x" (source origin))))))))
1350
1351 (test-assert "archival: missing revision"
1352   (let* ((origin   (origin
1353                      (method git-fetch)
1354                      (uri (git-reference
1355                            (url "http://example.org/foo.git")
1356                            (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
1357                      (sha256 (make-bytevector 32))))
1358          ;; https://archive.softwareheritage.org/api/1/origin/save/
1359          (save     "{ \"origin_url\": \"http://example.org/foo.git\",
1360                       \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
1361                       \"save_request_status\": \"accepted\",
1362                       \"save_task_status\": \"scheduled\" }")
1363          (warnings (with-http-server `((404 "No revision.") ;lookup-revision
1364                                        (404 "No origin.")   ;lookup-origin
1365                                        (200 ,save))         ;save-origin
1366                      (parameterize ((%swh-base-url (%local-url)))
1367                        (check-archival (dummy-package "x" (source origin)))))))
1368     (warning-contains? "scheduled" warnings)))
1369
1370 (test-equal "archival: revision available"
1371   '()
1372   (let* ((origin   (origin
1373                      (method git-fetch)
1374                      (uri (git-reference
1375                            (url "http://example.org/foo.git")
1376                            (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
1377                      (sha256 (make-bytevector 32))))
1378          ;; https://archive.softwareheritage.org/api/1/revision/
1379          (revision "{ \"author\": {}, \"parents\": [],
1380                       \"date\": \"2014-11-17T22:09:38+01:00\" }"))
1381     (with-http-server `((200 ,revision))
1382       (parameterize ((%swh-base-url (%local-url)))
1383         (check-archival (dummy-package "x" (source origin)))))))
1384
1385 (test-assert "archival: rate limit reached"
1386   ;; We should get a single warning stating that the rate limit was reached,
1387   ;; and nothing more, in particular no other HTTP requests.
1388   (let* ((origin   (origin
1389                      (method url-fetch)
1390                      (uri "http://example.org/foo.tgz")
1391                      (sha256 (make-bytevector 32))))
1392          (too-many (build-response
1393                     #:code 429
1394                     #:reason-phrase "Too many requests"
1395                     #:headers '((x-ratelimit-remaining . "0")
1396                                 (x-ratelimit-reset . "3000000000"))))
1397          (warnings (with-http-server `((,too-many "Rate limit reached."))
1398                      (parameterize ((%swh-base-url (%local-url)))
1399                        (append-map (lambda (name)
1400                                      (check-archival
1401                                       (dummy-package name (source origin))))
1402                                    '("x" "y" "z"))))))
1403     (string-contains (single-lint-warning-message warnings)
1404                      "rate limit reached")))
1405
1406 (test-assert "haskell-stackage"
1407   (let* ((stackage (string-append "{ \"packages\": [{"
1408                                   "    \"name\":\"pandoc\","
1409                                   "    \"synopsis\":\"synopsis\","
1410                                   "    \"version\":\"1.0\" }],"
1411                                   "  \"snapshot\": {"
1412                                   "    \"ghc\": \"8.6.5\","
1413                                   "    \"name\": \"lts-14.27\""
1414                                   "  }}"))
1415          (packages (map (lambda (version)
1416                           (dummy-package
1417                            "ghc-pandoc"
1418                            (version version)
1419                            (source
1420                             (dummy-origin
1421                              (method url-fetch)
1422                              (uri (string-append
1423                                    "https://hackage.haskell.org/package/"
1424                                    "pandoc-" version "/pandoc-" version ".tar.gz"))))))
1425                         '("0.9" "1.0" "100.0")))
1426          (warnings (pk (with-http-server `((200 ,stackage) ; memoized
1427                                            (200 "name: pandoc\nversion: 1.0\n")
1428                                            (200 "name: pandoc\nversion: 1.0\n")
1429                                            (200 "name: pandoc\nversion: 1.0\n"))
1430                          (parameterize ((%hackage-url (%local-url))
1431                                         (%stackage-url (%local-url)))
1432                            (append-map check-haskell-stackage packages))))))
1433     (match warnings
1434       (((? lint-warning? warning))
1435        (and (string=? (package-version (lint-warning-package warning)) "100.0")
1436             (string-contains (lint-warning-message warning)
1437                              "ahead of Stackage LTS version"))))))
1438
1439 (test-end "lint")
1440
1441 ;; Local Variables:
1442 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
1443 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
1444 ;; End: