http.server.requests: if the content-length header is missing or invalid, a (controlled) error is thrown

basis/http/server/requests/requests-tests.factor

@@ -1,73 +1,37 @@
-USING: accessors assocs continuations http http.server http.server.requests
-io.streams.limited io.streams.string kernel multiline namespaces peg sequences
-splitting tools.test urls ;
+USING: accessors assocs continuations http http.client http.client.private
+http.server http.server.requests io.streams.limited io.streams.string kernel
+multiline namespaces peg sequences splitting tools.test urls ;
 IN: http.server.requests.tests
 
 : normalize-nl ( str -- str' )
     "\n" "\r\n" replace ;
 
+: request>string ( request -- string )
+    [ write-request ] with-string-writer ;
+
 : string>request ( str -- request )
-    normalize-nl
     [ request-limit get limited-input read-request ] with-string-reader ;
 
 ! POST requests
-STRING: test-post-no-content-type
-POST / HTTP/1.1
-connection: close
-host: 127.0.0.1:55532
-user-agent: Factor http.client
-content-length: 7
-
-foo=bar
-;
 { "foo=bar" "7" } [
-    test-post-no-content-type string>request
+    "foo=bar" "localhost" <post-request> request>string string>request
     [ post-data>> data>> ] [ header>> "content-length" of ] bi
 ] unit-test
 
-STRING: test-post-0-content-length
-POST / HTTP/1.1
-connection: close
-host: 127.0.0.1:55532
-user-agent: Factor http.client
-content-length: 0
-
-
-;
 { f "0" } [
-    test-post-0-content-length string>request
+    "" "localhost" <post-request> request>string string>request
     [ post-data>> data>> ] [ header>> "content-length" of ] bi
 ] unit-test
 
-! Should work no problem.
-STRING: test-post-wrong-content-length
-POST / HTTP/1.1
-connection: close
-host: 127.0.0.1:55532
-user-agent: Factor http.client
-Content-Type: application/x-www-form-urlencoded; charset=utf-8
-content-length: 190
-
-foo=bar
-;
+! Incorrect content-length works fine
 { H{ { "foo" "bar" } } } [
-    test-post-wrong-content-length string>request post-data>> params>>
+    { { "foo" "bar" } } "localhost" <post-request> request>string
+    "7" "190" replace string>request post-data>> params>>
 ] unit-test
 
-STRING: test-post-urlencoded
-POST / HTTP/1.1
-Accept: */*
-Accept-Encoding: gzip, deflate
-Connection: keep-alive
-Content-Length: 15
-Content-Type: application/x-www-form-urlencoded; charset=utf-8
-Host: news.ycombinator.com
-User-Agent: HTTPie/0.9.0-dev
-
-name=John+Smith
-;
 { H{ { "name" "John Smith" } } } [
-    test-post-urlencoded string>request post-data>> params>>
+    { { "name" "John Smith" } } "localhost" <post-request> request>string
+    string>request post-data>> params>>
 ] unit-test
 
 ! multipart/form-data
@@ -95,8 +59,8 @@ hello
           "form-data; name=\"text\"; filename=\"upload.txt\"" }
     }
 } [
-    test-multipart/form-data string>request post-data>> params>> "text" of
-    [ filename>> ] [ headers>> ] bi
+    test-multipart/form-data normalize-nl string>request
+    post-data>> params>> "text" of [ filename>> ] [ headers>> ] bi
 ] unit-test
 
 ! Error handling
@@ -119,21 +83,39 @@ hello
 --768de80194d942619886d23f1337aa15--
 
 ;
-{ t } [
-    [
-        test-multipart/form-data-missing-boundary string>request
-    ] [ no-boundary? ] recover
-] unit-test
+[ test-multipart/form-data-missing-boundary string>request ]
+[ no-boundary? ] must-fail-with
 
 ! Relative urls are invalid.
-{ "foo" } [
-    [ "GET foo HTTP/1.1" string>request ] [ path>> ] recover
-] unit-test
+[ "GET foo HTTP/1.1" string>request ] [ path>> "foo" = ] must-fail-with
 
 ! Empty request lines
-{ t } [
-    [ "" string>request ] [ parse-error>> parse-error? ] recover
-] unit-test
+[ "" string>request ] [ parse-error>> parse-error? ] must-fail-with
+
+! Missing content-length is probably not ok. It's plausible
+! transfer-length could replace it, but we don't handle it atm anyway.
+[
+    { { "foo" "bar" } } "localhost" <post-request> request>string
+    "content-length" "foo" replace string>request
+] [ content-length-missing? ] must-fail-with
+
+! Non-numeric content-length is ofc crap.
+[
+    { { "foo" "bar" } } "localhost" <post-request> request>string
+    "7" "i am not a number!" replace string>request
+] [
+    [ invalid-content-length? ]
+    [ content-length>> "i am not a number!" = ] bi and
+] must-fail-with
+
+! Negative is it too.
+[
+    { { "foo" "bar" } } "localhost" <post-request> request>string
+    "7" "-1234" replace string>request
+] [
+    [ invalid-content-length? ]
+    [ content-length>> -1234 = ] bi and
+] must-fail-with
 
 ! RFC 2616: Section 4.1
 ! In the interest of robustness, servers SHOULD ignore any empty

basis/http/server/requests/requests.factor

@@ -1,5 +1,5 @@
 USING: accessors combinators continuations http http.parsers io io.crlf
-io.encodings io.encodings.binary io.streams.limited kernel math.order
+io.encodings io.encodings.binary io.streams.limited kernel math math.order
 math.parser namespaces sequences splitting urls urls.encoding ;
 FROM: mime.multipart => parse-multipart ;
 IN: http.server.requests
@@ -10,6 +10,10 @@ ERROR: no-boundary < request-error ;
 
 ERROR: invalid-path < request-error path ;
 
+ERROR: invalid-content-length < request-error content-length ;
+
+ERROR: content-length-missing < request-error ;
+
 ERROR: bad-request-line < request-error parse-error ;
 
 : check-absolute ( url -- )
@@ -34,22 +38,28 @@ upload-limit [ 200,000,000 ] initialize
     ";" split1 nip
     "=" split1 nip [ no-boundary ] unless* ;
 
-: read-multipart-data ( request -- mime-parts )
-    [ "content-type" header ]
-    [ "content-length" header string>number ] bi
-    unlimited-input
-    upload-limit get [ min ] when* limited-input
-    binary decode-input
-    parse-multipart-form-data parse-multipart ;
+: maybe-limit-input ( content-length -- )
+    unlimited-input upload-limit get [ min ] when* limited-input ;
 
-: read-content ( request -- bytes )
-    "content-length" header string>number read ;
+: read-multipart-data ( request content-length -- mime-parts )
+    maybe-limit-input binary decode-input
+    "content-type" header parse-multipart-form-data parse-multipart ;
+
+: parse-content-length-safe ( request -- content-length )
+    "content-length" header [
+        dup string>number [
+            nip dup 0 >= [ invalid-content-length ] unless
+        ] [ invalid-content-length ] if*
+    ] [ content-length-missing ] if* ;
 
 : parse-content ( request content-type -- post-data )
-    [ <post-data> swap ] keep {
+    dup <post-data> -rot over parse-content-length-safe swap
+    {
         { "multipart/form-data" [ read-multipart-data >>params ] }
-        { "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
-        [ drop read-content >>data ]
+        { "application/x-www-form-urlencoded" [
+            nip read query>assoc >>params
+        ] }
+        [ drop nip read >>data ]
     } case ;
 
 : read-post-data ( request -- request )