123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
- ;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
- ;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
- ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
- ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
- ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
- ;;; Copyright © 2017, 2022 Efraim Flashner <efraim@flashner.co.il>
- ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
- ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
- ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
- ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
- ;;; Copyright © 2021, 2023 Maxime Devos <maximedevos@telenet.be>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- ;; Avoid interference.
- (unsetenv "http_proxy")
- (define-module (test-lint)
- #:use-module (guix tests)
- #:use-module (guix tests http)
- #:use-module (guix download)
- #:use-module (guix git-download)
- #:use-module (guix svn-download)
- #:use-module (guix build-system texlive)
- #:use-module (guix build-system emacs)
- #:use-module (guix build-system gnu)
- #:use-module (guix packages)
- #:use-module (guix lint)
- #:use-module (guix ui)
- #:use-module (guix swh)
- #:use-module ((guix gexp)
- #:select (gexp local-file computed-file gexp?))
- #:use-module ((guix utils) #:select (call-with-temporary-directory))
- #:use-module ((guix import hackage) #:select (%hackage-url))
- #:use-module ((guix import stackage) #:select (%stackage-url))
- #:use-module (gnu packages)
- #:use-module (gnu packages glib)
- #:use-module (gnu packages pkg-config)
- #:use-module (gnu packages python-build)
- #:use-module ((gnu packages bash) #:select (bash bash-minimal))
- #:use-module (web uri)
- #:use-module (web server)
- #:use-module (web server http)
- #:use-module (web response)
- #:use-module (ice-9 match)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 getopt-long)
- #:use-module (ice-9 pretty-print)
- #:use-module (rnrs bytevectors)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-64))
- ;; Test the linter.
- (define %null-sha256
- ;; SHA256 of the empty string.
- (base32
- "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
- (define %long-string
- (make-string 2000 #\a))
- (define (string-match-or-error pattern str)
- (or (string-match pattern str)
- (error str "did not match" pattern)))
- (define single-lint-warning-message
- (match-lambda
- (((and (? lint-warning?) warning))
- (lint-warning-message warning))))
- (define (warning-contains? str warnings)
- "Return true if WARNINGS is a singleton with a warning that contains STR."
- (match warnings
- (((? lint-warning? warning))
- (string-contains (lint-warning-message warning) str))))
- (test-begin "lint")
- (test-equal "description: not a string"
- "invalid description: foobar"
- (single-lint-warning-message
- (check-description-style
- (dummy-package "x" (description 'foobar)))))
- (test-equal "description: not empty"
- "description should not be empty"
- (single-lint-warning-message
- (check-description-style
- (dummy-package "x" (description "")))))
- (test-equal "description: invalid Texinfo markup"
- "Texinfo markup in description is invalid"
- (single-lint-warning-message
- (check-description-style
- (dummy-package "x" (description (identity "f{oo}b@r"))))))
- (test-equal "description: does not start with an upper-case letter"
- "description should start with an upper-case letter or digit"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "bad description."))))
- (check-description-style pkg))))
- (test-equal "description: may start with a digit"
- '()
- (let ((pkg (dummy-package "x"
- (description "2-component library."))))
- (check-description-style pkg)))
- (test-equal "description: may start with lower-case package name"
- '()
- (let ((pkg (dummy-package "x"
- (description "x is a dummy package."))))
- (check-description-style pkg)))
- (test-equal "description: two spaces after end of sentence"
- "sentences in description should be followed by two spaces; possible infraction at 3"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "Bad. Quite bad."))))
- (check-description-style pkg))))
- (test-equal "description: end-of-sentence detection with abbreviations"
- '()
- (let ((pkg (dummy-package "x"
- (description
- "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
- (check-description-style pkg)))
- (test-equal "description: may not contain trademark signs: ™"
- "description should not contain trademark sign '™' at 20"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "Does The Right Thing™"))))
- (check-description-style pkg))))
- (test-equal "description: may not contain trademark signs: ®"
- "description should not contain trademark sign '®' at 17"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "Works with Format®"))))
- (check-description-style pkg))))
- (test-equal "description: suggest ornament instead of quotes"
- "use @code or similar ornament instead of quotes"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "This is a 'quoted' thing."))))
- (check-description-style pkg))))
- (test-equal "description: leading whitespace"
- "description contains leading whitespace"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description " Whitespace."))))
- (check-description-style pkg))))
- (test-equal "description: trailing whitespace"
- "description contains trailing whitespace"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "Whitespace. "))))
- (check-description-style pkg))))
- (test-equal "description: pluralized 'This package'"
- "description contains typo 'This packages', should be 'This package'"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "This packages is a typo."))))
- (check-description-style pkg))))
- (test-equal "description: grammar 'allows to'"
- "description contains typo 'allows to'"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (description "This package allows to do stuff."))))
- (check-description-style pkg))))
- (test-equal "synopsis: not a string"
- "invalid synopsis: #f"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis #f))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: not empty"
- "synopsis should not be empty"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis ""))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: valid Texinfo markup"
- "Texinfo markup in synopsis is invalid"
- (single-lint-warning-message
- (check-synopsis-style
- (dummy-package "x" (synopsis (identity "Bad $@ texinfo"))))))
- (test-equal "synopsis: does not start with an upper-case letter"
- "synopsis should start with an upper-case letter or digit"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "bad synopsis"))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: may start with a digit"
- '()
- (let ((pkg (dummy-package "x"
- (synopsis "5-dimensional frobnicator"))))
- (check-synopsis-style pkg)))
- (test-equal "synopsis: ends with a period"
- "no period allowed at the end of the synopsis"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "Bad synopsis."))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: ends with 'etc.'"
- '()
- (let ((pkg (dummy-package "x"
- (synopsis "Foo, bar, etc."))))
- (check-synopsis-style pkg)))
- (test-equal "synopsis: starts with 'A'"
- "no article allowed at the beginning of the synopsis"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "A bad synopŝis"))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: starts with 'An'"
- "no article allowed at the beginning of the synopsis"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "An awful synopsis"))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: starts with 'a'"
- '("no article allowed at the beginning of the synopsis"
- "synopsis should start with an upper-case letter or digit")
- (sort
- (map
- lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "a bad synopsis"))))
- (check-synopsis-style pkg)))
- string<?))
- (test-equal "synopsis: starts with 'an'"
- '("no article allowed at the beginning of the synopsis"
- "synopsis should start with an upper-case letter or digit")
- (sort
- (map
- lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "an awful synopsis"))))
- (check-synopsis-style pkg)))
- string<?))
- (test-equal "synopsis: too long"
- "synopsis should be less than 80 characters long"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis (make-string 80 #\X)))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: start with package name"
- "synopsis should not start with the package name"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (name "Foo")
- (synopsis "Foo, a nice package"))))
- (check-synopsis-style pkg))))
- (test-equal "synopsis: start with package name prefix"
- '()
- (let ((pkg (dummy-package "arb"
- (synopsis "Arbitrary precision"))))
- (check-synopsis-style pkg)))
- (test-equal "synopsis: start with abbreviation"
- '()
- (let ((pkg (dummy-package "uucp"
- ;; Same problem with "APL interpreter", etc.
- (synopsis "UUCP implementation")
- (description "Imagine this is Taylor UUCP."))))
- (check-synopsis-style pkg)))
- (test-equal "synopsis: contains trailing whitespace"
- "synopsis contains trailing whitespace"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (synopsis "Whitespace "))))
- (check-synopsis-style pkg))))
- (test-equal "name: use underscore in package name"
- "name should use hyphens instead of underscores"
- (single-lint-warning-message
- (let ((pkg (dummy-package "under_score")))
- (check-name pkg))))
- (test-equal "tests-true: #:tests? must not be set to #t"
- "#:tests? must not be explicitly set to #t"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x" (arguments '(#:tests? #t)))))
- (check-tests-true pkg))))
- (test-equal "tests-true: absent #:tests? is acceptable"
- '()
- (let ((pkg (dummy-package "x")))
- (check-tests-true pkg)))
- (test-equal "tests-true: #:tests? #f is acceptable"
- '()
- (let ((pkg (dummy-package "x" (arguments '(#:tests? #f)))))
- (check-tests-true pkg)))
- (test-equal "tests-true: #:tests? #t acceptable when compiling natively"
- '()
- (let ((pkg (dummy-package "x"
- (arguments
- `(#:tests? ,(not (%current-target-system)))))))
- (check-tests-true pkg)))
- (test-equal "compiler-for-target: unconditional CC=gcc is unacceptable"
- "'CC' should be set to '(cc-for-target)' instead of 'gcc'"
- (single-lint-warning-message
- (check-compiler-for-target
- (dummy-package "x" (arguments '(#:make-flags '("CC=gcc")))))))
- (test-equal "compiler-for-target: looks through G-expressions"
- "'CC' should be set to '(cc-for-target)' instead of 'gcc'"
- (single-lint-warning-message
- (check-compiler-for-target
- (dummy-package "x" (arguments '(#:make-flags #~'("CC=gcc")))))))
- (test-equal "compiler-for-target: (cc-for-target) is acceptable"
- '()
- (check-compiler-for-target
- (dummy-package "x"
- (arguments
- (list #:make-flags
- #~(list (string-append "CC=" (cc-for-target))))))))
- (test-equal "compiler-for-target: CC=gcc is acceptable when target=#false"
- '()
- (check-compiler-for-target
- ;; This (dummy) package consists purely of architecture-independent data.
- (dummy-package "tzdata"
- (arguments
- (list #:target #false
- #:make-flags #~(list "CC=gcc"))))))
- ;; The emacs-build-system sets #:tests? #f by default.
- (test-equal "tests-true: #:tests? #t acceptable for emacs packages"
- '()
- (let ((pkg (dummy-package "x"
- (build-system emacs-build-system)
- (arguments
- `(#:tests? #t)))))
- (check-tests-true pkg)))
- ;; Likewise, though the 'check' phase is deleted by default,
- ;; so #:tests? #t won't be useful by itself.
- (test-equal "tests-true: #:tests? #t acceptable for texlive packages"
- '()
- (let ((pkg (dummy-package "x"
- (build-system texlive-build-system)
- (arguments
- `(#:tests? #t)))))
- (check-tests-true pkg)))
- (test-equal "inputs: pkg-config is probably a native input"
- "'pkg-config' should probably be a native input"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (inputs `(("pkg-config" ,pkg-config))))))
- (check-inputs-should-be-native pkg))))
- (test-equal "inputs: glib:bin is probably a native input"
- "'glib:bin' should probably be a native input"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (inputs `(("glib" ,glib "bin"))))))
- (check-inputs-should-be-native pkg))))
- (test-equal
- "inputs: python-setuptools should not be an input at all (input)"
- "'python-setuptools' should probably not be an input at all"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (inputs `(("python-setuptools"
- ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg))))
- (test-equal
- "inputs: python-setuptools should not be an input at all (native-input)"
- "'python-setuptools' should probably not be an input at all"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (native-inputs
- `(("python-setuptools"
- ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg))))
- (test-equal
- "inputs: python-setuptools should not be an input at all (propagated-input)"
- "'python-setuptools' should probably not be an input at all"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (propagated-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg))))
- (test-assert "input labels: no warnings"
- (let ((pkg (dummy-package "x"
- (inputs `(("glib" ,glib)
- ("pkg-config" ,pkg-config))))))
- (null? (check-input-labels pkg))))
- (test-equal "input labels: one warning"
- "label 'pkgkonfig' does not match package name 'pkg-config'"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (inputs `(("glib" ,glib)
- ("pkgkonfig" ,pkg-config))))))
- (check-input-labels pkg))))
- (test-equal "explicit #:sh argument to 'wrap-program' is acceptable"
- '()
- (let* ((phases
- ;; Loosely based on the "catfish" package
- `(modify-phases %standard-phases
- (add-after 'install 'wrap
- (lambda* (#:key inputs outputs #:allow-other-keys)
- (define catfish (string-append (assoc-ref outputs "out")
- "/bin/catfish"))
- (define hsab (string-append (assoc-ref inputs "hsab")
- "/bin/hsab"))
- (wrap-program catfish #:sh hsab
- `("PYTHONPATH" = (,"blabla")))))))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
- (check-wrapper-inputs pkg)))
- (test-equal
- "'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs"
- "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used"
- (let* ((phases
- `(modify-phases %standard-phases
- (add-after 'install 'wrap
- (lambda _
- (wrap-program the-binary bla-bla)))))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
- (single-lint-warning-message (check-wrapper-inputs pkg))))
- (test-equal
- "'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs"
- "\"bash-minimal\" should be in 'inputs' when 'wrap-qt-program' is used"
- (let* ((phases
- `(modify-phases %standard-phases
- (add-after 'install 'qtwrap
- (lambda _
- (wrap-qt-program the-binary bla-bla)))))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
- (single-lint-warning-message (check-wrapper-inputs pkg))))
- (test-equal "\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'"
- '()
- (let* ((phases
- `(modify-phases %standard-phases
- (add-after 'install 'wrap
- (lambda _
- (wrap-program the-binary bla-bla)))))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases))
- (inputs `(("bash" ,bash))))))
- (check-wrapper-inputs pkg)))
- (test-equal "\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'"
- '()
- (let* ((phases
- `(modify-phases %standard-phases
- (add-after 'install 'wrap
- (lambda _
- (wrap-program THE-BINARY bla-bla)))))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases))
- (inputs `(("bash-minimal" ,bash-minimal))))))
- (check-wrapper-inputs pkg)))
- (test-equal "'cut' doesn't hide bad usages of 'wrap-program'"
- "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used"
- (let* ((phases
- ;; Taken from the "straw-viewer" package
- `(modify-phases %standard-phases
- (add-after 'install 'wrap-program
- (lambda* (#:key outputs #:allow-other-keys)
- (let* ((out (assoc-ref outputs "out"))
- (bin-dir (string-append out "/bin/"))
- (site-dir (string-append out "/lib/perl5/site_perl/"))
- (lib-path (getenv "PERL5LIB")))
- (for-each (cut wrap-program <>
- `("PERL5LIB" ":" prefix
- (,lib-path ,site-dir)))
- (find-files bin-dir)))))))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
- (single-lint-warning-message (check-wrapper-inputs pkg))))
- (test-equal "bogus phase specifications don't crash the linter"
- "invalid phase clause"
- (let* ((phases
- `(modify-phases %standard-phases
- (add-invalid)))
- (pkg (dummy-package "x" (arguments `(#:phases ,phases)))))
- (single-lint-warning-message (check-wrapper-inputs pkg))))
- (test-equal "file patches: different file name -> warning"
- "file names of patches should start with the package name"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list "/path/to/y.patch")))))))
- (check-patch-file-names pkg))))
- (test-equal "file patches: same file name -> no warnings"
- '()
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list "/path/to/x.patch")))))))
- (check-patch-file-names pkg)))
- (test-equal "<origin> patches: different file name -> warning"
- "file names of patches should start with the package name"
- (single-lint-warning-message
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches
- (list
- (dummy-origin
- (file-name "y.patch")))))))))
- (check-patch-file-names pkg))))
- (test-equal "<origin> patches: same file name -> no warnings"
- '()
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches
- (list
- (dummy-origin
- (file-name "x.patch")))))))))
- (check-patch-file-names pkg)))
- (test-equal "patches: file name too long, which may break 'make dist'"
- (string-append "x-"
- (make-string 152 #\a)
- ".patch: file name is too long, which may break 'make dist'")
- (single-lint-warning-message
- (let ((pkg (dummy-package
- "x"
- (source
- (dummy-origin
- (patches (list (string-append "x-"
- (make-string 152 #\a)
- ".patch"))))))))
- (check-patch-file-names pkg))))
- (test-equal "patches: not found"
- "this-patch-does-not-exist!: patch not found\n"
- (single-lint-warning-message
- (let ((pkg (dummy-package
- "x"
- (source
- (dummy-origin
- (patches
- (list (search-patch "this-patch-does-not-exist!"))))))))
- (check-patch-file-names pkg))))
- (test-assert "patch headers: no warnings"
- (call-with-temporary-directory
- (lambda (directory)
- (call-with-output-file (string-append directory "/t.patch")
- (lambda (port)
- (display "This is a patch.\n\n--- a\n+++ b\n"
- port)))
- (parameterize ((%patch-path (list directory)))
- (let ((pkg (dummy-package "x"
- (source (dummy-origin
- (patches (search-patches "t.patch")))))))
- (null? (check-patch-headers pkg)))))))
- (test-equal "patch headers: missing comment"
- "t.patch: patch lacks comment and upstream status"
- (call-with-temporary-directory
- (lambda (directory)
- (call-with-output-file (string-append directory "/t.patch")
- (lambda (port)
- (display "\n--- a\n+++ b\n"
- port)))
- (parameterize ((%patch-path (list directory)))
- (let ((pkg (dummy-package "x"
- (source (dummy-origin
- (patches (search-patches "t.patch")))))))
- (single-lint-warning-message (check-patch-headers pkg)))))))
- (test-equal "patch headers: empty"
- "t.patch: empty patch"
- (call-with-temporary-directory
- (lambda (directory)
- (call-with-output-file (string-append directory "/t.patch")
- (const #t))
- (parameterize ((%patch-path '()))
- (let ((pkg (dummy-package "x"
- (source (dummy-origin
- (patches
- (list (local-file
- (string-append directory
- "/t.patch")))))))))
- (single-lint-warning-message (check-patch-headers pkg)))))))
- (test-equal "patch headers: patch not found"
- "does-not-exist.patch: patch not found\n"
- (parameterize ((%patch-path '()))
- (let ((pkg (dummy-package "x"
- (source (dummy-origin
- (patches
- (search-patches "does-not-exist.patch")))))))
- (single-lint-warning-message (check-patch-headers pkg)))))
- (test-equal "derivation: invalid arguments"
- "failed to create x86_64-linux derivation: (match-error \"match\" \"no matching pattern\" invalid-module)"
- (match (let ((pkg (dummy-package "x"
- (arguments
- '(#:imported-modules (invalid-module))))))
- (check-derivation pkg))
- (((and (? lint-warning?) first-warning) others ...)
- (lint-warning-message first-warning))))
- (test-equal "profile-collisions: no warnings"
- '()
- (check-profile-collisions (dummy-package "x")))
- (test-equal "profile-collisions: propagated inputs collide"
- "propagated inputs p0@1 and p0@2 collide"
- (let* ((p0 (dummy-package "p0" (version "1")))
- (p0* (dummy-package "p0" (version "2")))
- (p1 (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
- (p2 (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
- (p3 (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
- (p4 (dummy-package "p4" (propagated-inputs
- `(("p2" ,p2) ("p3", p3))))))
- (single-lint-warning-message
- (check-profile-collisions p4))))
- (test-assert "profile-collisions: propagated inputs collide, store items"
- (string-match-or-error
- "propagated inputs /[[:graph:]]+-p0-1 and /[[:graph:]]+-p0-1 collide"
- (let* ((p0 (dummy-package "p0" (version "1")))
- (p0* (dummy-package "p0" (version "1")
- (inputs `(("x" ,(dummy-package "x"))))))
- (p1 (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
- (p2 (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
- (p3 (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
- (p4 (dummy-package "p4" (propagated-inputs
- `(("p2" ,p2) ("p3", p3))))))
- (single-lint-warning-message
- (check-profile-collisions p4)))))
- (test-equal "license: invalid license"
- "invalid license field"
- (single-lint-warning-message
- (check-license (dummy-package "x" (license #f)))))
- (test-equal "home-page: wrong home-page"
- "invalid value for home page"
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page #f))))
- (single-lint-warning-message
- (check-home-page pkg))))
- (test-equal "home-page: invalid URI"
- "invalid home page URL: \"foobar\""
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "foobar"))))
- (single-lint-warning-message
- (check-home-page pkg))))
- (test-assert "home-page: host not found"
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "http://does-not-exist"))))
- (warning-contains? "domain not found" (check-home-page pkg))))
- (parameterize ((%http-server-port 9999))
- ;; TODO skip this test if some process is currently listening at 9999
- (test-equal "home-page: Connection refused"
- "URI http://localhost:9999/foo/bar unreachable: Connection refused"
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (single-lint-warning-message
- (check-home-page pkg)))))
- (test-equal "home-page: 200"
- '()
- (with-http-server `((200 ,%long-string))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- (with-http-server `((200 "This is too small."))
- (test-equal "home-page: 200 but short length"
- (format #f "URI ~a returned suspiciously small file (18 bytes)"
- (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (single-lint-warning-message
- (check-home-page pkg)))))
- (with-http-server `((404 ,%long-string))
- (test-equal "home-page: 404"
- (format #f "URI ~a not reachable: 404 (\"Such is life\")" (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (single-lint-warning-message
- (check-home-page pkg)))))
- (with-http-server `((301 ,%long-string))
- (test-equal "home-page: 301, invalid"
- (format #f "invalid permanent redirect from ~a" (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (single-lint-warning-message
- (check-home-page pkg)))))
- (with-http-server `((200 ,%long-string))
- (let* ((initial-url (%local-url))
- (redirect (build-response #:code 301
- #:headers
- `((location
- . ,(string->uri initial-url))))))
- (parameterize ((%http-server-port 0))
- (with-http-server `((,redirect ""))
- (test-equal "home-page: 301 -> 200"
- (format #f "permanent redirect from ~a to ~a"
- (%local-url) initial-url)
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (single-lint-warning-message
- (check-home-page pkg))))))))
- (with-http-server `((404 "booh!"))
- (let* ((initial-url (%local-url))
- (redirect (build-response #:code 301
- #:headers
- `((location
- . ,(string->uri initial-url))))))
- (parameterize ((%http-server-port 0))
- (with-http-server `((,redirect ""))
- (test-equal "home-page: 301 -> 404"
- (format #f "URI ~a not reachable: 404 (\"Such is life\")" (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (single-lint-warning-message
- (check-home-page pkg))))))))
- (test-equal "source-file-name"
- "the source file name should contain the package name"
- (let ((pkg (dummy-package "x"
- (version "3.2.1")
- (source
- (origin
- (method url-fetch)
- (uri "http://www.example.com/3.2.1.tar.gz")
- (sha256 %null-sha256))))))
- (single-lint-warning-message
- (check-source-file-name pkg))))
- (test-equal "source-file-name: v prefix"
- "the source file name should contain the package name"
- (let ((pkg (dummy-package "x"
- (version "3.2.1")
- (source
- (origin
- (method url-fetch)
- (uri "http://www.example.com/v3.2.1.tar.gz")
- (sha256 %null-sha256))))))
- (single-lint-warning-message
- (check-source-file-name pkg))))
- (test-equal "source-file-name: bad checkout"
- "the source file name should contain the package name"
- (let ((pkg (dummy-package "x"
- (version "3.2.1")
- (source
- (origin
- (method git-fetch)
- (uri (git-reference
- (url "http://www.example.com/x.git")
- (commit "0")))
- (sha256 %null-sha256))))))
- (single-lint-warning-message
- (check-source-file-name pkg))))
- (test-equal "source-file-name: good checkout"
- '()
- (let ((pkg (dummy-package "x"
- (version "3.2.1")
- (source
- (origin
- (method git-fetch)
- (uri (git-reference
- (url "http://git.example.com/x.git")
- (commit "0")))
- (file-name (string-append "x-" version))
- (sha256 %null-sha256))))))
- (check-source-file-name pkg)))
- (test-equal "source-file-name: valid"
- '()
- (let ((pkg (dummy-package "x"
- (version "3.2.1")
- (source
- (origin
- (method url-fetch)
- (uri "http://www.example.com/x-3.2.1.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-file-name pkg)))
- (test-equal "source-unstable-tarball"
- "the source URI should not be an autogenerated tarball"
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/example/archive/v0.0.tar.gz")
- (sha256 %null-sha256))))))
- (single-lint-warning-message
- (check-source-unstable-tarball pkg))))
- (test-equal "source-unstable-tarball: source #f"
- '()
- (let ((pkg (dummy-package "x"
- (source #f))))
- (check-source-unstable-tarball pkg)))
- (test-equal "source-unstable-tarball: valid"
- '()
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- (test-equal "source-unstable-tarball: package named archive"
- '()
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- (test-equal "source-unstable-tarball: not-github"
- '()
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- (test-equal "source-unstable-tarball: git-fetch"
- '()
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method git-fetch)
- (uri (git-reference
- (url "https://github.com/archive/example")
- (commit "0")))
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- (define (package-with-phase-changes changes)
- (dummy-package "x"
- (arguments `(#:phases
- ,(if (gexp? changes)
- #~(modify-phases %standard-phases
- #$@changes)
- `(modify-phases %standard-phases
- ,@changes))))))
- (test-equal "optional-tests: no check phase"
- '()
- (let ((pkg (package-with-phase-changes '())))
- (check-optional-tests pkg)))
- (test-equal "optional-tests: check phase respects #:tests?"
- '()
- (let ((pkg (package-with-phase-changes
- '((replace 'check
- (lambda* (#:key tests? #:allow-other-keys?)
- (when tests?
- (invoke "./the-test-suite"))))))))
- (check-optional-tests pkg)))
- (test-equal "optional-tests: check phase ignores #:tests?"
- "the 'check' phase should respect #:tests?"
- (let ((pkg (package-with-phase-changes
- '((replace 'check
- (lambda _
- (invoke "./the-test-suite")))))))
- (single-lint-warning-message
- (check-optional-tests pkg))))
- (test-equal "optional-tests: do not crash when #:phases is invalid"
- "incorrect call to ‘modify-phases’"
- (let ((pkg (package-with-phase-changes 'this-is-not-a-list)))
- (single-lint-warning-message
- (check-optional-tests pkg))))
- (test-equal "optional-tests: allow G-exps (no warning)"
- '()
- (let ((pkg (package-with-phase-changes #~())))
- (check-optional-tests pkg)))
- (test-equal "optional-tests: allow G-exps (warning)"
- "the 'check' phase should respect #:tests?"
- (let ((pkg (package-with-phase-changes
- #~((replace 'check
- (lambda _
- (invoke "/the-test-suite")))))))
- (single-lint-warning-message
- (check-optional-tests pkg))))
- (test-equal "optional-tests: complicated 'check' phase"
- "the 'check' phase should respect #:tests?"
- (let ((pkg (package-with-phase-changes
- '((replace 'check
- (lambda* (#:key inputs tests? #:allow-other-keys)
- (let ((something (stuff from inputs or native-inputs)))
- (delete-file "dateutil/test/test_utils.py")
- (invoke "pytest" "-vv"))))))))
- (single-lint-warning-message
- (check-optional-tests pkg))))
- (test-equal "optional-tests: 'check' phase is not first phase"
- "the 'check' phase should respect #:tests?"
- (let ((pkg (package-with-phase-changes
- '((add-after 'unpack
- (lambda _
- (chdir "libtestcase-0.0.0")))
- (replace 'check
- (lambda _ (invoke "./test-suite")))))))
- (single-lint-warning-message
- (check-optional-tests pkg))))
- (test-equal "source: 200"
- '()
- (with-http-server `((200 ,%long-string))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
- (check-source pkg))))
- (with-http-server '((200 "This is too small."))
- (test-equal "source: 200 but short length"
- (format #f "URI ~a returned suspiciously small file (18 bytes)"
- (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
- (match (check-source pkg)
- ((first-warning ; All source URIs are unreachable
- (and (? lint-warning?) second-warning))
- (lint-warning-message second-warning))))))
- (with-http-server `((404 ,%long-string))
- (test-equal "source: 404"
- (format #f "URI ~a not reachable: 404 (\"Such is life\")"
- (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
- (match (check-source pkg)
- ((first-warning ; All source URIs are unreachable
- (and (? lint-warning?) second-warning))
- (lint-warning-message second-warning))))))
- (test-equal "source: 404 and 200"
- '()
- (with-http-server `((404 ,%long-string))
- (let ((bad-url (%local-url)))
- (parameterize ((%http-server-port (+ 1 (%http-server-port))))
- (with-http-server `((200 ,%long-string))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (list bad-url (%local-url)))
- (sha256 %null-sha256))))))
- ;; Since one of the two URLs is good, this should return the empty
- ;; list.
- (check-source pkg)))))))
- (with-http-server `((200 ,%long-string))
- (let* ((initial-url (%local-url))
- (redirect (build-response #:code 301
- #:headers
- `((location
- . ,(string->uri initial-url))))))
- (parameterize ((%http-server-port 0))
- (with-http-server `((,redirect ""))
- (test-equal "source: 301 -> 200"
- (format #f "permanent redirect from ~a to ~a"
- (%local-url) initial-url)
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
- (match (check-source pkg)
- ((first-warning ; All source URIs are unreachable
- (and (? lint-warning?) second-warning))
- (lint-warning-message second-warning)))))))))
- (with-http-server `((200 ,%long-string))
- (let* ((initial-url (%local-url))
- (redirect (build-response #:code 301
- #:headers
- `((location
- . ,(string->uri initial-url))))))
- (parameterize ((%http-server-port 0))
- (with-http-server `((,redirect ""))
- (test-equal "source, git-reference: 301 -> 200"
- (format #f "permanent redirect from ~a to ~a"
- (%local-url) initial-url)
- (let ((pkg (dummy-package
- "x"
- (source (origin
- (method git-fetch)
- (uri (git-reference (url (%local-url))
- (commit "v1.0.0")))
- (sha256 %null-sha256))))))
- (single-lint-warning-message (check-source pkg))))))))
- (with-http-server '((404 "booh!"))
- (let* ((initial-url (%local-url))
- (redirect (build-response #:code 301
- #:headers
- `((location
- . ,(string->uri initial-url))))))
- (parameterize ((%http-server-port 0))
- (with-http-server `((,redirect ""))
- (test-equal "source: 301 -> 404"
- (format #f "URI ~a not reachable: 404 (\"Such is life\")"
- (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
- (match (check-source pkg)
- ((first-warning ; The first warning says that all URI's are
- ; unreachable
- (and (? lint-warning?) second-warning))
- (lint-warning-message second-warning)))))))))
- (test-equal "source: svn-reference, HTTP 200"
- '()
- (with-http-server `((200 ,%long-string))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method svn-fetch)
- (uri (svn-reference
- (url (%local-url))
- (revision 1234)))
- (sha256 %null-sha256))))))
- (check-source pkg))))
- (with-http-server `((404 ,%long-string))
- (test-equal "source: svn-reference, HTTP 404"
- (format #f "URI ~a not reachable: 404 (\"Such is life\")"
- (%local-url))
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method svn-fetch)
- (uri (svn-reference
- (url (%local-url))
- (revision 1234)))
- (sha256 %null-sha256))))))
- (match (check-source pkg)
- ((warning)
- (lint-warning-message warning))))))
- (test-equal "mirror-url"
- '()
- (let ((source (origin
- (method url-fetch)
- (uri "http://example.org/foo/bar.tar.gz")
- (sha256 %null-sha256))))
- (check-mirror-url (dummy-package "x" (source source)))))
- (test-equal "mirror-url: one suggestion"
- "URL should be 'mirror://gnu/foo/foo.tar.gz'"
- (let ((source (origin
- (method url-fetch)
- (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
- (sha256 %null-sha256))))
- (single-lint-warning-message
- (check-mirror-url (dummy-package "x" (source source))))))
- (test-equal "mirror-url: kde suggestion"
- "URL should be 'mirror://kde/stable/gcompris/qt/src/gcompris-qt-2.3.tar.xz'"
- (let ((source (origin
- (method url-fetch)
- (uri "https://download.kde.org/stable/gcompris/qt/src/gcompris-qt-2.3.tar.xz")
- (sha256 %null-sha256))))
- (single-lint-warning-message
- (check-mirror-url (dummy-package "x" (source source))))))
- (test-equal "github-url"
- '()
- (with-http-server `((200 ,%long-string))
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256)))))))
- (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
- (test-equal "github-url: one suggestion"
- (string-append
- "URL should be '" github-url "'")
- (let ((redirect (build-response #:code 301
- #:headers
- `((location
- . ,(string->uri github-url))))))
- (with-http-server `((,redirect ""))
- (let* ((initial-url (%local-url))
- (redirect (build-response #:code 302
- #:headers
- `((location
- . ,(string->uri initial-url))))))
- (parameterize ((%http-server-port 0))
- (with-http-server `((,redirect ""))
- (single-lint-warning-message
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))))))))
- (test-equal "github-url: already the correct github url"
- '()
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri github-url)
- (sha256 %null-sha256)))))))
- (test-equal "cve"
- '()
- (mock ((guix lint) package-vulnerabilities (const '()))
- (check-vulnerabilities (dummy-package "x"))))
- (test-equal "cve: one vulnerability"
- "probably vulnerable to CVE-2015-1234"
- (let ((dummy-vulnerabilities
- (lambda (package)
- (list (make-struct/no-tail
- (@@ (guix cve) <vulnerability>)
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package))))))))
- (single-lint-warning-message
- (check-vulnerabilities (dummy-package "pi" (version "3.14"))
- dummy-vulnerabilities))))
- (test-equal "cve: one patched vulnerability"
- '()
- (mock ((guix lint) package-vulnerabilities
- (lambda (package)
- (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package)))))))
- (check-vulnerabilities
- (dummy-package "pi"
- (version "3.14")
- (source
- (dummy-origin
- (patches
- (list "/a/b/pi-CVE-2015-1234.patch"))))))))
- (test-equal "cve: known safe from vulnerability"
- '()
- (mock ((guix lint) package-vulnerabilities
- (lambda (package)
- (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package)))))))
- (check-vulnerabilities
- (dummy-package "pi"
- (version "3.14")
- (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))
- (test-equal "cve: vulnerability fixed in replacement version"
- '()
- (mock ((guix lint) package-vulnerabilities
- (lambda (package)
- (match (package-version package)
- ("0"
- (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package))))))
- ("1"
- '()))))
- (check-vulnerabilities
- (dummy-package
- "foo" (version "0")
- (replacement (dummy-package "foo" (version "1")))))))
- (test-equal "cve: patched vulnerability in replacement"
- '()
- (mock ((guix lint) package-vulnerabilities
- (lambda (package)
- (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package)))))))
- (check-vulnerabilities
- (dummy-package
- "pi" (version "3.14") (source (dummy-origin))
- (replacement (dummy-package
- "pi" (version "3.14")
- (source
- (dummy-origin
- (patches
- (list "/a/b/pi-CVE-2015-1234.patch"))))))))))
- (test-equal "formatting: lonely parentheses"
- "parentheses feel lonely, move to the previous or next line"
- (single-lint-warning-message
- (check-formatting
- (dummy-package "ugly as hell!"
- )
- )))
- (test-assert "formatting: tabulation"
- (string-match-or-error
- "tabulation on line [0-9]+, column [0-9]+"
- (single-lint-warning-message
- (check-formatting (dummy-package "leave the tab here: ")))))
- (test-assert "formatting: trailing white space"
- (string-match-or-error
- "trailing white space .*"
- ;; Leave the trailing white space on the next line!
- (single-lint-warning-message
- (check-formatting (dummy-package "x")))))
- (test-assert "formatting: long line"
- (string-match-or-error
- "line [0-9]+ is way too long \\([0-9]+ characters\\)"
- (single-lint-warning-message (check-formatting
- (dummy-package "x")) ;here is a stupid comment just to make a long line
- )))
- (test-equal "formatting: alright"
- '()
- (check-formatting (dummy-package "x")))
- (test-assert "archival: not an origin"
- (warning-contains? "not an origin"
- (check-archival
- (dummy-package
- "x" (source (computed-file "x-src" #t))))))
- (test-assert "archival: missing content"
- (let* ((origin (origin
- (method url-fetch)
- (uri "http://example.org/foo.tgz")
- (sha256 (make-bytevector 32))))
- (warnings (with-http-server '((404 "Not archived.")
- (404 "Not in Disarchive database."))
- (parameterize ((%swh-base-url (%local-url)))
- (mock ((guix download) %disarchive-mirrors
- (list (%local-url)))
- (check-archival (dummy-package "x"
- (source origin))))))))
- (warning-contains? "not archived" warnings)))
- (test-equal "archival: content available"
- '()
- (let* ((origin (origin
- (method url-fetch)
- (uri "http://example.org/foo.tgz")
- (sha256 (make-bytevector 32))))
- ;; https://archive.softwareheritage.org/api/1/content/
- (content "{ \"checksums\": {}, \"data_url\": \"xyz\",
- \"length\": 42 }"))
- (with-http-server `((200 ,content))
- (parameterize ((%swh-base-url (%local-url)))
- (check-archival (dummy-package "x" (source origin)))))))
- (test-equal "archival: content unavailable but disarchive available"
- '()
- (let* ((origin (origin
- (method url-fetch)
- (uri "http://example.org/foo.tgz")
- (sha256 (make-bytevector 32))))
- (disarchive (object->string
- '(disarchive (version 0)
- ...
- "swh:1:dir:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
- ;; https://archive.softwareheritage.org/api/1/directory/
- (directory "[ { \"checksums\": {},
- \"dir_id\": \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\",
- \"type\": \"file\",
- \"name\": \"README\"
- \"length\": 42 } ]"))
- (with-http-server `((404 "") ;lookup-content
- (200 ,disarchive) ;Disarchive database lookup
- (200 ,directory)) ;lookup-directory
- (mock ((guix download) %disarchive-mirrors (list (%local-url)))
- (parameterize ((%swh-base-url (%local-url)))
- (check-archival (dummy-package "x" (source origin))))))))
- (test-assert "archival: missing revision"
- (let* ((origin (origin
- (method git-fetch)
- (uri (git-reference
- (url "http://example.org/foo.git")
- (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
- (sha256 (make-bytevector 32))))
- ;; https://archive.softwareheritage.org/api/1/origin/save/
- (save "{ \"origin_url\": \"http://example.org/foo.git\",
- \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
- \"save_request_status\": \"accepted\",
- \"save_task_status\": \"scheduled\" }")
- (warnings (with-http-server `((404 "No revision.") ;lookup-revision
- (404 "No origin.") ;lookup-origin
- (200 ,save)) ;save-origin
- (parameterize ((%swh-base-url (%local-url)))
- (check-archival (dummy-package "x" (source origin)))))))
- (warning-contains? "scheduled" warnings)))
- (test-equal "archival: revision available"
- '()
- (let* ((origin (origin
- (method git-fetch)
- (uri (git-reference
- (url "http://example.org/foo.git")
- (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
- (sha256 (make-bytevector 32))))
- ;; https://archive.softwareheritage.org/api/1/revision/
- (revision "{ \"author\": {}, \"parents\": [],
- \"date\": \"2014-11-17T22:09:38+01:00\" }"))
- (with-http-server `((200 ,revision))
- (parameterize ((%swh-base-url (%local-url)))
- (check-archival (dummy-package "x" (source origin)))))))
- (test-assert "archival: rate limit reached"
- ;; We should get a single warning stating that the rate limit was reached,
- ;; and nothing more, in particular no other HTTP requests.
- (let* ((origin (origin
- (method url-fetch)
- (uri "http://example.org/foo.tgz")
- (sha256 (make-bytevector 32))))
- (too-many (build-response
- #:code 429
- #:reason-phrase "Too many requests"
- #:headers '((x-ratelimit-remaining . "0")
- (x-ratelimit-reset . "3000000000"))))
- (warnings (with-http-server `((,too-many "Rate limit reached."))
- (parameterize ((%swh-base-url (%local-url)))
- (append-map (lambda (name)
- (check-archival
- (dummy-package name (source origin))))
- '("x" "y" "z"))))))
- (string-contains (single-lint-warning-message warnings)
- "rate limit reached")))
- (test-assert "haskell-stackage"
- (let* ((stackage (string-append "{ \"packages\": [{"
- " \"name\":\"pandoc\","
- " \"synopsis\":\"synopsis\","
- " \"version\":\"1.0\" }],"
- " \"snapshot\": {"
- " \"ghc\": \"8.6.5\","
- " \"name\": \"lts-14.27\""
- " }}"))
- (packages (map (lambda (version)
- (dummy-package
- "ghc-pandoc"
- (version version)
- (source
- (dummy-origin
- (method url-fetch)
- (uri (string-append
- "https://hackage.haskell.org/package/"
- "pandoc-" version "/pandoc-" version ".tar.gz"))))))
- '("0.9" "1.0" "100.0")))
- (warnings (pk (with-http-server `((200 ,stackage) ; memoized
- (200 "name: pandoc\nversion: 1.0\n")
- (200 "name: pandoc\nversion: 1.0\n")
- (200 "name: pandoc\nversion: 1.0\n"))
- (parameterize ((%hackage-url (%local-url))
- (%stackage-url (%local-url)))
- (append-map check-haskell-stackage packages))))))
- (match warnings
- (((? lint-warning? warning))
- (and (string=? (package-version (lint-warning-package warning)) "100.0")
- (string-contains (lint-warning-message warning)
- "ahead of Stackage LTS version"))))))
- (test-end "lint")
- ;; Local Variables:
- ;; eval: (put 'with-http-server 'scheme-indent-function 1)
- ;; eval: (put 'with-warnings 'scheme-indent-function 0)
- ;; End:
|