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 "patches: file names"
 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 "patches: file name too long"
 328   (string-append "x-"
 329                  (make-string 100 #\a)
 330                  ".patch: file name is too long")
 331   (single-lint-warning-message
 332    (let ((pkg (dummy-package
 333                "x"
 334                (source
 335                 (dummy-origin
 336                  (patches (list (string-append "x-"
 337                                                (make-string 100 #\a)
 338                                                ".patch"))))))))
 339      (check-patch-file-names pkg))))
 340
 341 (test-equal "patches: not found"
 342   "this-patch-does-not-exist!: patch not found\n"
 343   (single-lint-warning-message
 344    (let ((pkg (dummy-package
 345                "x"
 346                (source
 347                 (dummy-origin
 348                  (patches
 349                   (list (search-patch "this-patch-does-not-exist!"))))))))
 350      (check-patch-file-names pkg))))
 351
 352 (test-assert "patch headers: no warnings"
 353   (call-with-temporary-directory
 354    (lambda (directory)
 355      (call-with-output-file (string-append directory "/t.patch")
 356        (lambda (port)
 357          (display "This is a patch.\n\n--- a\n+++ b\n"
 358                   port)))
 359
 360      (parameterize ((%patch-path (list directory)))
 361        (let ((pkg (dummy-package "x"
 362                     (source (dummy-origin
 363                              (patches (search-patches "t.patch")))))))
 364          (null? (check-patch-headers pkg)))))))
 365
 366 (test-equal "patch headers: missing comment"
 367   "t.patch: patch lacks comment and upstream status"
 368   (call-with-temporary-directory
 369    (lambda (directory)
 370      (call-with-output-file (string-append directory "/t.patch")
 371        (lambda (port)
 372          (display "\n--- a\n+++ b\n"
 373                   port)))
 374
 375      (parameterize ((%patch-path (list directory)))
 376        (let ((pkg (dummy-package "x"
 377                     (source (dummy-origin
 378                              (patches (search-patches "t.patch")))))))
 379          (single-lint-warning-message (check-patch-headers pkg)))))))
 380
 381 (test-equal "patch headers: empty"
 382   "t.patch: empty patch"
 383   (call-with-temporary-directory
 384    (lambda (directory)
 385      (call-with-output-file (string-append directory "/t.patch")
 386        (const #t))
 387
 388      (parameterize ((%patch-path '()))
 389        (let ((pkg (dummy-package "x"
 390                     (source (dummy-origin
 391                              (patches
 392                               (list (local-file
 393                                      (string-append directory
 394                                                     "/t.patch")))))))))
 395          (single-lint-warning-message (check-patch-headers pkg)))))))
 396
 397 (test-equal "patch headers: patch not found"
 398   "does-not-exist.patch: patch not found\n"
 399   (parameterize ((%patch-path '()))
 400     (let ((pkg (dummy-package "x"
 401                  (source (dummy-origin
 402                           (patches
 403                            (search-patches "does-not-exist.patch")))))))
 404       (single-lint-warning-message (check-patch-headers pkg)))))
 405
 406 (test-equal "derivation: invalid arguments"
 407   "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())"
 408   (match (let ((pkg (dummy-package "x"
 409                                    (arguments
 410                                     '(#:imported-modules (invalid-module))))))
 411            (check-derivation pkg))
 412     (((and (? lint-warning?) first-warning) others ...)
 413      (lint-warning-message first-warning))))
 414
 415 (test-equal "profile-collisions: no warnings"
 416   '()
 417   (check-profile-collisions (dummy-package "x")))
 418
 419 (test-equal "profile-collisions: propagated inputs collide"
 420   "propagated inputs p0@1 and p0@2 collide"
 421   (let* ((p0  (dummy-package "p0" (version "1")))
 422          (p0* (dummy-package "p0" (version "2")))
 423          (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
 424          (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
 425          (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
 426          (p4  (dummy-package "p4" (propagated-inputs
 427                                    `(("p2" ,p2) ("p3", p3))))))
 428     (single-lint-warning-message
 429      (check-profile-collisions p4))))
 430
 431 (test-assert "profile-collisions: propagated inputs collide, store items"
 432   (string-match-or-error
 433    "propagated inputs /[[:graph:]]+-p0-1 and /[[:graph:]]+-p0-1 collide"
 434    (let* ((p0  (dummy-package "p0" (version "1")))
 435           (p0* (dummy-package "p0" (version "1")
 436                               (inputs `(("x" ,(dummy-package "x"))))))
 437           (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
 438           (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
 439           (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
 440           (p4  (dummy-package "p4" (propagated-inputs
 441                                     `(("p2" ,p2) ("p3", p3))))))
 442      (single-lint-warning-message
 443       (check-profile-collisions p4)))))
 444
 445 (test-equal "license: invalid license"
 446   "invalid license field"
 447   (single-lint-warning-message
 448    (check-license (dummy-package "x" (license #f)))))
 449
 450 (test-equal "home-page: wrong home-page"
 451   "invalid value for home page"
 452   (let ((pkg (package
 453                (inherit (dummy-package "x"))
 454                (home-page #f))))
 455     (single-lint-warning-message
 456      (check-home-page pkg))))
 457
 458 (test-equal "home-page: invalid URI"
 459   "invalid home page URL: \"foobar\""
 460   (let ((pkg (package
 461                (inherit (dummy-package "x"))
 462                (home-page "foobar"))))
 463     (single-lint-warning-message
 464      (check-home-page pkg))))
 465
 466 (test-assert "home-page: host not found"
 467   (let ((pkg (package
 468                (inherit (dummy-package "x"))
 469                (home-page "http://does-not-exist"))))
 470     (warning-contains? "domain not found" (check-home-page pkg))))
 471
 472 (test-skip (if (http-server-can-listen?) 0 1))
 473 (test-equal "home-page: Connection refused"
 474   "URI http://localhost:9999/foo/bar unreachable: Connection refused"
 475   (let ((pkg (package
 476                (inherit (dummy-package "x"))
 477                (home-page (%local-url)))))
 478     (single-lint-warning-message
 479      (check-home-page pkg))))
 480
 481 (test-skip (if (http-server-can-listen?) 0 1))
 482 (test-equal "home-page: 200"
 483   '()
 484   (with-http-server `((200 ,%long-string))
 485     (let ((pkg (package
 486                  (inherit (dummy-package "x"))
 487                  (home-page (%local-url)))))
 488       (check-home-page pkg))))
 489
 490 (test-skip (if (http-server-can-listen?) 0 1))
 491 (test-equal "home-page: 200 but short length"
 492   "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
 493   (with-http-server `((200 "This is too small."))
 494     (let ((pkg (package
 495                  (inherit (dummy-package "x"))
 496                  (home-page (%local-url)))))
 497
 498       (single-lint-warning-message
 499        (check-home-page pkg)))))
 500
 501 (test-skip (if (http-server-can-listen?) 0 1))
 502 (test-equal "home-page: 404"
 503   "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
 504   (with-http-server `((404 ,%long-string))
 505     (let ((pkg (package
 506                  (inherit (dummy-package "x"))
 507                  (home-page (%local-url)))))
 508       (single-lint-warning-message
 509        (check-home-page pkg)))))
 510
 511 (test-skip (if (http-server-can-listen?) 0 1))
 512 (test-equal "home-page: 301, invalid"
 513   "invalid permanent redirect from http://localhost:9999/foo/bar"
 514   (with-http-server `((301 ,%long-string))
 515     (let ((pkg (package
 516                  (inherit (dummy-package "x"))
 517                  (home-page (%local-url)))))
 518       (single-lint-warning-message
 519        (check-home-page pkg)))))
 520
 521 (test-skip (if (http-server-can-listen?) 0 1))
 522 (test-equal "home-page: 301 -> 200"
 523   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
 524   (with-http-server `((200 ,%long-string))
 525     (let* ((initial-url (%local-url))
 526            (redirect    (build-response #:code 301
 527                                         #:headers
 528                                         `((location
 529                                            . ,(string->uri initial-url))))))
 530       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 531         (with-http-server `((,redirect ""))
 532           (let ((pkg (package
 533                        (inherit (dummy-package "x"))
 534                        (home-page (%local-url)))))
 535             (single-lint-warning-message
 536              (check-home-page pkg))))))))
 537
 538 (test-skip (if (http-server-can-listen?) 0 1))
 539 (test-equal "home-page: 301 -> 404"
 540   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
 541   (with-http-server '((404 "booh!"))
 542     (let* ((initial-url (%local-url))
 543            (redirect    (build-response #:code 301
 544                                         #:headers
 545                                         `((location
 546                                            . ,(string->uri initial-url))))))
 547       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 548         (with-http-server `((,redirect ""))
 549           (let ((pkg (package
 550                        (inherit (dummy-package "x"))
 551                        (home-page (%local-url)))))
 552             (single-lint-warning-message
 553              (check-home-page pkg))))))))
 554
 555
 556 (test-equal "source-file-name"
 557   "the source file name should contain the package name"
 558   (let ((pkg (dummy-package "x"
 559                             (version "3.2.1")
 560                             (source
 561                              (origin
 562                                (method url-fetch)
 563                                (uri "http://www.example.com/3.2.1.tar.gz")
 564                                (sha256 %null-sha256))))))
 565     (single-lint-warning-message
 566      (check-source-file-name pkg))))
 567
 568 (test-equal "source-file-name: v prefix"
 569   "the source file name should contain the package name"
 570   (let ((pkg (dummy-package "x"
 571                             (version "3.2.1")
 572                             (source
 573                              (origin
 574                                (method url-fetch)
 575                                (uri "http://www.example.com/v3.2.1.tar.gz")
 576                                (sha256 %null-sha256))))))
 577     (single-lint-warning-message
 578      (check-source-file-name pkg))))
 579
 580 (test-equal "source-file-name: bad checkout"
 581   "the source file name should contain the package name"
 582   (let ((pkg (dummy-package "x"
 583                             (version "3.2.1")
 584                             (source
 585                              (origin
 586                                (method git-fetch)
 587                                (uri (git-reference
 588                                      (url "http://www.example.com/x.git")
 589                                      (commit "0")))
 590                                (sha256 %null-sha256))))))
 591     (single-lint-warning-message
 592      (check-source-file-name pkg))))
 593
 594 (test-equal "source-file-name: good checkout"
 595   '()
 596   (let ((pkg (dummy-package "x"
 597                             (version "3.2.1")
 598                             (source
 599                              (origin
 600                                (method git-fetch)
 601                                (uri (git-reference
 602                                      (url "http://git.example.com/x.git")
 603                                      (commit "0")))
 604                                (file-name (string-append "x-" version))
 605                                (sha256 %null-sha256))))))
 606     (check-source-file-name pkg)))
 607
 608 (test-equal "source-file-name: valid"
 609   '()
 610   (let ((pkg (dummy-package "x"
 611                             (version "3.2.1")
 612                             (source
 613                              (origin
 614                                (method url-fetch)
 615                                (uri "http://www.example.com/x-3.2.1.tar.gz")
 616                                (sha256 %null-sha256))))))
 617     (check-source-file-name pkg)))
 618
 619 (test-equal "source-unstable-tarball"
 620   "the source URI should not be an autogenerated tarball"
 621   (let ((pkg (dummy-package "x"
 622                             (source
 623                              (origin
 624                                (method url-fetch)
 625                                (uri "https://github.com/example/example/archive/v0.0.tar.gz")
 626                                (sha256 %null-sha256))))))
 627     (single-lint-warning-message
 628      (check-source-unstable-tarball pkg))))
 629
 630 (test-equal "source-unstable-tarball: source #f"
 631   '()
 632   (let ((pkg (dummy-package "x"
 633                             (source #f))))
 634     (check-source-unstable-tarball pkg)))
 635
 636 (test-equal "source-unstable-tarball: valid"
 637   '()
 638   (let ((pkg (dummy-package "x"
 639                             (source
 640                              (origin
 641                                (method url-fetch)
 642                                (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
 643                                (sha256 %null-sha256))))))
 644     (check-source-unstable-tarball pkg)))
 645
 646 (test-equal "source-unstable-tarball: package named archive"
 647   '()
 648   (let ((pkg (dummy-package "x"
 649                             (source
 650                              (origin
 651                                (method url-fetch)
 652                                (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
 653                                (sha256 %null-sha256))))))
 654     (check-source-unstable-tarball pkg)))
 655
 656 (test-equal "source-unstable-tarball: not-github"
 657   '()
 658   (let ((pkg (dummy-package "x"
 659                             (source
 660                              (origin
 661                                (method url-fetch)
 662                                (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
 663                                (sha256 %null-sha256))))))
 664     (check-source-unstable-tarball pkg)))
 665
 666 (test-equal "source-unstable-tarball: git-fetch"
 667   '()
 668   (let ((pkg (dummy-package "x"
 669                             (source
 670                              (origin
 671                                (method git-fetch)
 672                                (uri (git-reference
 673                                      (url "https://github.com/archive/example")
 674                                      (commit "0")))
 675                                (sha256 %null-sha256))))))
 676     (check-source-unstable-tarball pkg)))
 677
 678 (test-skip (if (http-server-can-listen?) 0 1))
 679 (test-equal "source: 200"
 680   '()
 681   (with-http-server `((200 ,%long-string))
 682     (let ((pkg (package
 683                  (inherit (dummy-package "x"))
 684                  (source (origin
 685                            (method url-fetch)
 686                            (uri (%local-url))
 687                            (sha256 %null-sha256))))))
 688       (check-source pkg))))
 689
 690 (test-skip (if (http-server-can-listen?) 0 1))
 691 (test-equal "source: 200 but short length"
 692   "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
 693   (with-http-server '((200 "This is too small."))
 694     (let ((pkg (package
 695                  (inherit (dummy-package "x"))
 696                  (source (origin
 697                            (method url-fetch)
 698                            (uri (%local-url))
 699                            (sha256 %null-sha256))))))
 700       (match (check-source pkg)
 701         ((first-warning ; All source URIs are unreachable
 702           (and (? lint-warning?) second-warning))
 703          (lint-warning-message second-warning))))))
 704
 705 (test-skip (if (http-server-can-listen?) 0 1))
 706 (test-equal "source: 404"
 707   "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
 708   (with-http-server `((404 ,%long-string))
 709     (let ((pkg (package
 710                  (inherit (dummy-package "x"))
 711                  (source (origin
 712                            (method url-fetch)
 713                            (uri (%local-url))
 714                            (sha256 %null-sha256))))))
 715       (match (check-source pkg)
 716         ((first-warning ; All source URIs are unreachable
 717           (and (? lint-warning?) second-warning))
 718          (lint-warning-message second-warning))))))
 719
 720 (test-skip (if (http-server-can-listen?) 0 1))
 721 (test-equal "source: 404 and 200"
 722   '()
 723   (with-http-server `((404 ,%long-string))
 724     (let ((bad-url (%local-url)))
 725       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 726         (with-http-server `((200 ,%long-string))
 727           (let ((pkg (package
 728                        (inherit (dummy-package "x"))
 729                        (source (origin
 730                                  (method url-fetch)
 731                                  (uri (list bad-url (%local-url)))
 732                                  (sha256 %null-sha256))))))
 733             ;; Since one of the two URLs is good, this should return the empty
 734             ;; list.
 735             (check-source pkg)))))))
 736
 737 (test-skip (if (http-server-can-listen?) 0 1))
 738 (test-equal "source: 301 -> 200"
 739   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
 740   (with-http-server `((200 ,%long-string))
 741     (let* ((initial-url (%local-url))
 742            (redirect    (build-response #:code 301
 743                                         #:headers
 744                                         `((location
 745                                            . ,(string->uri initial-url))))))
 746       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 747         (with-http-server `((,redirect ""))
 748           (let ((pkg (package
 749                        (inherit (dummy-package "x"))
 750                        (source (origin
 751                                  (method url-fetch)
 752                                  (uri (%local-url))
 753                                  (sha256 %null-sha256))))))
 754             (match (check-source pkg)
 755               ((first-warning ; All source URIs are unreachable
 756                 (and (? lint-warning?) second-warning))
 757                (lint-warning-message second-warning)))))))))
 758
 759 (test-skip (if (http-server-can-listen?) 0 1))
 760 (test-equal "source, git-reference: 301 -> 200"
 761   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
 762   (with-http-server `((200 ,%long-string))
 763     (let* ((initial-url (%local-url))
 764            (redirect    (build-response #:code 301
 765                                         #:headers
 766                                         `((location
 767                                            . ,(string->uri initial-url))))))
 768       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 769         (with-http-server `((,redirect ""))
 770           (let ((pkg (dummy-package
 771                       "x"
 772                       (source (origin
 773                                 (method git-fetch)
 774                                 (uri (git-reference (url (%local-url))
 775                                                     (commit "v1.0.0")))
 776                                 (sha256 %null-sha256))))))
 777             (single-lint-warning-message (check-source pkg))))))))
 778
 779 (test-skip (if (http-server-can-listen?) 0 1))
 780 (test-equal "source: 301 -> 404"
 781   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
 782   (with-http-server '((404 "booh!"))
 783     (let* ((initial-url (%local-url))
 784            (redirect    (build-response #:code 301
 785                                         #:headers
 786                                         `((location
 787                                            . ,(string->uri initial-url))))))
 788       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 789         (with-http-server `((,redirect ""))
 790           (let ((pkg (package
 791                        (inherit (dummy-package "x"))
 792                        (source (origin
 793                                  (method url-fetch)
 794                                  (uri (%local-url))
 795                                  (sha256 %null-sha256))))))
 796             (match (check-source pkg)
 797               ((first-warning ; The first warning says that all URI's are
 798                               ; unreachable
 799                 (and (? lint-warning?) second-warning))
 800                (lint-warning-message second-warning)))))))))
 801
 802 (test-equal "mirror-url"
 803   '()
 804   (let ((source (origin
 805                   (method url-fetch)
 806                   (uri "http://example.org/foo/bar.tar.gz")
 807                   (sha256 %null-sha256))))
 808     (check-mirror-url (dummy-package "x" (source source)))))
 809
 810 (test-equal "mirror-url: one suggestion"
 811   "URL should be 'mirror://gnu/foo/foo.tar.gz'"
 812   (let ((source (origin
 813                   (method url-fetch)
 814                   (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
 815                   (sha256 %null-sha256))))
 816     (single-lint-warning-message
 817      (check-mirror-url (dummy-package "x" (source source))))))
 818
 819 (test-skip (if (http-server-can-listen?) 0 1))
 820 (test-equal "github-url"
 821   '()
 822   (with-http-server `((200 ,%long-string))
 823     (check-github-url
 824      (dummy-package "x" (source
 825                          (origin
 826                            (method url-fetch)
 827                            (uri (%local-url))
 828                            (sha256 %null-sha256)))))))
 829
 830 (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
 831   (test-skip (if (http-server-can-listen?) 0 1))
 832   (test-equal "github-url: one suggestion"
 833     (string-append
 834      "URL should be '" github-url "'")
 835     (let ((redirect (build-response #:code 301
 836                                     #:headers
 837                                     `((location
 838                                        . ,(string->uri github-url))))))
 839       (with-http-server `((,redirect ""))
 840         (let* ((initial-url (%local-url))
 841                (redirect    (build-response #:code 302
 842                                             #:headers
 843                                             `((location
 844                                                . ,(string->uri initial-url))))))
 845           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
 846             (with-http-server `((,redirect ""))
 847               (single-lint-warning-message
 848                (check-github-url
 849                 (dummy-package "x" (source
 850                                     (origin
 851                                       (method url-fetch)
 852                                       (uri (%local-url))
 853                                       (sha256 %null-sha256))))))))))))
 854
 855   (test-skip (if (http-server-can-listen?) 0 1))
 856   (test-equal "github-url: already the correct github url"
 857     '()
 858     (check-github-url
 859      (dummy-package "x" (source
 860                          (origin
 861                            (method url-fetch)
 862                            (uri github-url)
 863                            (sha256 %null-sha256)))))))
 864
 865 (test-equal "cve"
 866   '()
 867   (mock ((guix lint) package-vulnerabilities (const '()))
 868         (check-vulnerabilities (dummy-package "x"))))
 869
 870 (test-equal "cve: one vulnerability"
 871   "probably vulnerable to CVE-2015-1234"
 872   (let ((dummy-vulnerabilities
 873          (lambda (package)
 874            (list (make-struct/no-tail
 875                   (@@ (guix cve) <vulnerability>)
 876                   "CVE-2015-1234"
 877                   (list (cons (package-name package)
 878                               (package-version package))))))))
 879     (single-lint-warning-message
 880      (check-vulnerabilities (dummy-package "pi" (version "3.14"))
 881                             dummy-vulnerabilities))))
 882
 883 (test-equal "cve: one patched vulnerability"
 884   '()
 885   (mock ((guix lint) package-vulnerabilities
 886          (lambda (package)
 887            (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
 888                                       "CVE-2015-1234"
 889                                       (list (cons (package-name package)
 890                                                   (package-version package)))))))
 891         (check-vulnerabilities
 892          (dummy-package "pi"
 893                         (version "3.14")
 894                         (source
 895                          (dummy-origin
 896                           (patches
 897                            (list "/a/b/pi-CVE-2015-1234.patch"))))))))
 898
 899 (test-equal "cve: known safe from vulnerability"
 900   '()
 901   (mock ((guix lint) package-vulnerabilities
 902          (lambda (package)
 903            (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
 904                                       "CVE-2015-1234"
 905                                       (list (cons (package-name package)
 906                                                   (package-version package)))))))
 907         (check-vulnerabilities
 908          (dummy-package "pi"
 909                         (version "3.14")
 910                         (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))
 911
 912 (test-equal "cve: vulnerability fixed in replacement version"
 913   '()
 914   (mock ((guix lint) package-vulnerabilities
 915          (lambda (package)
 916            (match (package-version package)
 917              ("0"
 918               (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
 919                                          "CVE-2015-1234"
 920                                          (list (cons (package-name package)
 921                                                      (package-version package))))))
 922              ("1"
 923               '()))))
 924         (check-vulnerabilities
 925          (dummy-package
 926           "foo" (version "0")
 927           (replacement (dummy-package "foo" (version "1")))))))
 928
 929 (test-equal "cve: patched vulnerability in replacement"
 930   '()
 931   (mock ((guix lint) package-vulnerabilities
 932          (lambda (package)
 933            (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
 934                                       "CVE-2015-1234"
 935                                       (list (cons (package-name package)
 936                                                   (package-version package)))))))
 937         (check-vulnerabilities
 938          (dummy-package
 939           "pi" (version "3.14") (source (dummy-origin))
 940           (replacement (dummy-package
 941                         "pi" (version "3.14")
 942                         (source
 943                          (dummy-origin
 944                           (patches
 945                            (list "/a/b/pi-CVE-2015-1234.patch"))))))))))
 946
 947 (test-equal "formatting: lonely parentheses"
 948   "parentheses feel lonely, move to the previous or next line"
 949   (single-lint-warning-message
 950    (check-formatting
 951     (dummy-package "ugly as hell!"
 952                    )
 953     )))
 954
 955 (test-assert "formatting: tabulation"
 956   (string-match-or-error
 957    "tabulation on line [0-9]+, column [0-9]+"
 958    (single-lint-warning-message
 959     (check-formatting (dummy-package "leave the tab here:       ")))))
 960
 961 (test-assert "formatting: trailing white space"
 962   (string-match-or-error
 963    "trailing white space .*"
 964    ;; Leave the trailing white space on the next line!
 965    (single-lint-warning-message
 966     (check-formatting (dummy-package "x")))))
 967
 968 (test-assert "formatting: long line"
 969   (string-match-or-error
 970    "line [0-9]+ is way too long \\([0-9]+ characters\\)"
 971    (single-lint-warning-message (check-formatting
 972            (dummy-package "x"))                                     ;here is a stupid comment just to make a long line
 973      )))
 974
 975 (test-equal "formatting: alright"
 976   '()
 977   (check-formatting (dummy-package "x")))
 978
 979 (test-skip (if (http-server-can-listen?) 0 1))
 980 (test-assert "archival: missing content"
 981   (let* ((origin   (origin
 982                      (method url-fetch)
 983                      (uri "http://example.org/foo.tgz")
 984                      (sha256 (make-bytevector 32))))
 985          (warnings (with-http-server '((404 "Not archived."))
 986                      (parameterize ((%swh-base-url (%local-url)))
 987                        (check-archival (dummy-package "x"
 988                                                       (source origin)))))))
 989     (warning-contains? "not archived" warnings)))
 990
 991 (test-skip (if (http-server-can-listen?) 0 1))
 992 (test-equal "archival: content available"
 993   '()
 994   (let* ((origin   (origin
 995                      (method url-fetch)
 996                      (uri "http://example.org/foo.tgz")
 997                      (sha256 (make-bytevector 32))))
 998          ;; https://archive.softwareheritage.org/api/1/content/
 999          (content  "{ \"checksums\": {}, \"data_url\": \"xyz\",
1000                       \"length\": 42 }"))
1001     (with-http-server `((200 ,content))
1002       (parameterize ((%swh-base-url (%local-url)))
1003         (check-archival (dummy-package "x" (source origin)))))))
1004
1005 (test-skip (if (http-server-can-listen?) 0 1))
1006 (test-assert "archival: missing revision"
1007   (let* ((origin   (origin
1008                      (method git-fetch)
1009                      (uri (git-reference
1010                            (url "http://example.org/foo.git")
1011                            (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
1012                      (sha256 (make-bytevector 32))))
1013          ;; https://archive.softwareheritage.org/api/1/origin/save/
1014          (save     "{ \"origin_url\": \"http://example.org/foo.git\",
1015                       \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
1016                       \"save_request_status\": \"accepted\",
1017                       \"save_task_status\": \"scheduled\" }")
1018          (warnings (with-http-server `((404 "No revision.") ;lookup-revision
1019                                        (404 "No origin.")   ;lookup-origin
1020                                        (200 ,save))         ;save-origin
1021                      (parameterize ((%swh-base-url (%local-url)))
1022                        (check-archival (dummy-package "x" (source origin)))))))
1023     (warning-contains? "scheduled" warnings)))
1024
1025 (test-skip (if (http-server-can-listen?) 0 1))
1026 (test-equal "archival: revision available"
1027   '()
1028   (let* ((origin   (origin
1029                      (method git-fetch)
1030                      (uri (git-reference
1031                            (url "http://example.org/foo.git")
1032                            (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
1033                      (sha256 (make-bytevector 32))))
1034          ;; https://archive.softwareheritage.org/api/1/revision/
1035          (revision "{ \"author\": {}, \"parents\": [],
1036                       \"date\": \"2014-11-17T22:09:38+01:00\" }"))
1037     (with-http-server `((200 ,revision))
1038       (parameterize ((%swh-base-url (%local-url)))
1039         (check-archival (dummy-package "x" (source origin)))))))
1040
1041 (test-skip (if (http-server-can-listen?) 0 1))
1042 (test-assert "archival: rate limit reached"
1043   ;; We should get a single warning stating that the rate limit was reached,
1044   ;; and nothing more, in particular no other HTTP requests.
1045   (let* ((origin   (origin
1046                      (method url-fetch)
1047                      (uri "http://example.org/foo.tgz")
1048                      (sha256 (make-bytevector 32))))
1049          (too-many (build-response
1050                     #:code 429
1051                     #:reason-phrase "Too many requests"
1052                     #:headers '((x-ratelimit-remaining . "0")
1053                                 (x-ratelimit-reset . "3000000000"))))
1054          (warnings (with-http-server `((,too-many "Rate limit reached."))
1055                      (parameterize ((%swh-base-url (%local-url)))
1056                        (append-map (lambda (name)
1057                                      (check-archival
1058                                       (dummy-package name (source origin))))
1059                                    '("x" "y" "z"))))))
1060     (string-contains (single-lint-warning-message warnings)
1061                      "rate limit reached")))
1062
1063 (test-skip (if (http-server-can-listen?) 0 1))
1064 (test-assert "haskell-stackage"
1065   (let* ((stackage (string-append "{ \"packages\": [{"
1066                                   "    \"name\":\"x\","
1067                                   "    \"version\":\"1.0\" }]}"))
1068          (packages (map (lambda (version)
1069                           (dummy-package
1070                            (string-append "ghc-x")
1071                            (version version)
1072                            (source
1073                             (dummy-origin
1074                              (method url-fetch)
1075                              (uri (string-append
1076                                    "https://hackage.haskell.org/package/"
1077                                    "x-" version "/x-" version ".tar.gz"))))))
1078                         '("0.9" "1.0" "2.0")))
1079          (warnings (pk (with-http-server `((200 ,stackage) ; memoized
1080                                            (200 "name: x\nversion: 1.0\n")
1081                                            (200 "name: x\nversion: 1.0\n")
1082                                            (200 "name: x\nversion: 1.0\n"))
1083                          (parameterize ((%hackage-url (%local-url))
1084                                         (%stackage-url (%local-url)))
1085                            (append-map check-haskell-stackage packages))))))
1086     (match warnings
1087       (((? lint-warning? warning))
1088        (and (string=? (package-version (lint-warning-package warning)) "2.0")
1089             (string-contains (lint-warning-message warning)
1090                              "ahead of Stackage LTS version"))))))
1091
1092 (test-end "lint")
1093
1094 ;; Local Variables:
1095 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
1096 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
1097 ;; End: