summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorpatthoyts <patthoyts@users.sourceforge.net>2009-04-19 18:27:59 (GMT)
committerpatthoyts <patthoyts@users.sourceforge.net>2009-04-19 18:27:59 (GMT)
commit088d91e5be449b50b2330892fc611bed5a4a6c6a (patch)
tree3b26238ddcfadfd8972ccfc769b72d9455ad5342
parent0faf3c561ee72b67abea7c34667c19344d759d18 (diff)
downloadtcl-088d91e5be449b50b2330892fc611bed5a4a6c6a.zip
tcl-088d91e5be449b50b2330892fc611bed5a4a6c6a.tar.gz
tcl-088d91e5be449b50b2330892fc611bed5a4a6c6a.tar.bz2
Removed newline appended to POST data.
Added tests to check that the data provided by a POST is as stated in the content-length [Bug 2715421]
-rw-r--r--ChangeLog8
-rw-r--r--library/http/http.tcl5
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--tests/http11.test74
-rw-r--r--tests/httpd11.tcl45
-rw-r--r--unix/Makefile.in6
-rw-r--r--win/Makefile.in6
7 files changed, 127 insertions, 19 deletions
diff --git a/ChangeLog b/ChangeLog
index 4fb2c3d..c95f36d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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 \