2 files changed, 57 insertions(+), 12 deletions(-)

M guix/scripts/lint.scm
M tests/lint.scm

@@ 359,7 359,22 @@ warning for PACKAGE mentionning the FIELD."
                 (probe-uri uri #:timeout 3)))     ;wait at most 3 seconds
     (case status
       ((http-response)
-       (or (= 200 (response-code argument))
+       (if (= 200 (response-code argument))
+           (match (response-content-length argument)
+             ((? number? length)
+              ;; As of July 2016, SourceForge returns 200 (instead of 404)
+              ;; with a small HTML page upon failure.  Attempt to detect such
+              ;; malicious behavior.
+              (or (> length 1000)
+                  (begin
+                    (emit-warning package
+                                  (format #f
+                                          (_ "URI ~a returned \
+suspiciously small file (~a bytes)")
+                                          (uri->string uri)
+                                          length))
+                    #f)))
+             (_ #t))
            (begin
              (emit-warning package
                            (format #f

@@ 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: