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