From ea116e2f10256171cdfd039099091084adefa533 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sat, 19 Dec 2020 06:24:58 +0000 Subject: [PATCH 1/3] Remove all suites and *-test-suite-app libraries Also added a section on testing to README.rst --- README.rst | 20 +++++++ .../http-client-test-suite-app-library.dylan | 12 ---- client/tests/http-client-test-suite-app.dylan | 4 -- client/tests/http-client-test-suite-app.lid | 3 - .../http-common-test-suite-app-library.dylan | 12 ---- common/tests/http-common-test-suite-app.dylan | 4 -- common/tests/http-common-test-suite-app.lid | 3 - .../http-common-test-suite-library.dylan | 5 +- common/tests/http-common-test-suite.dylan | 54 ++++-------------- .../http-server-test-suite-app-library.dylan | 32 ----------- server/tests/http-server-test-suite-app.dylan | 15 ----- server/tests/http-server-test-suite-app.lid | 3 - ...http-protocol-test-suite-app-library.dylan | 11 ---- tests/http-protocol-test-suite-app.dylan | 3 - tests/http-protocol-test-suite-app.lid | 4 -- tests/http-protocol-test-suite-library.dylan | 6 +- tests/http-protocol-test-suite.dylan | 57 +++++-------------- tests/http-test-suite-app-library.dylan | 12 ---- tests/http-test-suite-app.dylan | 4 -- tests/http-test-suite-app.lid | 3 - tests/http-test-suite-library.dylan | 6 +- tests/http-test-suite.dylan | 9 --- tests/http-test-suite.lid | 1 - 23 files changed, 50 insertions(+), 233 deletions(-) delete mode 100644 client/tests/http-client-test-suite-app-library.dylan delete mode 100644 client/tests/http-client-test-suite-app.dylan delete mode 100644 client/tests/http-client-test-suite-app.lid delete mode 100644 common/tests/http-common-test-suite-app-library.dylan delete mode 100644 common/tests/http-common-test-suite-app.dylan delete mode 100644 common/tests/http-common-test-suite-app.lid delete mode 100644 server/tests/http-server-test-suite-app-library.dylan delete mode 100644 server/tests/http-server-test-suite-app.dylan delete mode 100644 server/tests/http-server-test-suite-app.lid delete mode 100644 tests/http-protocol-test-suite-app-library.dylan delete mode 100644 tests/http-protocol-test-suite-app.dylan delete mode 100644 tests/http-protocol-test-suite-app.lid delete mode 100644 tests/http-test-suite-app-library.dylan delete mode 100644 tests/http-test-suite-app.dylan delete mode 100644 tests/http-test-suite-app.lid delete mode 100644 tests/http-test-suite.dylan diff --git a/README.rst b/README.rst index 527f252..740f81a 100644 --- a/README.rst +++ b/README.rst @@ -21,3 +21,23 @@ them on your ``PYTHONPATH``:: You can clone sphinx-extensions with:: git clone git@github.com:dylan-lang/sphinx-extensions + + +Testing +======= + +As of Dec 2020 there are serious problems with the tests and many of them hang. +Fixing this should be #1 priority. + +However, in general, to run all the tests:: + + $ dylan-compiler -build http-test-suite + $ dylan-compiler -build testworks-run + $ _build/bin/testworks-run --load libhttp-test-suite.so + +Or you may run one of the more specific test suites:: + + $ _build/bin/testworks-run --load libhttp-server-test-suite.so + $ _build/bin/testworks-run --load libhttp-client-test-suite.so + $ _build/bin/testworks-run --load libhttp-common-test-suite.so + $ _build/bin/testworks-run --load libhttp-protocol-test-suite.so diff --git a/client/tests/http-client-test-suite-app-library.dylan b/client/tests/http-client-test-suite-app-library.dylan deleted file mode 100644 index 23d5257..0000000 --- a/client/tests/http-client-test-suite-app-library.dylan +++ /dev/null @@ -1,12 +0,0 @@ -Module: dylan-user -Copyright: See LICENSE in this distribution for details. - -define library http-client-test-suite-app - use http-client-test-suite; - use testworks; -end; - -define module http-client-test-suite-app - use http-client-test-suite; - use testworks; -end; diff --git a/client/tests/http-client-test-suite-app.dylan b/client/tests/http-client-test-suite-app.dylan deleted file mode 100644 index 22f43f9..0000000 --- a/client/tests/http-client-test-suite-app.dylan +++ /dev/null @@ -1,4 +0,0 @@ -Module: http-client-test-suite-app -Copyright: See LICENSE in this distribution for details. - -run-test-application(http-client-test-suite); diff --git a/client/tests/http-client-test-suite-app.lid b/client/tests/http-client-test-suite-app.lid deleted file mode 100644 index 0377e0e..0000000 --- a/client/tests/http-client-test-suite-app.lid +++ /dev/null @@ -1,3 +0,0 @@ -library: http-client-test-suite-app -files: http-client-test-suite-app-library - http-client-test-suite-app diff --git a/common/tests/http-common-test-suite-app-library.dylan b/common/tests/http-common-test-suite-app-library.dylan deleted file mode 100644 index 1b614d7..0000000 --- a/common/tests/http-common-test-suite-app-library.dylan +++ /dev/null @@ -1,12 +0,0 @@ -Module: dylan-user -Copyright: See LICENSE in this distribution for details. - -define library http-common-test-suite-app - use http-common-test-suite; - use testworks; -end; - -define module http-common-test-suite-app - use http-common-test-suite; - use testworks; -end; diff --git a/common/tests/http-common-test-suite-app.dylan b/common/tests/http-common-test-suite-app.dylan deleted file mode 100644 index 23a7243..0000000 --- a/common/tests/http-common-test-suite-app.dylan +++ /dev/null @@ -1,4 +0,0 @@ -Module: http-common-test-suite-app -Copyright: See LICENSE in this distribution for details. - -run-test-application(http-common-test-suite); diff --git a/common/tests/http-common-test-suite-app.lid b/common/tests/http-common-test-suite-app.lid deleted file mode 100644 index b53156b..0000000 --- a/common/tests/http-common-test-suite-app.lid +++ /dev/null @@ -1,3 +0,0 @@ -library: http-common-test-suite-app -files: http-common-test-suite-app-library - http-common-test-suite-app diff --git a/common/tests/http-common-test-suite-library.dylan b/common/tests/http-common-test-suite-library.dylan index f1209e1..43dce48 100644 --- a/common/tests/http-common-test-suite-library.dylan +++ b/common/tests/http-common-test-suite-library.dylan @@ -8,7 +8,7 @@ define library http-common-test-suite use testworks; use io; export http-common-test-suite; -end; +end library; define module http-common-test-suite use common-dylan; @@ -16,6 +16,5 @@ define module http-common-test-suite use http-common-internals; use testworks; use format; - export http-common-test-suite; -end; +end module; diff --git a/common/tests/http-common-test-suite.dylan b/common/tests/http-common-test-suite.dylan index b8ec70e..a708414 100644 --- a/common/tests/http-common-test-suite.dylan +++ b/common/tests/http-common-test-suite.dylan @@ -2,8 +2,6 @@ Module: http-common-test-suite Copyright: See LICENSE in this distribution for details. -//// --- parsing test suite --- - define test test-quality-value () for (pair in #[#["0.2", 0.2], #["0.02", 0.02], @@ -16,14 +14,7 @@ define test test-quality-value () expected, quality-value(string, 0, string.size)); end; -end test test-quality-value; - -define suite parsing-test-suite () - test test-quality-value; -end; - - -//// --- headers test suite --- +end test; // See also: test-parse-media-type define test test-accept-header () @@ -32,14 +23,7 @@ define test test-accept-header () list(make-media-type("audio", "*", #["q", 0.5], #["r", "2"]), make-media-type("audio", "mp3", #["q", 1.0])), parse-header-value(#"accept", raw-header)); -end test test-accept-header; - -define suite headers-test-suite () - test test-accept-header; -end; - - -//// --- media-type test suite --- +end test; define function make-media-type (type :: , subtype :: , #rest attributes) @@ -51,13 +35,13 @@ define function make-media-type type: type, subtype: subtype, attributes: attrs) -end; +end function; define function parse-media-type-helper (media-type :: ) => (media-type :: ) parse-media-type(media-type, 0, media-type.size) -end; +end function; define constant text/plain = make-media-type("text", "plain"); @@ -106,7 +90,7 @@ define test test-parse-media-type () check-equal("parse-media-type converts level to integer?", 2, media-type-level(parse-media-type-helper("text/plain; q=0.3; level=2"))); -end test test-parse-media-type; +end test; define test test-match-media-types () for (item in list(list("text", "plain"), @@ -132,7 +116,7 @@ define test test-match-media-types () check-false(format-to-string("media-types-match?(text/plain, %s/%s) is false?", t, s), match-media-types(text/plain, make-media-type(t, s))); end; -end test test-match-media-types; +end test; define test test-media-type-more-specific? () let text/html-level-1 = make-media-type("text", "html", #["level", 1]); @@ -143,7 +127,7 @@ define test test-media-type-more-specific? () list(text/html-level-1, text/html, text/*, wild/*), // expected sort(list(text/*, text/html, text/html-level-1, wild/*), test: media-type-more-specific?)); -end test test-media-type-more-specific?; +end test; define test test-media-type-exact? () check-true("media-type-exact?(text/plain)", media-type-exact?(text/plain)); @@ -151,7 +135,7 @@ define test test-media-type-exact? () media-type-exact?(make-media-type("text", $mime-wild))); check-false("media-type-exact?(*/*)", media-type-exact?(make-media-type($mime-wild, $mime-wild))); -end test test-media-type-exact?; +end test; define test test-media-type-quality () check-equal("'q' attribute defines media type quality value?", @@ -160,29 +144,11 @@ define test test-media-type-quality () check-equal("Default quality value is 1.0?", 1.0, make-media-type("a", "b").media-type-quality); -end test test-media-type-quality; +end test; define test test-media-type-level () check-equal("'level' attribute defines media type level?", 2, make-media-type("a", "b", #["level", 2]).media-type-level); check-false("Default level is #f?", make-media-type("a", "b").media-type-level); -end test test-media-type-level; - -define suite media-type-test-suite () - test test-parse-media-type; - test test-media-type-quality; - test test-media-type-level; - test test-media-type-exact?; - test test-media-type-more-specific?; - test test-match-media-types; -end suite media-type-test-suite; - - -//// --- top level suite --- - -define suite http-common-test-suite () - suite parsing-test-suite; - suite headers-test-suite; - suite media-type-test-suite; -end; +end test; diff --git a/server/tests/http-server-test-suite-app-library.dylan b/server/tests/http-server-test-suite-app-library.dylan deleted file mode 100644 index f2f7ab6..0000000 --- a/server/tests/http-server-test-suite-app-library.dylan +++ /dev/null @@ -1,32 +0,0 @@ -Module: dylan-user - -define library http-server-test-suite-app - use common-dylan; - use http-client; - use http-common; - use http-server; - use http-server-test-suite; - use logging; - use system, - import: { operating-system }; - use testworks; -end library http-server-test-suite-app; - -define module http-server-test-suite-app - use common-dylan; - use http-client, - import: { *http-client-log* }; - use http-common, - import: { *http-common-log* }; - use http-server, - import: { *log-content?* }; - use http-server-test-suite, - import: { http-server-test-suite }; - use logging, - import: { log-level-setter, - $trace-level }; - use operating-system, - import: { environment-variable }; - use testworks, - import: { run-test-application }; -end module http-server-test-suite-app; diff --git a/server/tests/http-server-test-suite-app.dylan b/server/tests/http-server-test-suite-app.dylan deleted file mode 100644 index d412693..0000000 --- a/server/tests/http-server-test-suite-app.dylan +++ /dev/null @@ -1,15 +0,0 @@ -Module: http-server-test-suite-app - - -define function main () => () - // Run the test suite. - // Show all request/response headers and message content. - *http-common-log*.log-level := $trace-level; - *http-client-log*.log-level := $trace-level; - *log-content?* := #f; // http-server variable, not yet configurable. - run-test-application(http-server-test-suite); -end function main; - -begin - main() -end; diff --git a/server/tests/http-server-test-suite-app.lid b/server/tests/http-server-test-suite-app.lid deleted file mode 100644 index f09c8ac..0000000 --- a/server/tests/http-server-test-suite-app.lid +++ /dev/null @@ -1,3 +0,0 @@ -Library: http-server-test-suite-app -Files: http-server-test-suite-app-library - http-server-test-suite-app diff --git a/tests/http-protocol-test-suite-app-library.dylan b/tests/http-protocol-test-suite-app-library.dylan deleted file mode 100644 index 35c69ae..0000000 --- a/tests/http-protocol-test-suite-app-library.dylan +++ /dev/null @@ -1,11 +0,0 @@ -module: dylan-user - -define library http-protocol-test-suite-app - use testworks; - use http-protocol-test-suite; -end library; - -define module http-protocol-test-suite-app - use testworks; - use http-protocol-test-suite; -end module; diff --git a/tests/http-protocol-test-suite-app.dylan b/tests/http-protocol-test-suite-app.dylan deleted file mode 100644 index 6841622..0000000 --- a/tests/http-protocol-test-suite-app.dylan +++ /dev/null @@ -1,3 +0,0 @@ -module: http-protocol-test-suite-app - -run-test-application(http-protocol-test-suite); diff --git a/tests/http-protocol-test-suite-app.lid b/tests/http-protocol-test-suite-app.lid deleted file mode 100644 index a6d84f4..0000000 --- a/tests/http-protocol-test-suite-app.lid +++ /dev/null @@ -1,4 +0,0 @@ -library: http-protocol-test-suite-app -executable: http-protocol-test-suite-app -files: http-protocol-test-suite-app-library - http-protocol-test-suite-app diff --git a/tests/http-protocol-test-suite-library.dylan b/tests/http-protocol-test-suite-library.dylan index 0b8a8de..cf49f92 100644 --- a/tests/http-protocol-test-suite-library.dylan +++ b/tests/http-protocol-test-suite-library.dylan @@ -12,7 +12,7 @@ define library http-protocol-test-suite use strings; export http-protocol-test-suite; -end library http-protocol-test-suite; +end library; define module http-protocol-test-suite use common-dylan; @@ -24,6 +24,4 @@ define module http-protocol-test-suite use testworks; use uri; use strings; - - export http-protocol-test-suite; -end module http-protocol-test-suite; +end module; diff --git a/tests/http-protocol-test-suite.dylan b/tests/http-protocol-test-suite.dylan index 54be2c9..bdd2df2 100644 --- a/tests/http-protocol-test-suite.dylan +++ b/tests/http-protocol-test-suite.dylan @@ -23,7 +23,7 @@ define function full-url parse-url(fmt("http://%s:%d%s", *test-host*, *test-port*, join(segments, "/"))); end function full-url; - +//--------------------------------------------------------------------- define test test-options-method (tags: #("online")) let response = http-options(full-url("/")); @@ -31,7 +31,7 @@ define test test-options-method (tags: #("online")) assert-equal(#("GET", "HEAD", "OPTIONS"), sort(split(get-header(response, "Allow"), ", ")), "Allowed methods"); -end test test-options-method; +end test; define test test-get-method (tags: #("online")) let response = http-get(full-url("/")); @@ -49,7 +49,7 @@ define test test-get-method (tags: #("online")) response := http-get(full-url("/get"), headers: h); check-equal("200 OK", response.response-code, 200); check-true("Send headers", response-content-contains?(response, "X-Test-Header")); -end test test-get-method; +end test; define test test-get-method-allow-redirect (tags: #("online")) let response = http-get(full-url("/redirect", "1")); @@ -62,7 +62,7 @@ define test test-get-method-allow-redirect (tags: #("online")) response := http-get(full-url("/redirect", "3"), follow-redirects: 3); check-equal("follow-redirects: 3", response.response-code, 200); -end test test-get-method-allow-redirect; +end test; define test test-post-method (tags: #("online")) let response = http-post(full-url("/post"), content: "{\"key1\": \"value1\"}"); @@ -76,12 +76,12 @@ define test test-post-method (tags: #("online")) check-true("Send data as form-encoded (value)", find-substring(response.response-content, concatenate("\"key2\":", " \"", payload["key2"], "\""))); -end test test-post-method; +end test; define test test-head-method (tags: #("online")) let response = http-head(full-url("/")); check-equal("200 OK", response.response-code, 200); -end test test-head-method; +end test; define test test-put-method (tags: #("online")) let payload = make(, size: 2); @@ -90,32 +90,20 @@ define test test-put-method (tags: #("online")) let response = http-put(full-url("/put"), content: payload); check-true("Send data as form-encoded (key)", response-content-contains?(response, "key1")); check-equal("200 OK", response.response-code, 200); -end test test-put-method; +end test; define test test-delete-method (tags: #("online")) let response = http-delete(full-url("/delete")); check-equal("200 OK", response.response-code, 200); -end test test-delete-method; +end test; define test test-trace-method () // Not implemented by httpbin -end test test-trace-method; +end test; define test test-connect-method () // Not implemented by httpbin -end test test-connect-method; - -define suite method-test-suite () - test test-options-method; - test test-get-method; - test test-get-method-allow-redirect; - test test-post-method; - test test-head-method; - test test-put-method; - test test-delete-method; - test test-trace-method; - test test-connect-method; -end; +end test; define test test-date-header-parsing () @@ -136,32 +124,15 @@ define test test-date-header-parsing () date, parse-http-date(test-date, 0, test-date.size)); end; -end test test-date-header-parsing; - -define suite header-test-suite () - test test-date-header-parsing; -end suite header-test-suite; +end test; define test test-cookies () -end test test-cookies; +end test; define test test-cookies-on-301 () -end test test-cookies-on-301; +end test; define test test-cookies-on-redirect () // This test requires a class to persist status between requests (session?) -end test test-cookies-on-redirect; - -define suite cookies-test-suite () - test test-cookies; - test test-cookies-on-301; - test test-cookies-on-redirect; -end suite cookies-test-suite; - - -define suite http-protocol-test-suite () - suite method-test-suite; - suite header-test-suite; - suite cookies-test-suite; -end suite http-protocol-test-suite; +end test; diff --git a/tests/http-test-suite-app-library.dylan b/tests/http-test-suite-app-library.dylan deleted file mode 100644 index e2a0578..0000000 --- a/tests/http-test-suite-app-library.dylan +++ /dev/null @@ -1,12 +0,0 @@ -Module: dylan-user -Copyright: See LICENSE in this distribution for details. - -define library http-test-suite-app - use http-test-suite; - use testworks; -end; - -define module http-test-suite-app - use http-test-suite; - use testworks; -end; diff --git a/tests/http-test-suite-app.dylan b/tests/http-test-suite-app.dylan deleted file mode 100644 index c5c6194..0000000 --- a/tests/http-test-suite-app.dylan +++ /dev/null @@ -1,4 +0,0 @@ -Module: http-test-suite-app -Copyright: See LICENSE in this distribution for details. - -run-test-application(http-test-suite); diff --git a/tests/http-test-suite-app.lid b/tests/http-test-suite-app.lid deleted file mode 100644 index 24f0316..0000000 --- a/tests/http-test-suite-app.lid +++ /dev/null @@ -1,3 +0,0 @@ -library: http-test-suite-app -files: http-test-suite-app-library - http-test-suite-app diff --git a/tests/http-test-suite-library.dylan b/tests/http-test-suite-library.dylan index ea24a04..516dcf8 100644 --- a/tests/http-test-suite-library.dylan +++ b/tests/http-test-suite-library.dylan @@ -9,7 +9,7 @@ define library http-test-suite use testworks; export http-test-suite; -end; +end library; define module http-test-suite use http-client-test-suite; @@ -17,6 +17,4 @@ define module http-test-suite use http-protocol-test-suite; use http-server-test-suite; use testworks; - - export http-test-suite; -end; +end module; diff --git a/tests/http-test-suite.dylan b/tests/http-test-suite.dylan deleted file mode 100644 index 7474b0c..0000000 --- a/tests/http-test-suite.dylan +++ /dev/null @@ -1,9 +0,0 @@ -Module: http-test-suite -Copyright: See LICENSE in this distribution for details. - -define suite http-test-suite () - suite http-client-test-suite; - suite http-common-test-suite; - suite http-protocol-test-suite; - suite http-server-test-suite; -end; diff --git a/tests/http-test-suite.lid b/tests/http-test-suite.lid index 4926d6a..c7da6fb 100644 --- a/tests/http-test-suite.lid +++ b/tests/http-test-suite.lid @@ -1,3 +1,2 @@ library: http-test-suite files: http-test-suite-library - http-test-suite From 27f9ec7f545ea027c762d3913bdc3bce5821d29d Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Fri, 18 Dec 2020 20:55:08 +0000 Subject: [PATCH 2/3] Replace expensive replace-substrings call with a loop ...no need to allocate a new string and copy. --- server/core/request.dylan | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/server/core/request.dylan b/server/core/request.dylan index 7a2b983..10d80e0 100644 --- a/server/core/request.dylan +++ b/server/core/request.dylan @@ -267,7 +267,12 @@ define method process-request-content // By the time we get here request-query-values has already // been bound to a containing the URL query // values. Now we augment it with any form values. - let content = replace-substrings(request-content(request), "+", " "); + let content :: = request-content(request); + for (i from 0, char in content) + if (char == '+') + content[i] := ' '; + end; + end; let parsed-query = split-query(content); for (value keyed-by key in parsed-query) request.request-query-values[key] := value; From a3cdd7f5b92b070eb18a78070547fb730ab28cc1 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Mon, 21 Dec 2020 05:47:18 +0000 Subject: [PATCH 3/3] Fix multipart/form-data, rewrite header parsing Each multipart/form-data part has a set of RFC822 headers separated from the body of the part by a blank line, and is a good excuse to reuse the main header parsing code. Doing so exposed bugs around exactly how CRLF was handled. This includes a fairly comprehensive rewrite of the header parsing that also simplifies the code and adds tests. It introduces a more efficient use of buffers. There is now a fixed-size header buffer, based on a quick survey of what other web servers do. (8K seems common but should be made configurable.) The idea is that this buffer should be plumbed through the remaining code so that a single one can be reused for each request, one buffer per worker thread. That is future work. The HTTP test suite is in terrible shape and hangs for many tests, making it essentially useless. I tested this mainly via http-common-test-suite and by running web-playground. --- client/http-client.dylan | 3 +- common/headers.dylan | 177 ++++++++---------- common/http-common.dylan | 5 +- common/library.dylan | 9 +- common/tests/headers-tests.dylan | 62 ++++++ .../http-common-test-suite-library.dylan | 1 + common/tests/http-common-test-suite.lid | 1 + server/core/request.dylan | 90 +++++---- 8 files changed, 202 insertions(+), 146 deletions(-) create mode 100644 common/tests/headers-tests.dylan diff --git a/client/http-client.dylan b/client/http-client.dylan index c5a0a01..ebf2b6b 100644 --- a/client/http-client.dylan +++ b/client/http-client.dylan @@ -449,7 +449,8 @@ define method read-response => (response :: ) let socket :: = conn.connection-socket; let (http-version, status-code, reason-phrase) = read-status-line(socket); - let headers :: = read-message-headers(socket); + let headers :: = make(); + read-headers!(socket, make-header-buffer(), headers); let response = make(response-class, connection: conn, // TODO: add version to class diff --git a/common/headers.dylan b/common/headers.dylan index 984b2d3..f4678b7 100644 --- a/common/headers.dylan +++ b/common/headers.dylan @@ -38,33 +38,6 @@ define method content-length get-header(headers, "Content-Length", parsed: #t) end; -// Read message headers into a and return it. -// If the "headers" argument is supplied then it is side-effected. -// Otherwise a new is created and returned. -// -define function read-message-headers - (stream :: , - #key buffer :: = grow-header-buffer("", 0), - start :: = 0, - headers :: = make(), - require-crlf? :: = #t) - => (headers :: , buffer :: , epos :: ) - iterate loop (buffer :: = buffer, - bpos :: = start, - peek-ch :: false-or() = #f) - let (buffer, bpos, epos, peek-ch) - = read-header-line(stream, buffer, bpos, peek-ch, require-crlf?); - if (bpos == epos) // blank line, done. - values(headers, buffer, epos) - else - let (key, data) = split-header(buffer, bpos, epos); - log-debug(*http-common-log*, "Received header %s: %s", key, data); - set-header(headers, key, data); - loop(buffer, epos, peek-ch) - end if - end iterate -end function read-message-headers; - define open generic set-header (object :: , header :: , value :: , #key if-exists? :: one-of(#"replace", #"append", #"ignore", #"error")); @@ -152,86 +125,98 @@ define function grow-header-buffer (old :: , len :: ) end; end function grow-header-buffer; -// Read a header line, including continuation lines, if any. -// If require-crlf? is #t then lines MUST be terminated by CRLF, otherwise -// they may be terminated by CRLF or LF. Either way, the EOL characters -// are not included in the result. require-crlf?: #f is intended for use -// reading headers generated by CGI scripts. +// Make a header buffer of a standard size, chosen based on what other web +// servers are documented to do. // -// Note that this implementation has a drawback: it stores the CR in the -// buffer and then later removes it if LF follows. This greatly simplifies -// the code but that last CR could unnecessarily grow the buffer. +// TODO(cgay): should be configurable. +// TODO(cgay): should be only one of these per worker thread. +define inline function make-header-buffer + () => (buffer :: ) + make(, size: 8192) +end function; + +// Read message headers into `headers` using `buffer` for temporary storage. +// It is valid to read zero headers, e.g., if the first line is a blank line. +// If the caller cares about this case it should check the size of `headers`. +// This is so that this code may be used to parse multipart/form-data in +// addition to HTTP request headers. // -define function read-header-line - (stream :: , - buffer :: , - bpos :: , - peek-ch :: false-or(), - require-crlf? :: ) - => (buffer :: , - bpos :: , - epos :: , - peek-ch :: false-or()) - iterate loop (buffer :: = buffer, - bpos :: = bpos, - epos :: = buffer.size, - pos :: = bpos, - peek-ch :: false-or() = peek-ch) - // Complain even if don't really need room for one more char, makes the - // program logic simpler... - if (pos == epos) - if (*max-single-header-size* & epos - bpos >= *max-single-header-size*) - header-too-large-error(max-size: *max-single-header-size*); - else - let len = epos - bpos; - let new = grow-header-buffer(buffer, len); - loop(new, 0, new.size, len, peek-ch); - end; +// Parameters: +// stream - Stream from which to read header data. +// buffer - Temporary work space. May be reused for each call. +// headers - Table in which to store header name -> unparsed-header-value mappings. +// Values: +// nbytes - The total number of bytes read from `stream`. +// Signals: +// +define function read-headers! + (stream :: , buffer :: , headers :: ) + => (nbytes :: ) + iterate loop (nbytes = 0) + let (epos, n) = read-header-line!(stream, buffer); + if (epos > 0) + let (name, value) = split-header(buffer, epos); + log-debug(*http-common-log*, "Received header %s: %s", name, value); + set-header(headers, name, value); + loop(nbytes + n); else - let ch :: = peek-ch | read-element(stream); - let prev-was-cr? = (pos > bpos & buffer[pos - 1] == $cr); - if (ch == $lf & (~require-crlf? | prev-was-cr?)) - if (prev-was-cr?) - pos := pos - 1; // don't include CR in result - end; - if (bpos == pos) // empty line means end - values(buffer, bpos, pos, #f) - else - let ch = read-element(stream); - if (ch == ' ' | ch == '\t') // continuation line - // should canonicalize whitespace to a single SP here? - loop(buffer, bpos, epos, pos, ch) - else - values(buffer, bpos, pos, ch) - end - end + nbytes + n + end + end; +end function; + +// Read a header line from `stream` into `buffer`, including any continuation +// lines. The CRLF preceding continuation lines is removed, but other +// whitespace is retained. +// +// Returns: +// epos - The end index, excluding the final CRLF. +// nbytes - The total number of bytes read from `stream`. +// Signals: +// +define function read-header-line! + (stream :: , buffer :: ) + => (epos :: , nbytes :: ) + iterate loop (pos = 0, prev = #f, nbytes = 0) + let ch = read-element(stream, on-end-of-stream: #f) + | bad-header-error(message: "end of data"); + if (ch == $lf & prev == $cr) + // Always drop the CRLF, whether for continuation lines or end of header. + pos := pos - 1; + // Avoid calling peek if this is the blank line terminating the headers + // since message body may be empty. + let char = pos > 0 & peek(stream, on-end-of-stream: #f); + if (char == ' ' | char == '\t') + loop(pos, char, nbytes + 1) else - buffer[pos] := ch; - loop(buffer, bpos, epos, pos + 1, #f) + values(pos, nbytes + 1) end + else + buffer[pos] := ch; + loop(pos + 1, ch, nbytes + 1) end end iterate -end function read-header-line; - - +end function; // Split header into header name (the part preceding the ':') and header value. +// Note that this will happily accept "name:value" with no whitespace after the +// colon and "name:" with no data after the colon (in which case an empty +// string is returned). +// +// Signals: +// define function split-header - (buffer :: , bpos :: , epos :: ) - => (header-key :: , header-data :: ) - let pos = char-position(':', buffer, bpos, epos); + (buffer :: , epos :: ) + => (name :: , value :: ) + let pos = char-position(':', buffer, 0, epos); if (~pos) - bad-header-error(message: "Header line contained no colon") - else - // We don't use keywords for header keys, because don't want to end - // up interning some huge bogus header that would then drag us down - // for the rest of eternity... - let key = substring(buffer, bpos, pos); - let (data-start, data-end) = trim-whitespace(buffer, pos + 1, epos); - let data = substring(buffer, data-start, data-end); - values(key, data) - end -end function split-header; + bad-header-error(message: "no colon found") + end; + let name = copy-sequence(buffer, start: 0, end: pos); + let (start, _end) = trim-whitespace(buffer, pos + 1, epos); + values(name, + copy-sequence(buffer, start: start, end: _end)) +end function; //////////////////////////////////////////////////////////////////////////////// diff --git a/common/http-common.dylan b/common/http-common.dylan index a1aaab7..315070d 100644 --- a/common/http-common.dylan +++ b/common/http-common.dylan @@ -426,10 +426,7 @@ end method chunked-transfer-encoding?; // The string returned does not include the CRLF. Second return value // is the end-of-line index. // -// See also: read-header-line -// todo -- Callers of this that are in the server should pass a max-size -// argument, at which point an error should be signaled. -// +// TODO(cgay): Redo this to be more like read-http-line!. define method read-http-line (stream :: ) => (buffer :: , len :: ) diff --git a/common/library.dylan b/common/library.dylan index af92612..1e9b9cd 100644 --- a/common/library.dylan +++ b/common/library.dylan @@ -268,7 +268,7 @@ define module http-common , get-header, set-header, - read-message-headers, + read-headers!, raw-headers, parsed-headers, , @@ -285,10 +285,11 @@ define module http-common // lower level header APIs... create - read-header-line, - read-http-line, + grow-header-buffer, + make-header-buffer, parse-header-value, - grow-header-buffer; + read-header-line!, + read-http-line; // Cookies create diff --git a/common/tests/headers-tests.dylan b/common/tests/headers-tests.dylan new file mode 100644 index 0000000..e4ac7f6 --- /dev/null +++ b/common/tests/headers-tests.dylan @@ -0,0 +1,62 @@ +Module: http-common-test-suite + +// Verify that the CRLF following the last header line is consumed, i.e., that +// epos includes it. +define test test-read-headers! () + let text = "Content-Disposition: form-data; name=\"main-code\"\r\n\r\ndef"; + let buffer = make-header-buffer(); + let headers = make(); + with-input-from-string (stream = text) + let epos = read-headers!(stream, buffer, headers); + test-output("up to 52: %=\n", copy-sequence(text, end: 52)); + assert-equal(52, epos); + assert-equal("form-data; name=\"main-code\"", + headers["content-disposition"], + "content-disposition header correct?"); + assert-equal(1, headers.size); + assert-equal("def", read-to-end(stream)); + end; +end test; + +define test test-read-headers!-valid () + let items + = list(list("x: y\r\n\r\n", #("x", "y")), + list("x: y\r\nz: a\r\n\r\n", #("x", "y", "z", "a")), + list("x:y\r\n\r\n", #("x", "y")), + list("x:\r\n\r\n", #("x", "")), + list("x: y\r\n z\r\n\r\n", #("x", "y z")), + list("x: y\rz\r\n\r\n", #("x", "y\rz")), + list("x: y\nz\r\n\r\n", #("x", "y\nz")), + list("\r\nmessage body", #()), + list("x: y: z\r\n\r\n", #("x", "y: z"))); + for (item in items) + let (input, want) = apply(values, item); + let buffer = make-header-buffer(); + let headers = make(); + with-input-from-string (stream = input) + read-headers!(stream, buffer, headers); + end; + let description = format-to-string("input: %=", input); + assert-equal(floor/(want.size, 2), headers.size, description); + for (i from 0 below want.size by 2) + let name = want[i]; + let value = want[i + 1]; + assert-equal(value, headers[name], description); + end; + end for; +end test; + +define test test-read-headers!-invalid () + let error-cases = list("x:y\r\n", // no LWS + "x: y", // no CRLF + "x y\r\n"); // no colon + for (message in error-cases) + let buffer = make-header-buffer(); + let headers = make(); + assert-signals(, + with-input-from-string (stream = message) + read-headers!(stream, buffer, headers); + end, + format-to-string("message: %=", message)); + end; +end test; diff --git a/common/tests/http-common-test-suite-library.dylan b/common/tests/http-common-test-suite-library.dylan index 43dce48..072242e 100644 --- a/common/tests/http-common-test-suite-library.dylan +++ b/common/tests/http-common-test-suite-library.dylan @@ -14,6 +14,7 @@ define module http-common-test-suite use common-dylan; use http-common; use http-common-internals; + use streams; use testworks; use format; end module; diff --git a/common/tests/http-common-test-suite.lid b/common/tests/http-common-test-suite.lid index 76afc57..fc24122 100644 --- a/common/tests/http-common-test-suite.lid +++ b/common/tests/http-common-test-suite.lid @@ -1,3 +1,4 @@ library: http-common-test-suite files: http-common-test-suite-library + headers-tests http-common-test-suite diff --git a/server/core/request.dylan b/server/core/request.dylan index 10d80e0..52ded98 100644 --- a/server/core/request.dylan +++ b/server/core/request.dylan @@ -106,10 +106,7 @@ define method read-request request.request-method, request.request-raw-url-string, request.request-version); - read-message-headers(socket, - buffer: buffer, - start: len, - headers: request.raw-headers); + read-headers!(socket, buffer, request.raw-headers); process-incoming-headers(request); // Unconditionally read all request content in case we need to process // further requests on the same connection. This is temporary and needs @@ -259,8 +256,8 @@ define open generic process-request-content define method process-request-content (request :: , content-type :: ) - // do nothing special for this content type -end method; + // No special processing for this content type. +end; define method process-request-content (request :: , content-type == #"application/x-www-form-urlencoded") @@ -281,9 +278,14 @@ define method process-request-content // For now this'll have to do. end method; -// See https://tools.ietf.org/html/rfc7578 for full semantics of -// multipart/form-data. This code is in no way complete. It is enough to get -// play.opendylan.org working though. +// Augment the current request-query-values with the values in the +// multipart/form-data body. +// +// https://tools.ietf.org/html/rfc2046#section-5.1 -- Multipart Media Type +// https://tools.ietf.org/html/rfc7578 -- Returning Values from Forms: multipart/form-data +// +// This code is in no way complete or optimized; it is enough to get +// play.opendylan.org working. There is much unnecessary string copying. define method process-request-content (request :: , content-type == #"multipart/form-data") local method fail (msg :: ) @@ -295,38 +297,44 @@ define method process-request-content let boundary = get-attribute(header, "boundary") | fail("'Content-Type: multipart/form-data' missing 'boundary' parameter"); - boundary := concatenate("--", boundary); - - let parts = split(request.request-content, boundary, - remove-if-empty?: #t); // first separator is at position 0 + if (boundary.size == 0 | boundary.size > 70) + fail("multipart/form-data boundary size must be 1-70 characters"); + end; + boundary := concatenate("--", boundary); // inefficient - // Treat each part like a full HTTP request: headers, blank line, body + let content :: = request.request-content; + let parts = split(content, boundary, remove-if-empty?: #t); let qvalues = request.request-query-values; - for (part in parts, i from 1) - // In Chrome, the "--" separator appears immediately following the last - // occurrence of the boundary. Skip it if it's the last element. Spec is - // vague on this. - if (~(i = parts.size & starts-with?(part, "--"))) - part := strip-left(part); - let (headers, _, epos) - = with-input-from-string (stream = part) - read-message-headers(stream) - end; - // TODO: handle different content-types, charsets, transfer encodings. - - let disposition :: - = get-header(headers, "Content-Disposition", parsed: #t) - | fail("multipart/form-data missing 'Content-Disposition' header"); - let name = element(disposition, "name", default: #f) - | fail("multipart/form-data missing 'name' parameter"); - let form-value = copy-sequence(part, start: epos); - let val = element(qvalues, name, default: #f); - qvalues[name] := case - ~val => form-value; - instance?(val, ) => list(val, form-value); - otherwise => pair(form-value, val); // val is a list - end; - end if; + let headers = make(); + let buffer = make-header-buffer(); + for (part in parts, + while: ~starts-with?(part, "--")) + // Each part should begin and end with CRLF. The initial CRLF is technically the + // terminator for the boundary line but we're not really processing this by lines. + if (~starts-with?(part, "\r\n")) + fail("invalid multipart/form-data boundary -- no trailing CRLF"); + end; + if (~ends-with?(part, "\r\n")) + fail("invalid multipart/form-data -- no CRLF at end of part"); + end; + let epos = with-input-from-string (stream = part, start: 2, end: part.size - 2) + remove-all-keys!(headers); + read-headers!(stream, buffer, headers); + end; + // TODO: handle different content-types, charsets, transfer encodings. + + let disposition :: + = get-header(headers, "Content-Disposition", parsed: #t) + | fail("multipart/form-data missing 'Content-Disposition' header"); + let name = element(disposition, "name", default: #f) + | fail("multipart/form-data missing 'name' parameter"); + let form-value = copy-sequence(part, start: epos, end: part.size - 2); + let val = element(qvalues, name, default: #f); + qvalues[name] := case + ~val => form-value; + instance?(val, ) => list(val, form-value); + otherwise => pair(form-value, val); // val is a list + end; end for; end method; @@ -338,9 +346,9 @@ define method process-incoming-headers (request :: ) let conn-values :: = get-header(request, "Connection", parsed: #t) | #(); if (member?("close", conn-values, test: string-equal-ic?)) - request-keep-alive?(request) := #f + request-keep-alive?(request) := #f; elseif (member?("keep-alive", conn-values, test: string-equal-ic?)) - request-keep-alive?(request) := #t + request-keep-alive?(request) := #t; end; let host/port = get-header(request, "Host", parsed: #t); let host = host/port & head(host/port);