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