tests/lint.scm

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