lint: 'validate-uri' reports suspiciously small 200 responses.

* guix/scripts/lint.scm (validate-uri): Upon 200 http-response, check
the 'response-content-length' and emit a warning when it is <= 1000.
* tests/lint.scm (call-with-http-server): Add 'data' parameter.
(with-http-server): Likewise.
(%long-string): New variable.
("home-page: 200"): Pass %LONG-STRING to 'with-http-server'.
("home-page: 404", "source: 200", "source: 404"): Likewise.
("home-page: 200 but short length"): New test.
("source: 200 but short length"): New test.

1 files changed, 41 insertions, 11 deletions

diff --git a/tests/lint.scm b/tests/lint.scm
index 1f1b0c95e9..ce751c42c9 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -102,14 +102,14 @@
   http-write
   (@@ (web server http) http-close))
 
-(define (call-with-http-server code thunk)
-  "Call THUNK with an HTTP server running and returning CODE on HTTP
-requests."
+(define (call-with-http-server code data thunk)
+  "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
   (define (server-body)
     (define (handle request body)
       (values (build-response #:code code
                               #:reason-phrase "Such is life")
-              "Hello, world."))
+              data))
 
     (catch 'quit
       (lambda ()
@@ -123,8 +123,11 @@ requests."
       ;; Normally SERVER exits automatically once it has received a request.
       (thunk))))
 
-(define-syntax-rule (with-http-server code body ...)
-  (call-with-http-server code (lambda () body ...)))
+(define-syntax-rule (with-http-server code data body ...)
+  (call-with-http-server code data (lambda () body ...)))
+
+(define %long-string
+  (make-string 2000 #\a))
 
 
 (test-begin "lint")
@@ -402,18 +405,30 @@ requests."
 (test-equal "home-page: 200"
   ""
   (with-warnings
-   (with-http-server 200
+   (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-socket 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-socket 0 1))
 (test-assert "home-page: 404"
   (->bool
    (string-contains
     (with-warnings
-      (with-http-server 404
+      (with-http-server 404 %long-string
         (let ((pkg (package
                      (inherit (dummy-package "x"))
                      (home-page %local-url))))
@@ -501,7 +516,7 @@ requests."
 (test-equal "source: 200"
   ""
   (with-warnings
-   (with-http-server 200
+   (with-http-server 200 %long-string
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (source (origin
@@ -511,11 +526,26 @@ requests."
        (check-source pkg)))))
 
 (test-skip (if %http-server-socket 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-socket 0 1))
 (test-assert "source: 404"
   (->bool
    (string-contains
     (with-warnings
-      (with-http-server 404
+      (with-http-server 404 %long-string
         (let ((pkg (package
                      (inherit (dummy-package "x"))
                      (source (origin
@@ -617,6 +647,6 @@ requests."
 (test-end "lint")
 
 ;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 1)
+;; eval: (put 'with-http-server 'scheme-indent-function 2)
 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 ;; End: