tests/lint.scm

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346 2016-03-24 build: Bump version number.... Ludovic Courtès
;;; 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, 2015, 2016, 2017, 2018 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 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; 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 build-system gnu)
  #:use-module (guix packages)
  #:use-module (guix scripts lint)
  #:use-module (guix ui)
  #:use-module (gnu packages)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages python-xyz)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (web server http)
  #:use-module (web response)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-64))

;; Test the linter.

;; Avoid collisions with other tests.
(%http-server-port 9999)

(define %null-sha256
  ;; SHA256 of the empty string.
  (base32
   "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))

(define %long-string
  (make-string 2000 #\a))


(test-begin "lint")

(define (call-with-warnings thunk)
  (let ((port (open-output-string)))
    (parameterize ((guix-warning-port port))
      (thunk))
    (get-output-string port)))

(define-syntax-rule (with-warnings body ...)
  (call-with-warnings (lambda () body ...)))

(test-assert "description: not a string"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description 'foobar))))
                        (check-description-style pkg)))
                    "invalid description")))

(test-assert "description: not empty"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description ""))))
                        (check-description-style pkg)))
                    "description should not be empty")))

(test-assert "description: valid Texinfo markup"
  (->bool
   (string-contains
    (with-warnings
      (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
    "Texinfo markup in description is invalid")))

(test-assert "description: does not start with an upper-case letter"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description "bad description."))))
                        (check-description-style pkg)))
                    "description should start with an upper-case letter")))

(test-assert "description: may start with a digit"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (description "2-component library."))))
       (check-description-style pkg)))))

(test-assert "description: may start with lower-case package name"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (description "x is a dummy package."))))
       (check-description-style pkg)))))

(test-assert "description: two spaces after end of sentence"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description "Bad. Quite bad."))))
                        (check-description-style pkg)))
                    "sentences in description should be followed by two spaces")))

(test-assert "description: end-of-sentence detection with abbreviations"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (description
                   "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
       (check-description-style pkg)))))

(test-assert "description: may not contain trademark signs"
  (and (->bool
        (string-contains (with-warnings
                           (let ((pkg (dummy-package "x"
                                        (description "Does The Right Thing™"))))
                             (check-description-style pkg)))
                         "should not contain trademark sign"))
       (->bool
        (string-contains (with-warnings
                           (let ((pkg (dummy-package "x"
                                        (description "Works with Format®"))))
                             (check-description-style pkg)))
                         "should not contain trademark sign"))))

(test-assert "description: suggest ornament instead of quotes"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description "This is a 'quoted' thing."))))
                        (check-description-style pkg)))
                    "use @code")))

(test-assert "synopsis: not a string"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis #f))))
                        (check-synopsis-style pkg)))
                    "invalid synopsis")))

(test-assert "synopsis: not empty"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis ""))))
                        (check-synopsis-style pkg)))
                    "synopsis should not be empty")))

(test-assert "synopsis: valid Texinfo markup"
  (->bool
   (string-contains
    (with-warnings
      (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
    "Texinfo markup in synopsis is invalid")))

(test-assert "synopsis: does not start with an upper-case letter"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "bad synopsis."))))
                        (check-synopsis-style pkg)))
                    "synopsis should start with an upper-case letter")))

(test-assert "synopsis: may start with a digit"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (synopsis "5-dimensional frobnicator"))))
       (check-synopsis-style pkg)))))

(test-assert "synopsis: ends with a period"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "Bad synopsis."))))
                        (check-synopsis-style pkg)))
                    "no period allowed at the end of the synopsis")))

(test-assert "synopsis: ends with 'etc.'"
  (string-null? (with-warnings
                  (let ((pkg (dummy-package "x"
                               (synopsis "Foo, bar, etc."))))
                    (check-synopsis-style pkg)))))

(test-assert "synopsis: starts with 'A'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "A bad synopŝis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: starts with 'An'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "An awful synopsis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: starts with 'a'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "a bad synopsis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: starts with 'an'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "an awful synopsis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: too long"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis (make-string 80 #\x)))))
                        (check-synopsis-style pkg)))
                    "synopsis should be less than 80 characters long")))

(test-assert "synopsis: start with package name"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (name "foo")
                                   (synopsis "foo, a nice package"))))
                        (check-synopsis-style pkg)))
                    "synopsis should not start with the package name")))

(test-assert "synopsis: start with package name prefix"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "arb"
                  (synopsis "Arbitrary precision"))))
       (check-synopsis-style pkg)))))

(test-assert "synopsis: start with abbreviation"
  (string-null?
   (with-warnings
     (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-assert "inputs: pkg-config is probably a native input"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (inputs `(("pkg-config" ,pkg-config))))))
         (check-inputs-should-be-native pkg)))
         "'pkg-config' should probably be a native input")))

(test-assert "inputs: glib:bin is probably a native input"
  (->bool
    (string-contains
      (with-warnings
        (let ((pkg (dummy-package "x"
                     (inputs `(("glib" ,glib "bin"))))))
          (check-inputs-should-be-native pkg)))
          "'glib:bin' should probably be a native input")))

(test-assert
    "inputs: python-setuptools should not be an input at all (input)"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (inputs `(("python-setuptools" ,python-setuptools))))))
         (check-inputs-should-not-be-an-input-at-all pkg)))
         "'python-setuptools' should probably not be an input at all")))

(test-assert
    "inputs: python-setuptools should not be an input at all (native-input)"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (native-inputs
                     `(("python-setuptools" ,python-setuptools))))))
         (check-inputs-should-not-be-an-input-at-all pkg)))
         "'python-setuptools' should probably not be an input at all")))

(test-assert
    "inputs: python-setuptools should not be an input at all (propagated-input)"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (propagated-inputs
                     `(("python-setuptools" ,python-setuptools))))))
         (check-inputs-should-not-be-an-input-at-all pkg)))
         "'python-setuptools' should probably not be an input at all")))

(test-assert "patches: file names"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (dummy-origin
                       (patches (list "/path/to/y.patch")))))))
         (check-patch-file-names pkg)))
     "file names of patches should start with the package name")))

(test-assert "patches: file name too long"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (dummy-origin
                      (patches (list (string-append "x-"
                                                    (make-string 100 #\a)
                                                    ".patch"))))))))
         (check-patch-file-names pkg)))
     "file name is too long")))

(test-assert "patches: not found"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (dummy-origin
                       (patches
                        (list (search-patch "this-patch-does-not-exist!"))))))))
         (check-patch-file-names pkg)))
     "patch not found")))

(test-assert "derivation: invalid arguments"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (dummy-package "x"
                   (arguments
                    '(#:imported-modules (invalid-module))))))
        (check-derivation pkg)))
    "failed to create")))

(test-assert "license: invalid license"
  (string-contains
   (with-warnings
     (check-license (dummy-package "x" (license #f))))
   "invalid license"))

(test-assert "home-page: wrong home-page"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page #f))))
        (check-home-page pkg)))
    "invalid")))

(test-assert "home-page: invalid URI"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page "foobar"))))
        (check-home-page pkg)))
    "invalid home page URL")))

(test-assert "home-page: host not found"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page "http://does-not-exist"))))
        (check-home-page pkg)))
    "domain not found")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: Connection refused"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page (%local-url)))))
        (check-home-page pkg)))
    "Connection refused")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200"
  ""
  (with-warnings
   (with-http-server 200 %long-string
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
       (check-home-page pkg)))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 200 but short length"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 200 "This is too small."
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (home-page (%local-url)))))
          (check-home-page pkg))))
    "suspiciously small")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 %long-string
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (home-page (%local-url)))))
          (check-home-page pkg))))
    "not reachable: 404")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 301, invalid"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 301 %long-string
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (home-page (%local-url)))))
          (check-home-page pkg))))
    "invalid permanent redirect")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 301 -> 200"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 200 %long-string
        (let ((initial-url (%local-url)))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server (301 `((location
                                      . ,(string->uri initial-url))))
                ""
              (let ((pkg (package
                           (inherit (dummy-package "x"))
                           (home-page (%local-url)))))
                (check-home-page pkg)))))))
    "permanent redirect")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 301 -> 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 "booh!"
        (let ((initial-url (%local-url)))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server (301 `((location
                                      . ,(string->uri initial-url))))
                ""
              (let ((pkg (package
                           (inherit (dummy-package "x"))
                           (home-page (%local-url)))))
                (check-home-page pkg)))))))
    "not reachable: 404")))

(test-assert "source-file-name"
  (->bool
   (string-contains
    (with-warnings
      (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))))))
        (check-source-file-name pkg)))
    "file name should contain the package name")))

(test-assert "source-file-name: v prefix"
  (->bool
   (string-contains
    (with-warnings
      (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))))))
        (check-source-file-name pkg)))
    "file name should contain the package name")))

(test-assert "source-file-name: bad checkout"
  (->bool
   (string-contains
    (with-warnings
      (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))))))
        (check-source-file-name pkg)))
    "file name should contain the package name")))

(test-assert "source-file-name: good checkout"
  (not
   (->bool
    (string-contains
     (with-warnings
       (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)))
     "file name should contain the package name"))))

(test-assert "source-file-name: valid"
  (not
   (->bool
    (string-contains
     (with-warnings
       (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)))
     "file name should contain the package name"))))

(test-assert "source-unstable-tarball"
  (string-contains
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (source
                    (origin
                      (method url-fetch)
                      (uri "https://github.com/example/example/archive/v0.0.tar.gz")
                      (sha256 %null-sha256))))))
       (check-source-unstable-tarball pkg)))
   "source URI should not be an autogenerated tarball"))

(test-assert "source-unstable-tarball: source #f"
  (not
    (->bool
     (string-contains
      (with-warnings
        (let ((pkg (dummy-package "x"
                     (source #f))))
          (check-source-unstable-tarball pkg)))
      "source URI should not be an autogenerated tarball"))))

(test-assert "source-unstable-tarball: valid"
  (not
    (->bool
     (string-contains
      (with-warnings
        (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)))
      "source URI should not be an autogenerated tarball"))))

(test-assert "source-unstable-tarball: package named archive"
  (not
    (->bool
     (string-contains
      (with-warnings
        (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)))
      "source URI should not be an autogenerated tarball"))))

(test-assert "source-unstable-tarball: not-github"
  (not
    (->bool
     (string-contains
      (with-warnings
        (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)))
      "source URI should not be an autogenerated tarball"))))

(test-assert "source-unstable-tarball: git-fetch"
  (not
    (->bool
     (string-contains
      (with-warnings
        (let ((pkg (dummy-package "x"
                     (source
                       (origin
                         (method git-fetch)
                         (uri (git-reference
                                (url "https://github.com/archive/example.git")
                                (commit "0")))
                         (sha256 %null-sha256))))))
          (check-source-unstable-tarball pkg)))
      "source URI should not be an autogenerated tarball"))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
  ""
  (with-warnings
   (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)))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "source: 200 but short length"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 200 "This is too small."
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (source (origin
                               (method url-fetch)
                               (uri (%local-url))
                               (sha256 %null-sha256))))))
          (check-source pkg))))
    "suspiciously small")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "source: 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 %long-string
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (source (origin
                               (method url-fetch)
                               (uri (%local-url))
                               (sha256 %null-sha256))))))
          (check-source pkg))))
    "not reachable: 404")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 200"
  ""
  (with-warnings
    (with-http-server 200 %long-string
      (let ((initial-url (%local-url)))
        (parameterize ((%http-server-port (+ 1 (%http-server-port))))
          (with-http-server (301 `((location . ,(string->uri initial-url))))
              ""
            (let ((pkg (package
                         (inherit (dummy-package "x"))
                         (source (origin
                                   (method url-fetch)
                                   (uri (%local-url))
                                   (sha256 %null-sha256))))))
              (check-source pkg))))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "source: 301 -> 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 "booh!"
        (let ((initial-url (%local-url)))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server (301 `((location . ,(string->uri initial-url))))
                ""
              (let ((pkg (package
                           (inherit (dummy-package "x"))
                           (source (origin
                                     (method url-fetch)
                                     (uri (%local-url))
                                     (sha256 %null-sha256))))))
                (check-source pkg)))))))
    "not reachable: 404")))

(test-assert "mirror-url"
  (string-null?
   (with-warnings
     (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-assert "mirror-url: one suggestion"
  (string-contains
   (with-warnings
     (let ((source (origin
                     (method url-fetch)
                     (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
                     (sha256 %null-sha256))))
       (check-mirror-url (dummy-package "x" (source source)))))
   "mirror://gnu/foo/foo.tar.gz"))

(test-assert "github-url"
  (string-null?
   (with-warnings
     (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-assert "github-url: one suggestion"
    (string-contains
     (with-warnings
       (with-http-server (301 `((location . ,(string->uri github-url)))) ""
         (let ((initial-uri (%local-url)))
           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
             (with-http-server (302 `((location . ,(string->uri initial-uri)))) ""
               (check-github-url
                (dummy-package "x" (source
                                    (origin
                                      (method url-fetch)
                                      (uri (%local-url))
                                      (sha256 %null-sha256))))))))))
     github-url))
  (test-assert "github-url: already the correct github url"
    (string-null?
     (with-warnings
       (check-github-url
        (dummy-package "x" (source
                            (origin
                              (method url-fetch)
                              (uri github-url)
                              (sha256 %null-sha256)))))))))

(test-assert "cve"
  (mock ((guix scripts lint) package-vulnerabilities (const '()))
        (string-null?
         (with-warnings (check-vulnerabilities (dummy-package "x"))))))

(test-assert "cve: one vulnerability"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-contains
         (with-warnings
           (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
         "vulnerable to CVE-2015-1234")))

(test-assert "cve: one patched vulnerability"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-null?
         (with-warnings
           (check-vulnerabilities
            (dummy-package "pi"
                           (version "3.14")
                           (source
                            (dummy-origin
                             (patches
                              (list "/a/b/pi-CVE-2015-1234.patch"))))))))))

(test-assert "cve: known safe from vulnerability"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-null?
         (with-warnings
           (check-vulnerabilities
            (dummy-package "pi"
                           (version "3.14")
                           (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))

(test-assert "cve: vulnerability fixed in replacement version"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (match (package-version package)
             ("0"
              (list (make-struct (@@ (guix cve) <vulnerability>) 0
                                 "CVE-2015-1234"
                                 (list (cons (package-name package)
                                             (package-version package))))))
             ("1"
              '()))))
        (and (not (string-null?
                   (with-warnings
                     (check-vulnerabilities
                      (dummy-package "foo" (version "0"))))))
             (string-null?
              (with-warnings
                (check-vulnerabilities
                 (dummy-package
                  "foo" (version "0")
                  (replacement (dummy-package "foo" (version "1"))))))))))

(test-assert "cve: patched vulnerability in replacement"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-null?
         (with-warnings
           (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-assert "formatting: lonely parentheses"
  (string-contains
   (with-warnings
     (check-formatting
      (
       dummy-package "ugly as hell!"
      )
      ))
   "lonely"))

(test-assert "formatting: tabulation"
  (string-contains
   (with-warnings
     (check-formatting (dummy-package "leave the tab here:	")))
   "tabulation"))

(test-assert "formatting: trailing white space"
  (string-contains
   (with-warnings
     ;; Leave the trailing white space on the next line!
     (check-formatting (dummy-package "x")))            
   "trailing white space"))

(test-assert "formatting: long line"
  (string-contains
   (with-warnings
     (check-formatting
      (dummy-package "x"                          ;here is a stupid comment just to make a long line
                     )))
   "too long"))

(test-assert "formatting: alright"
  (string-null?
   (with-warnings
     (check-formatting (dummy-package "x")))))

(test-end "lint")

;; Local Variables:
;; eval: (put 'with-http-server 'scheme-indent-function 2)
;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End: