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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit bfcb3d767bbc24dc6c6d834619073351fbcc61b5
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jul 13 00:50:05 2016 +0200

    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.
---
 guix/scripts/lint.scm |   17 +++++++++++++++-
 tests/lint.scm        |   52 ++++++++++++++++++++++++++++++++++++++-----------
 2 files changed, 57 insertions(+), 12 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index b4fdb6f..d5e9197 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/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
diff --git a/tests/lint.scm b/tests/lint.scm
index 1f1b0c9..ce751c4 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: