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 Ludovic Courtès <ludo@gnu.org>
   5 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
   6 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
   7 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
   8 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
   9 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
  10 ;;;
  11 ;;; This file is part of GNU Guix.
  12 ;;;
  13 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  14 ;;; under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 3 of the License, or (at
  16 ;;; your option) any later version.
  17 ;;;
  18 ;;; GNU Guix is distributed in the hope that it will be useful, but
  19 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;; Avoid interference.
  27 (unsetenv "http_proxy")
  28
  29 (define-module (test-lint)
  30   #:use-module (guix tests)
  31   #:use-module (guix tests http)
  32   #:use-module (guix download)
  33   #:use-module (guix git-download)
  34   #:use-module (guix build-system gnu)
  35   #:use-module (guix packages)
  36   #:use-module (guix scripts lint)
  37   #:use-module (guix ui)
  38   #:use-module (gnu packages)
  39   #:use-module (gnu packages glib)
  40   #:use-module (gnu packages pkg-config)
  41   #:use-module (gnu packages python-xyz)
  42   #:use-module (web uri)
  43   #:use-module (web server)
  44   #:use-module (web server http)
  45   #:use-module (web response)
  46   #:use-module (ice-9 match)
  47   #:use-module (srfi srfi-9 gnu)
  48   #:use-module (srfi srfi-64))
  49
  50 ;; Test the linter.
  51
  52 ;; Avoid collisions with other tests.
  53 (%http-server-port 9999)
  54
  55 (define %null-sha256
  56   ;; SHA256 of the empty string.
  57   (base32
  58    "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
  59
  60 (define %long-string
  61   (make-string 2000 #\a))
  62
  63 \f
  64 (test-begin "lint")
  65
  66 (define (call-with-warnings thunk)
  67   (let ((port (open-output-string)))
  68     (parameterize ((guix-warning-port port))
  69       (thunk))
  70     (get-output-string port)))
  71
  72 (define-syntax-rule (with-warnings body ...)
  73   (call-with-warnings (lambda () body ...)))
  74
  75 (test-assert "description: not a string"
  76   (->bool
  77    (string-contains (with-warnings
  78                       (let ((pkg (dummy-package "x"
  79                                    (description 'foobar))))
  80                         (check-description-style pkg)))
  81                     "invalid description")))
  82
  83 (test-assert "description: not empty"
  84   (->bool
  85    (string-contains (with-warnings
  86                       (let ((pkg (dummy-package "x"
  87                                    (description ""))))
  88                         (check-description-style pkg)))
  89                     "description should not be empty")))
  90
  91 (test-assert "description: valid Texinfo markup"
  92   (->bool
  93    (string-contains
  94     (with-warnings
  95       (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
  96     "Texinfo markup in description is invalid")))
  97
  98 (test-assert "description: does not start with an upper-case letter"
  99   (->bool
 100    (string-contains (with-warnings
 101                       (let ((pkg (dummy-package "x"
 102                                    (description "bad description."))))
 103                         (check-description-style pkg)))
 104                     "description should start with an upper-case letter")))
 105
 106 (test-assert "description: may start with a digit"
 107   (string-null?
 108    (with-warnings
 109      (let ((pkg (dummy-package "x"
 110                   (description "2-component library."))))
 111        (check-description-style pkg)))))
 112
 113 (test-assert "description: may start with lower-case package name"
 114   (string-null?
 115    (with-warnings
 116      (let ((pkg (dummy-package "x"
 117                   (description "x is a dummy package."))))
 118        (check-description-style pkg)))))
 119
 120 (test-assert "description: two spaces after end of sentence"
 121   (->bool
 122    (string-contains (with-warnings
 123                       (let ((pkg (dummy-package "x"
 124                                    (description "Bad. Quite bad."))))
 125                         (check-description-style pkg)))
 126                     "sentences in description should be followed by two spaces")))
 127
 128 (test-assert "description: end-of-sentence detection with abbreviations"
 129   (string-null?
 130    (with-warnings
 131      (let ((pkg (dummy-package "x"
 132                   (description
 133                    "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
 134        (check-description-style pkg)))))
 135
 136 (test-assert "description: may not contain trademark signs"
 137   (and (->bool
 138         (string-contains (with-warnings
 139                            (let ((pkg (dummy-package "x"
 140                                         (description "Does The Right Thing™"))))
 141                              (check-description-style pkg)))
 142                          "should not contain trademark sign"))
 143        (->bool
 144         (string-contains (with-warnings
 145                            (let ((pkg (dummy-package "x"
 146                                         (description "Works with Format®"))))
 147                              (check-description-style pkg)))
 148                          "should not contain trademark sign"))))
 149
 150 (test-assert "description: suggest ornament instead of quotes"
 151   (->bool
 152    (string-contains (with-warnings
 153                       (let ((pkg (dummy-package "x"
 154                                    (description "This is a 'quoted' thing."))))
 155                         (check-description-style pkg)))
 156                     "use @code")))
 157
 158 (test-assert "synopsis: not a string"
 159   (->bool
 160    (string-contains (with-warnings
 161                       (let ((pkg (dummy-package "x"
 162                                    (synopsis #f))))
 163                         (check-synopsis-style pkg)))
 164                     "invalid synopsis")))
 165
 166 (test-assert "synopsis: not empty"
 167   (->bool
 168    (string-contains (with-warnings
 169                       (let ((pkg (dummy-package "x"
 170                                    (synopsis ""))))
 171                         (check-synopsis-style pkg)))
 172                     "synopsis should not be empty")))
 173
 174 (test-assert "synopsis: valid Texinfo markup"
 175   (->bool
 176    (string-contains
 177     (with-warnings
 178       (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
 179     "Texinfo markup in synopsis is invalid")))
 180
 181 (test-assert "synopsis: does not start with an upper-case letter"
 182   (->bool
 183    (string-contains (with-warnings
 184                       (let ((pkg (dummy-package "x"
 185                                    (synopsis "bad synopsis."))))
 186                         (check-synopsis-style pkg)))
 187                     "synopsis should start with an upper-case letter")))
 188
 189 (test-assert "synopsis: may start with a digit"
 190   (string-null?
 191    (with-warnings
 192      (let ((pkg (dummy-package "x"
 193                   (synopsis "5-dimensional frobnicator"))))
 194        (check-synopsis-style pkg)))))
 195
 196 (test-assert "synopsis: ends with a period"
 197   (->bool
 198    (string-contains (with-warnings
 199                       (let ((pkg (dummy-package "x"
 200                                    (synopsis "Bad synopsis."))))
 201                         (check-synopsis-style pkg)))
 202                     "no period allowed at the end of the synopsis")))
 203
 204 (test-assert "synopsis: ends with 'etc.'"
 205   (string-null? (with-warnings
 206                   (let ((pkg (dummy-package "x"
 207                                (synopsis "Foo, bar, etc."))))
 208                     (check-synopsis-style pkg)))))
 209
 210 (test-assert "synopsis: starts with 'A'"
 211   (->bool
 212    (string-contains (with-warnings
 213                       (let ((pkg (dummy-package "x"
 214                                    (synopsis "A bad synopŝis"))))
 215                         (check-synopsis-style pkg)))
 216                     "no article allowed at the beginning of the synopsis")))
 217
 218 (test-assert "synopsis: starts with 'An'"
 219   (->bool
 220    (string-contains (with-warnings
 221                       (let ((pkg (dummy-package "x"
 222                                    (synopsis "An awful synopsis"))))
 223                         (check-synopsis-style pkg)))
 224                     "no article allowed at the beginning of the synopsis")))
 225
 226 (test-assert "synopsis: starts with 'a'"
 227   (->bool
 228    (string-contains (with-warnings
 229                       (let ((pkg (dummy-package "x"
 230                                    (synopsis "a bad synopsis"))))
 231                         (check-synopsis-style pkg)))
 232                     "no article allowed at the beginning of the synopsis")))
 233
 234 (test-assert "synopsis: starts with 'an'"
 235   (->bool
 236    (string-contains (with-warnings
 237                       (let ((pkg (dummy-package "x"
 238                                    (synopsis "an awful synopsis"))))
 239                         (check-synopsis-style pkg)))
 240                     "no article allowed at the beginning of the synopsis")))
 241
 242 (test-assert "synopsis: too long"
 243   (->bool
 244    (string-contains (with-warnings
 245                       (let ((pkg (dummy-package "x"
 246                                    (synopsis (make-string 80 #\x)))))
 247                         (check-synopsis-style pkg)))
 248                     "synopsis should be less than 80 characters long")))
 249
 250 (test-assert "synopsis: start with package name"
 251   (->bool
 252    (string-contains (with-warnings
 253                       (let ((pkg (dummy-package "x"
 254                                    (name "foo")
 255                                    (synopsis "foo, a nice package"))))
 256                         (check-synopsis-style pkg)))
 257                     "synopsis should not start with the package name")))
 258
 259 (test-assert "synopsis: start with package name prefix"
 260   (string-null?
 261    (with-warnings
 262      (let ((pkg (dummy-package "arb"
 263                   (synopsis "Arbitrary precision"))))
 264        (check-synopsis-style pkg)))))
 265
 266 (test-assert "synopsis: start with abbreviation"
 267   (string-null?
 268    (with-warnings
 269      (let ((pkg (dummy-package "uucp"
 270                   ;; Same problem with "APL interpreter", etc.
 271                   (synopsis "UUCP implementation")
 272                   (description "Imagine this is Taylor UUCP."))))
 273        (check-synopsis-style pkg)))))
 274
 275 (test-assert "inputs: pkg-config is probably a native input"
 276   (->bool
 277    (string-contains
 278      (with-warnings
 279        (let ((pkg (dummy-package "x"
 280                     (inputs `(("pkg-config" ,pkg-config))))))
 281          (check-inputs-should-be-native pkg)))
 282          "'pkg-config' should probably be a native input")))
 283
 284 (test-assert "inputs: glib:bin is probably a native input"
 285   (->bool
 286     (string-contains
 287       (with-warnings
 288         (let ((pkg (dummy-package "x"
 289                      (inputs `(("glib" ,glib "bin"))))))
 290           (check-inputs-should-be-native pkg)))
 291           "'glib:bin' should probably be a native input")))
 292
 293 (test-assert
 294     "inputs: python-setuptools should not be an input at all (input)"
 295   (->bool
 296    (string-contains
 297      (with-warnings
 298        (let ((pkg (dummy-package "x"
 299                     (inputs `(("python-setuptools" ,python-setuptools))))))
 300          (check-inputs-should-not-be-an-input-at-all pkg)))
 301          "'python-setuptools' should probably not be an input at all")))
 302
 303 (test-assert
 304     "inputs: python-setuptools should not be an input at all (native-input)"
 305   (->bool
 306    (string-contains
 307      (with-warnings
 308        (let ((pkg (dummy-package "x"
 309                     (native-inputs
 310                      `(("python-setuptools" ,python-setuptools))))))
 311          (check-inputs-should-not-be-an-input-at-all pkg)))
 312          "'python-setuptools' should probably not be an input at all")))
 313
 314 (test-assert
 315     "inputs: python-setuptools should not be an input at all (propagated-input)"
 316   (->bool
 317    (string-contains
 318      (with-warnings
 319        (let ((pkg (dummy-package "x"
 320                     (propagated-inputs
 321                      `(("python-setuptools" ,python-setuptools))))))
 322          (check-inputs-should-not-be-an-input-at-all pkg)))
 323          "'python-setuptools' should probably not be an input at all")))
 324
 325 (test-assert "patches: file names"
 326   (->bool
 327    (string-contains
 328      (with-warnings
 329        (let ((pkg (dummy-package "x"
 330                     (source
 331                      (dummy-origin
 332                        (patches (list "/path/to/y.patch")))))))
 333          (check-patch-file-names pkg)))
 334      "file names of patches should start with the package name")))
 335
 336 (test-assert "patches: file name too long"
 337   (->bool
 338    (string-contains
 339      (with-warnings
 340        (let ((pkg (dummy-package "x"
 341                     (source
 342                      (dummy-origin
 343                       (patches (list (string-append "x-"
 344                                                     (make-string 100 #\a)
 345                                                     ".patch"))))))))
 346          (check-patch-file-names pkg)))
 347      "file name is too long")))
 348
 349 (test-assert "patches: not found"
 350   (->bool
 351    (string-contains
 352      (with-warnings
 353        (let ((pkg (dummy-package "x"
 354                     (source
 355                      (dummy-origin
 356                        (patches
 357                         (list (search-patch "this-patch-does-not-exist!"))))))))
 358          (check-patch-file-names pkg)))
 359      "patch not found")))
 360
 361 (test-assert "derivation: invalid arguments"
 362   (->bool
 363    (string-contains
 364     (with-warnings
 365       (let ((pkg (dummy-package "x"
 366                    (arguments
 367                     '(#:imported-modules (invalid-module))))))
 368         (check-derivation pkg)))
 369     "failed to create")))
 370
 371 (test-assert "license: invalid license"
 372   (string-contains
 373    (with-warnings
 374      (check-license (dummy-package "x" (license #f))))
 375    "invalid license"))
 376
 377 (test-assert "home-page: wrong home-page"
 378   (->bool
 379    (string-contains
 380     (with-warnings
 381       (let ((pkg (package
 382                    (inherit (dummy-package "x"))
 383                    (home-page #f))))
 384         (check-home-page pkg)))
 385     "invalid")))
 386
 387 (test-assert "home-page: invalid URI"
 388   (->bool
 389    (string-contains
 390     (with-warnings
 391       (let ((pkg (package
 392                    (inherit (dummy-package "x"))
 393                    (home-page "foobar"))))
 394         (check-home-page pkg)))
 395     "invalid home page URL")))
 396
 397 (test-assert "home-page: host not found"
 398   (->bool
 399    (string-contains
 400     (with-warnings
 401       (let ((pkg (package
 402                    (inherit (dummy-package "x"))
 403                    (home-page "http://does-not-exist"))))
 404         (check-home-page pkg)))
 405     "domain not found")))
 406
 407 (test-skip (if (http-server-can-listen?) 0 1))
 408 (test-assert "home-page: Connection refused"
 409   (->bool
 410    (string-contains
 411     (with-warnings
 412       (let ((pkg (package
 413                    (inherit (dummy-package "x"))
 414                    (home-page (%local-url)))))
 415         (check-home-page pkg)))
 416     "Connection refused")))
 417
 418 (test-skip (if (http-server-can-listen?) 0 1))
 419 (test-equal "home-page: 200"
 420   ""
 421   (with-warnings
 422    (with-http-server 200 %long-string
 423      (let ((pkg (package
 424                   (inherit (dummy-package "x"))
 425                   (home-page (%local-url)))))
 426        (check-home-page pkg)))))
 427
 428 (test-skip (if (http-server-can-listen?) 0 1))
 429 (test-assert "home-page: 200 but short length"
 430   (->bool
 431    (string-contains
 432     (with-warnings
 433       (with-http-server 200 "This is too small."
 434         (let ((pkg (package
 435                      (inherit (dummy-package "x"))
 436                      (home-page (%local-url)))))
 437           (check-home-page pkg))))
 438     "suspiciously small")))
 439
 440 (test-skip (if (http-server-can-listen?) 0 1))
 441 (test-assert "home-page: 404"
 442   (->bool
 443    (string-contains
 444     (with-warnings
 445       (with-http-server 404 %long-string
 446         (let ((pkg (package
 447                      (inherit (dummy-package "x"))
 448                      (home-page (%local-url)))))
 449           (check-home-page pkg))))
 450     "not reachable: 404")))
 451
 452 (test-skip (if (http-server-can-listen?) 0 1))
 453 (test-assert "home-page: 301, invalid"
 454   (->bool
 455    (string-contains
 456     (with-warnings
 457       (with-http-server 301 %long-string
 458         (let ((pkg (package
 459                      (inherit (dummy-package "x"))
 460                      (home-page (%local-url)))))
 461           (check-home-page pkg))))
 462     "invalid permanent redirect")))
 463
 464 (test-skip (if (http-server-can-listen?) 0 1))
 465 (test-assert "home-page: 301 -> 200"
 466   (->bool
 467    (string-contains
 468     (with-warnings
 469       (with-http-server 200 %long-string
 470         (let ((initial-url (%local-url)))
 471           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 472             (with-http-server (301 `((location
 473                                       . ,(string->uri initial-url))))
 474                 ""
 475               (let ((pkg (package
 476                            (inherit (dummy-package "x"))
 477                            (home-page (%local-url)))))
 478                 (check-home-page pkg)))))))
 479     "permanent redirect")))
 480
 481 (test-skip (if (http-server-can-listen?) 0 1))
 482 (test-assert "home-page: 301 -> 404"
 483   (->bool
 484    (string-contains
 485     (with-warnings
 486       (with-http-server 404 "booh!"
 487         (let ((initial-url (%local-url)))
 488           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 489             (with-http-server (301 `((location
 490                                       . ,(string->uri initial-url))))
 491                 ""
 492               (let ((pkg (package
 493                            (inherit (dummy-package "x"))
 494                            (home-page (%local-url)))))
 495                 (check-home-page pkg)))))))
 496     "not reachable: 404")))
 497
 498 (test-assert "source-file-name"
 499   (->bool
 500    (string-contains
 501     (with-warnings
 502       (let ((pkg (dummy-package "x"
 503                    (version "3.2.1")
 504                    (source
 505                     (origin
 506                       (method url-fetch)
 507                       (uri "http://www.example.com/3.2.1.tar.gz")
 508                       (sha256 %null-sha256))))))
 509         (check-source-file-name pkg)))
 510     "file name should contain the package name")))
 511
 512 (test-assert "source-file-name: v prefix"
 513   (->bool
 514    (string-contains
 515     (with-warnings
 516       (let ((pkg (dummy-package "x"
 517                    (version "3.2.1")
 518                    (source
 519                     (origin
 520                       (method url-fetch)
 521                       (uri "http://www.example.com/v3.2.1.tar.gz")
 522                       (sha256 %null-sha256))))))
 523         (check-source-file-name pkg)))
 524     "file name should contain the package name")))
 525
 526 (test-assert "source-file-name: bad checkout"
 527   (->bool
 528    (string-contains
 529     (with-warnings
 530       (let ((pkg (dummy-package "x"
 531                    (version "3.2.1")
 532                    (source
 533                     (origin
 534                       (method git-fetch)
 535                       (uri (git-reference
 536                             (url "http://www.example.com/x.git")
 537                             (commit "0")))
 538                       (sha256 %null-sha256))))))
 539         (check-source-file-name pkg)))
 540     "file name should contain the package name")))
 541
 542 (test-assert "source-file-name: good checkout"
 543   (not
 544    (->bool
 545     (string-contains
 546      (with-warnings
 547        (let ((pkg (dummy-package "x"
 548                     (version "3.2.1")
 549                     (source
 550                      (origin
 551                        (method git-fetch)
 552                        (uri (git-reference
 553                              (url "http://git.example.com/x.git")
 554                              (commit "0")))
 555                        (file-name (string-append "x-" version))
 556                        (sha256 %null-sha256))))))
 557          (check-source-file-name pkg)))
 558      "file name should contain the package name"))))
 559
 560 (test-assert "source-file-name: valid"
 561   (not
 562    (->bool
 563     (string-contains
 564      (with-warnings
 565        (let ((pkg (dummy-package "x"
 566                     (version "3.2.1")
 567                     (source
 568                      (origin
 569                        (method url-fetch)
 570                        (uri "http://www.example.com/x-3.2.1.tar.gz")
 571                        (sha256 %null-sha256))))))
 572          (check-source-file-name pkg)))
 573      "file name should contain the package name"))))
 574
 575 (test-assert "source-unstable-tarball"
 576   (string-contains
 577    (with-warnings
 578      (let ((pkg (dummy-package "x"
 579                   (source
 580                     (origin
 581                       (method url-fetch)
 582                       (uri "https://github.com/example/example/archive/v0.0.tar.gz")
 583                       (sha256 %null-sha256))))))
 584        (check-source-unstable-tarball pkg)))
 585    "source URI should not be an autogenerated tarball"))
 586
 587 (test-assert "source-unstable-tarball: source #f"
 588   (not
 589     (->bool
 590      (string-contains
 591       (with-warnings
 592         (let ((pkg (dummy-package "x"
 593                      (source #f))))
 594           (check-source-unstable-tarball pkg)))
 595       "source URI should not be an autogenerated tarball"))))
 596
 597 (test-assert "source-unstable-tarball: valid"
 598   (not
 599     (->bool
 600      (string-contains
 601       (with-warnings
 602         (let ((pkg (dummy-package "x"
 603                      (source
 604                        (origin
 605                          (method url-fetch)
 606                          (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
 607                          (sha256 %null-sha256))))))
 608           (check-source-unstable-tarball pkg)))
 609       "source URI should not be an autogenerated tarball"))))
 610
 611 (test-assert "source-unstable-tarball: package named archive"
 612   (not
 613     (->bool
 614      (string-contains
 615       (with-warnings
 616         (let ((pkg (dummy-package "x"
 617                      (source
 618                        (origin
 619                          (method url-fetch)
 620                          (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
 621                          (sha256 %null-sha256))))))
 622           (check-source-unstable-tarball pkg)))
 623       "source URI should not be an autogenerated tarball"))))
 624
 625 (test-assert "source-unstable-tarball: not-github"
 626   (not
 627     (->bool
 628      (string-contains
 629       (with-warnings
 630         (let ((pkg (dummy-package "x"
 631                      (source
 632                        (origin
 633                          (method url-fetch)
 634                          (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
 635                          (sha256 %null-sha256))))))
 636           (check-source-unstable-tarball pkg)))
 637       "source URI should not be an autogenerated tarball"))))
 638
 639 (test-assert "source-unstable-tarball: git-fetch"
 640   (not
 641     (->bool
 642      (string-contains
 643       (with-warnings
 644         (let ((pkg (dummy-package "x"
 645                      (source
 646                        (origin
 647                          (method git-fetch)
 648                          (uri (git-reference
 649                                 (url "https://github.com/archive/example.git")
 650                                 (commit "0")))
 651                          (sha256 %null-sha256))))))
 652           (check-source-unstable-tarball pkg)))
 653       "source URI should not be an autogenerated tarball"))))
 654
 655 (test-skip (if (http-server-can-listen?) 0 1))
 656 (test-equal "source: 200"
 657   ""
 658   (with-warnings
 659    (with-http-server 200 %long-string
 660      (let ((pkg (package
 661                   (inherit (dummy-package "x"))
 662                   (source (origin
 663                             (method url-fetch)
 664                             (uri (%local-url))
 665                             (sha256 %null-sha256))))))
 666        (check-source pkg)))))
 667
 668 (test-skip (if (http-server-can-listen?) 0 1))
 669 (test-assert "source: 200 but short length"
 670   (->bool
 671    (string-contains
 672     (with-warnings
 673       (with-http-server 200 "This is too small."
 674         (let ((pkg (package
 675                      (inherit (dummy-package "x"))
 676                      (source (origin
 677                                (method url-fetch)
 678                                (uri (%local-url))
 679                                (sha256 %null-sha256))))))
 680           (check-source pkg))))
 681     "suspiciously small")))
 682
 683 (test-skip (if (http-server-can-listen?) 0 1))
 684 (test-assert "source: 404"
 685   (->bool
 686    (string-contains
 687     (with-warnings
 688       (with-http-server 404 %long-string
 689         (let ((pkg (package
 690                      (inherit (dummy-package "x"))
 691                      (source (origin
 692                                (method url-fetch)
 693                                (uri (%local-url))
 694                                (sha256 %null-sha256))))))
 695           (check-source pkg))))
 696     "not reachable: 404")))
 697
 698 (test-skip (if (http-server-can-listen?) 0 1))
 699 (test-equal "source: 301 -> 200"
 700   ""
 701   (with-warnings
 702     (with-http-server 200 %long-string
 703       (let ((initial-url (%local-url)))
 704         (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 705           (with-http-server (301 `((location . ,(string->uri initial-url))))
 706               ""
 707             (let ((pkg (package
 708                          (inherit (dummy-package "x"))
 709                          (source (origin
 710                                    (method url-fetch)
 711                                    (uri (%local-url))
 712                                    (sha256 %null-sha256))))))
 713               (check-source pkg))))))))
 714
 715 (test-skip (if (http-server-can-listen?) 0 1))
 716 (test-assert "source: 301 -> 404"
 717   (->bool
 718    (string-contains
 719     (with-warnings
 720       (with-http-server 404 "booh!"
 721         (let ((initial-url (%local-url)))
 722           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 723             (with-http-server (301 `((location . ,(string->uri initial-url))))
 724                 ""
 725               (let ((pkg (package
 726                            (inherit (dummy-package "x"))
 727                            (source (origin
 728                                      (method url-fetch)
 729                                      (uri (%local-url))
 730                                      (sha256 %null-sha256))))))
 731                 (check-source pkg)))))))
 732     "not reachable: 404")))
 733
 734 (test-assert "mirror-url"
 735   (string-null?
 736    (with-warnings
 737      (let ((source (origin
 738                      (method url-fetch)
 739                      (uri "http://example.org/foo/bar.tar.gz")
 740                      (sha256 %null-sha256))))
 741        (check-mirror-url (dummy-package "x" (source source)))))))
 742
 743 (test-assert "mirror-url: one suggestion"
 744   (string-contains
 745    (with-warnings
 746      (let ((source (origin
 747                      (method url-fetch)
 748                      (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
 749                      (sha256 %null-sha256))))
 750        (check-mirror-url (dummy-package "x" (source source)))))
 751    "mirror://gnu/foo/foo.tar.gz"))
 752
 753 (test-assert "github-url"
 754   (string-null?
 755    (with-warnings
 756      (with-http-server 200 %long-string
 757        (check-github-url
 758         (dummy-package "x" (source
 759                             (origin
 760                               (method url-fetch)
 761                               (uri (%local-url))
 762                               (sha256 %null-sha256)))))))))
 763
 764 (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
 765   (test-assert "github-url: one suggestion"
 766     (string-contains
 767      (with-warnings
 768        (with-http-server (301 `((location . ,(string->uri github-url)))) ""
 769          (let ((initial-uri (%local-url)))
 770            (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 771              (with-http-server (302 `((location . ,(string->uri initial-uri)))) ""
 772                (check-github-url
 773                 (dummy-package "x" (source
 774                                     (origin
 775                                       (method url-fetch)
 776                                       (uri (%local-url))
 777                                       (sha256 %null-sha256))))))))))
 778      github-url))
 779   (test-assert "github-url: already the correct github url"
 780     (string-null?
 781      (with-warnings
 782        (check-github-url
 783         (dummy-package "x" (source
 784                             (origin
 785                               (method url-fetch)
 786                               (uri github-url)
 787                               (sha256 %null-sha256)))))))))
 788
 789 (test-assert "cve"
 790   (mock ((guix scripts lint) package-vulnerabilities (const '()))
 791         (string-null?
 792          (with-warnings (check-vulnerabilities (dummy-package "x"))))))
 793
 794 (test-assert "cve: one vulnerability"
 795   (mock ((guix scripts lint) package-vulnerabilities
 796          (lambda (package)
 797            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 798                               "CVE-2015-1234"
 799                               (list (cons (package-name package)
 800                                           (package-version package)))))))
 801         (string-contains
 802          (with-warnings
 803            (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
 804          "vulnerable to CVE-2015-1234")))
 805
 806 (test-assert "cve: one patched vulnerability"
 807   (mock ((guix scripts lint) package-vulnerabilities
 808          (lambda (package)
 809            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 810                               "CVE-2015-1234"
 811                               (list (cons (package-name package)
 812                                           (package-version package)))))))
 813         (string-null?
 814          (with-warnings
 815            (check-vulnerabilities
 816             (dummy-package "pi"
 817                            (version "3.14")
 818                            (source
 819                             (dummy-origin
 820                              (patches
 821                               (list "/a/b/pi-CVE-2015-1234.patch"))))))))))
 822
 823 (test-assert "cve: known safe from vulnerability"
 824   (mock ((guix scripts lint) package-vulnerabilities
 825          (lambda (package)
 826            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 827                               "CVE-2015-1234"
 828                               (list (cons (package-name package)
 829                                           (package-version package)))))))
 830         (string-null?
 831          (with-warnings
 832            (check-vulnerabilities
 833             (dummy-package "pi"
 834                            (version "3.14")
 835                            (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))
 836
 837 (test-assert "cve: vulnerability fixed in replacement version"
 838   (mock ((guix scripts lint) package-vulnerabilities
 839          (lambda (package)
 840            (match (package-version package)
 841              ("0"
 842               (list (make-struct (@@ (guix cve) <vulnerability>) 0
 843                                  "CVE-2015-1234"
 844                                  (list (cons (package-name package)
 845                                              (package-version package))))))
 846              ("1"
 847               '()))))
 848         (and (not (string-null?
 849                    (with-warnings
 850                      (check-vulnerabilities
 851                       (dummy-package "foo" (version "0"))))))
 852              (string-null?
 853               (with-warnings
 854                 (check-vulnerabilities
 855                  (dummy-package
 856                   "foo" (version "0")
 857                   (replacement (dummy-package "foo" (version "1"))))))))))
 858
 859 (test-assert "cve: patched vulnerability in replacement"
 860   (mock ((guix scripts lint) package-vulnerabilities
 861          (lambda (package)
 862            (list (make-struct (@@ (guix cve) <vulnerability>) 0
 863                               "CVE-2015-1234"
 864                               (list (cons (package-name package)
 865                                           (package-version package)))))))
 866         (string-null?
 867          (with-warnings
 868            (check-vulnerabilities
 869             (dummy-package
 870              "pi" (version "3.14") (source (dummy-origin))
 871              (replacement (dummy-package
 872                            "pi" (version "3.14")
 873                            (source
 874                             (dummy-origin
 875                              (patches
 876                               (list "/a/b/pi-CVE-2015-1234.patch"))))))))))))
 877
 878 (test-assert "formatting: lonely parentheses"
 879   (string-contains
 880    (with-warnings
 881      (check-formatting
 882       (
 883        dummy-package "ugly as hell!"
 884       )
 885       ))
 886    "lonely"))
 887
 888 (test-assert "formatting: tabulation"
 889   (string-contains
 890    (with-warnings
 891      (check-formatting (dummy-package "leave the tab here:      ")))
 892    "tabulation"))
 893
 894 (test-assert "formatting: trailing white space"
 895   (string-contains
 896    (with-warnings
 897      ;; Leave the trailing white space on the next line!
 898      (check-formatting (dummy-package "x")))
 899    "trailing white space"))
 900
 901 (test-assert "formatting: long line"
 902   (string-contains
 903    (with-warnings
 904      (check-formatting
 905       (dummy-package "x"                          ;here is a stupid comment just to make a long line
 906                      )))
 907    "too long"))
 908
 909 (test-assert "formatting: alright"
 910   (string-null?
 911    (with-warnings
 912      (check-formatting (dummy-package "x")))))
 913
 914 (test-end "lint")
 915
 916 ;; Local Variables:
 917 ;; eval: (put 'with-http-server 'scheme-indent-function 2)
 918 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 919 ;; End: