diff options
| -rw-r--r-- | guix/scripts/lint.scm | 17 | ||||
| -rw-r--r-- | tests/lint.scm | 52 |
2 files changed, 57 insertions, 12 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b4fdb6f905..d5e9197cc9 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 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: |