diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | library/http/http.tcl | 5 | ||||
| -rw-r--r-- | library/http/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | tests/http11.test | 74 | ||||
| -rw-r--r-- | tests/httpd11.tcl | 45 | ||||
| -rw-r--r-- | unix/Makefile.in | 6 | ||||
| -rw-r--r-- | win/Makefile.in | 6 |
7 files changed, 127 insertions, 19 deletions
@@ -1,3 +1,11 @@ +2009-04-19 Pat Thoyts <patthoyts@users.sourceforge.net> + + * library/http/http.tcl: Removed spurious newline added after POST + * tests/http11.test: and added tests to detect excess bytes + * tests/httpd11.tcl: being POSTed. [Bug 2715421] + * library/http/pkgIndex.tcl: + * makefiles: package version now 2.8.1 + 2009-04-15 Donal K. Fellows <dkf@users.sf.net> * doc/chan.n, doc/close.n: Tidy up documentation of TIP #332. diff --git a/library/http/http.tcl b/library/http/http.tcl index 8de0a9d..654d8b0 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -8,12 +8,12 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.75 2009/04/10 14:19:44 patthoyts Exp $ +# RCS: @(#) $Id: http.tcl,v 1.76 2009/04/19 18:27:59 patthoyts Exp $ package require Tcl 8.6 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.0 +package provide http 2.8.1 namespace eval http { # Allow resourcing to not clobber existing data @@ -906,7 +906,6 @@ proc http::Write {token} { incr state(queryoffset) $state(-queryblocksize) if {$state(queryoffset) >= $state(querylength)} { set state(queryoffset) $state(querylength) - puts $sock "" set done 1 } } else { diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index c7029be..b953d49 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} -package ifneeded http 2.8.0 [list tclPkgSetup $dir http 2.8.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.8.1 [list tclPkgSetup $dir http 2.8.1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http11.test b/tests/http11.test index 58bb091..967e5e6 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -231,7 +231,7 @@ test http-1.11 "normal,compress,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress chunked} -test http-1.11 "normal,identity,chunked" -setup { +test http-1.12 "normal,identity,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -573,6 +573,78 @@ test http-3.3 "-handler,keepalive,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} +test http-4.0 "normal post request" -setup { + variable httpd [create_httpd] +} -body { + set query [http::formatQuery q 1 z 2] + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -query $query -timeout 10000] + http::wait $tok + list status [http::status $tok] code [http::code $tok]\ + crc [check_crc $tok]\ + connection [meta $tok connection]\ + query-length [meta $tok x-query-length] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} + +test http-4.1 "normal post request, check query length" -setup { + variable httpd [create_httpd] +} -body { + set query [http::formatQuery q 1 z 2] + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -headers [list x-check-query yes] \ + -query $query -timeout 10000] + http::wait $tok + list status [http::status $tok] code [http::code $tok]\ + crc [check_crc $tok]\ + connection [meta $tok connection]\ + query-length [meta $tok x-query-length] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} + +test http-4.2 "normal post request, check long query length" -setup { + variable httpd [create_httpd] +} -body { + set query [string repeat a 24576] + set tok [http::geturl http://localhost:$httpd_port/testdoc.html\ + -headers [list x-check-query yes]\ + -query $query -timeout 10000] + http::wait $tok + list status [http::status $tok] code [http::code $tok]\ + crc [check_crc $tok]\ + connection [meta $tok connection]\ + query-length [meta $tok x-query-length] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 24576} + +test http-4.3 "normal post request, check channel query length" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + puts -nonewline $chan [string repeat [encoding convertto utf-8 "This is a test\n"] 8192] + flush $chan + seek $chan 0 +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html\ + -headers [list x-check-query yes]\ + -querychannel $chan -timeout 10000] + http::wait $tok + list status [http::status $tok] code [http::code $tok]\ + crc [check_crc $tok]\ + connection [meta $tok connection]\ + query-length [meta $tok x-query-length] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880} + # ------------------------------------------------------------------------- unset -nocomplain httpd_port diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index afa5f5d..9c543dc 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -89,6 +89,7 @@ proc Service {chan addr port} { while {1} { set meta {} chan configure $chan -buffering line -encoding iso8859-1 -translation crlf + chan configure $chan -blocking 0 yield while {[gets $chan line] < 0} { if {[eof $chan]} {chan event $chan readable {}; close $chan; return} @@ -101,16 +102,12 @@ proc Service {chan addr port} { puts $line while {[gets $chan line] > 0} { if {[regexp {^([^:]+):(.*)$} $line -> key val]} { - #puts "$key $val" + puts [list $key [string trim $val]] lappend meta [string tolower $key] [string trim $val] } yield } - if {[scan $url {%[^?]?%s} path query] < 2} { - set query "" - } - set encoding identity set transfer "" set close 1 @@ -119,6 +116,35 @@ proc Service {chan addr port} { set data "<html><head><title>Error 404</title></head>" append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>" + if {[scan $url {%[^?]?%s} path query] < 2} { + set query "" + } + + switch -exact -- $req { + GET - HEAD { + } + POST { + # Read the query. + set qlen [dict get? $meta content-length] + if {[string is integer -strict $qlen]} { + chan configure $chan -buffering none -translation binary + while {[string length $query] < $qlen} { + append query [read $chan $qlen] + if {[string length $query] < $qlen} {yield} + } + # Check for excess query bytes [Bug 2715421] + if {[dict get? $meta x-check-query] eq "yes"} { + chan configure $chan -blocking 0 + append query [read $chan] + } + } + } + default { + # invalid request error 5?? + } + } + if {$query ne ""} {puts $query} + set path [string trimleft $path /] set path [file join [pwd] $path] if {[file exists $path] && [file isfile $path]} { @@ -153,10 +179,13 @@ proc Service {chan addr port} { } } - chan configure $chan -translation crlf + chan configure $chan -buffering line -encoding iso8859-1 -translation crlf Puts $chan "$protocol $code" Puts $chan "content-type: $type" - Puts $chan [format "x-crc32: %x" [zlib crc32 $data]] + Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]] + if {$req eq "POST"} { + Puts $chan [format "x-query-length: %d" [string length $query]] + } if {$close} { Puts $chan "connection: close" } @@ -171,7 +200,7 @@ proc Service {chan addr port} { puts $chan "" flush $chan - chan configure $chan -translation binary + chan configure $chan -buffering full -translation binary if {$transfer eq "chunked"} { blow-chunks $data $chan $encoding } elseif {$encoding ne "identity"} { diff --git a/unix/Makefile.in b/unix/Makefile.in index 42790de..4fa5b12 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.267 2009/04/10 14:19:45 patthoyts Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.268 2009/04/19 18:27:59 patthoyts Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -820,8 +820,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.8.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.0.tm; + @echo "Installing package http 2.8.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.1.tm; @echo "Installing library opt0.4 directory"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index ed0632f..1f6d5ce 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.154 2009/04/10 14:19:45 patthoyts Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.155 2009/04/19 18:28:00 patthoyts Exp $ VERSION = @TCL_VERSION@ @@ -696,8 +696,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.0.tm; + @echo "Installing package http 2.8.1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.1.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ |