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