Fix bug [a13b9d0ce1] on HTTP compression: remove "compress", amend "deflate".

4 files changed, 185 insertions, 17 deletions

diff --git a/doc/http.n b/doc/http.n
index 5b70671..e61f52f 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -210,7 +210,7 @@ numbers of \fBhttp\fR and \fBTcl\fR.
 \fB\-zip\fR \fIboolean\fR
 .
 If the value is boolean \fBtrue\fR, then by default requests will send a header
-.QW "\fBAccept-Encoding: gzip,deflate,compress\fR" .
+.QW "\fBAccept-Encoding: gzip,deflate\fR" .
 If the value is boolean \fBfalse\fR, then by default this header will not be
 sent.  In either case the default can be overridden for an individual request by
 supplying a custom \fBAccept-Encoding\fR header in the \fB\-headers\fR option
@@ -236,7 +236,7 @@ that is invoked when the HTTP transaction completes.
 .
 Specifies whether to force interpreting the URL data as binary.  Normally
 this is auto-detected (anything not beginning with a \fBtext\fR content
-type or whose content encoding is \fBgzip\fR or \fBcompress\fR is
+type or whose content encoding is \fBgzip\fR or \fBdeflate\fR is
 considered binary data).
 .TP
 \fB\-blocksize\fR \fIsize\fR
@@ -314,7 +314,7 @@ The \fBhttp::geturl\fR code for the \fB\-handler\fR option is not compatible
 with either compression or chunked transfer-encoding.  If \fB\-handler\fR is
 specified, then to work around these issues \fBhttp::geturl\fR will reduce the
 HTTP protocol to 1.0, and override the \fB\-zip\fR option (i.e. it will not
-send the header "\fBAccept-Encoding: gzip,deflate,compress\fR").
+send the header "\fBAccept-Encoding: gzip,deflate\fR").
 .PP
 If options \fB\-handler\fR and \fB\-channel\fR are used together, the handler
 is responsible for copying the data from the HTTP socket to the specified
diff --git a/library/http/http.tcl b/library/http/http.tcl
index a76ce15..691355c 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -2128,7 +2128,7 @@ proc http::Connected {token proto phost srvurl} {
 	     && (![info exists state(-handler)])
 	     && $http(-zip)
 	} {
-	    puts $sock "Accept-Encoding: gzip,deflate,compress"
+	    puts $sock "Accept-Encoding: gzip,deflate"
 	}
 	if {$isQueryChannel && ($state(querylength) == 0)} {
 	    # Try to determine size of data in channel. If we cannot seek, the
@@ -4010,13 +4010,25 @@ proc http::CopyStart {sock token {initial 1}} {
     upvar 0 $token state
     if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
 	foreach coding [ContentEncoding $token] {
-	    lappend state(zlib) [zlib stream $coding]
+	    if {$coding eq {deflateX}} {
+		# Use the standards-compliant choice.
+		set coding2 decompress
+	    } else {
+		set coding2 $coding
+	    }
+	    lappend state(zlib) [zlib stream $coding2]
 	}
 	make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
     } else {
 	if {$initial} {
 	    foreach coding [ContentEncoding $token] {
-		zlib push $coding $sock
+		if {$coding eq {deflateX}} {
+		    # Use the standards-compliant choice.
+		    set coding2 decompress
+		} else {
+		    set coding2 $coding
+		}
+		zlib push $coding2 $sock
 	    }
 	}
 	if {[catch {
@@ -4137,7 +4149,20 @@ proc http::Eot {token {reason {}}} {
     if {[string length $state(body)] > 0} {
 	if {[catch {
 	    foreach coding [ContentEncoding $token] {
-		set state(body) [zlib $coding $state(body)]
+		if {$coding eq {deflateX}} {
+		    # First try the standards-compliant choice.
+		    set coding2 decompress
+		    if {[catch {zlib $coding2 $state(body)} result]} {
+			# If that fails, try the MS non-compliant choice.
+			set coding2 inflate
+			set state(body) [zlib $coding2 $state(body)]
+		    } else {
+			# error {failed at standards-compliant deflate}
+			set state(body) $result
+		    }
+		} else {
+		    set state(body) [zlib $coding $state(body)]
+		}
 	    }
 	} err]} {
 	    Log "error doing decompression for token $token: $err"
@@ -4387,16 +4412,41 @@ proc http::CharsetToEncoding {charset} {
     }
 }
 
+
+# ------------------------------------------------------------------------------
+#  Proc http::ContentEncoding
+# ------------------------------------------------------------------------------
 # Return the list of content-encoding transformations we need to do in order.
+#
+    # --------------------------------------------------------------------------
+    # Options for Accept-Encoding, Content-Encoding: the switch command
+    # --------------------------------------------------------------------------
+    # The symbol deflateX allows http to attempt both versions of "deflate",
+    # unless there is a -channel - for a -channel, only "decompress" is tried.
+    # Alternative/extra lines for switch:
+    # The standards-compliant version of "deflate" can be chosen with:
+    #		deflate { lappend r decompress }
+    # The Microsoft non-compliant version of "deflate" can be chosen with:
+    #		deflate { lappend r inflate }
+    # The previously used implementation of "compress", which appears to be
+    # incorrect and is rarely used by web servers, can be chosen with:
+    #		compress - x-compress { lappend r decompress }
+    # --------------------------------------------------------------------------
+#
+# Arguments:
+# token  - Connection token.
+#
+# Return Value: list
+# ------------------------------------------------------------------------------
+
 proc http::ContentEncoding {token} {
     upvar 0 $token state
     set r {}
     if {[info exists state(coding)]} {
 	foreach coding [split $state(coding) ,] {
 	    switch -exact -- $coding {
-		deflate { lappend r inflate }
+		deflate { lappend r deflateX }
 		gzip - x-gzip { lappend r gunzip }
-		compress - x-compress { lappend r decompress }
 		identity {}
 		br {
 		    return -code error\
diff --git a/tests/http11.test b/tests/http11.test
index 912e069..b3d9edb 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -144,7 +144,22 @@ test http11-1.2 "normal,deflated,non-chunked" -setup {
     halt_httpd
 } -result {ok {HTTP/1.1 200 OK} ok deflate {}}
 
-test http11-1.3 "normal,compressed,non-chunked" -setup {
+test http11-1.2.1 "normal,deflated,non-chunked,msdeflate" -setup {
+    variable httpd [create_httpd]
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \
+                 -timeout 10000 -headers {accept-encoding deflate}]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok] \
+        [meta $tok content-encoding] [meta $tok transfer-encoding]
+} -cleanup {
+    http::cleanup $tok
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
+
+test http11-1.3 "normal,compressed,non-chunked" -constraints badCompress -setup {
+    # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+    # Bug [a13b9d0ce1].
     variable httpd [create_httpd]
 } -body {
     set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
@@ -249,7 +264,22 @@ test http11-1.10 "normal,deflate,chunked" -setup {
     halt_httpd
 } -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
 
-test http11-1.11 "normal,compress,chunked" -setup {
+test http11-1.10.1 "normal,deflate,chunked,msdeflate" -setup {
+    variable httpd [create_httpd]
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+                 -timeout 10000 -headers {accept-encoding deflate}]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok] \
+        [meta $tok content-encoding] [meta $tok transfer-encoding]
+} -cleanup {
+    http::cleanup $tok
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
+
+test http11-1.11 "normal,compress,chunked" -constraints badCompress -setup {
+    # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+    # Bug [a13b9d0ce1].
     variable httpd [create_httpd]
 } -body {
     set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -370,7 +400,28 @@ test http11-2.2 "-channel, encoding deflate" -setup {
     halt_httpd
 } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
 
-test http11-2.3 "-channel,encoding compress" -setup {
+test http11-2.2.1 "-channel, encoding deflate,msdeflate" -setup {
+    variable httpd [create_httpd]
+    set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+                 -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
+    http::wait $tok
+    seek $chan 0
+    set data [read $chan]
+    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+        [meta $tok connection] [meta $tok content-encoding]\
+        [meta $tok transfer-encoding]
+} -cleanup {
+    http::cleanup $tok
+    close $chan
+    removeFile testfile.tmp
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
+
+test http11-2.3 "-channel,encoding compress" -constraints badCompress -setup {
+    # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+    # Bug [a13b9d0ce1].
     variable httpd [create_httpd]
     set chan [open [makeFile {} testfile.tmp] wb+]
 } -body {
@@ -522,7 +573,32 @@ test http11-2.7 "-channel,encoding deflate,non-chunked" -setup {
     halt_httpd
 } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
 
-test http11-2.8 "-channel,encoding compress,non-chunked" -setup {
+test http11-2.7.1 "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup {
+    # Test fails because a -channel can only try one un-deflate algorithm, and the
+    # compliant "decompress" is tried, not the non-compliant "inflate" of
+    # the MS browser implementation.
+    variable httpd [create_httpd]
+    set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \
+                 -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
+    http::wait $tok
+    seek $chan 0
+    set data [read $chan]
+    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+        [meta $tok connection] [meta $tok content-encoding]\
+        [meta $tok transfer-encoding]\
+        [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+    http::cleanup $tok
+    close $chan
+    removeFile testfile.tmp
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
+
+test http11-2.8 "-channel,encoding compress,non-chunked" -constraints badCompress -setup {
+    # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+    # Bug [a13b9d0ce1].
     variable httpd [create_httpd]
     set chan [open [makeFile {} testfile.tmp] wb+]
 } -body {
@@ -583,6 +659,27 @@ test http11-2.10 "-channel,deflate,keepalive" -setup {
     halt_httpd
 } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
 
+test http11-2.10.1 "-channel,deflate,keepalive,msdeflate" -setup {
+    variable httpd [create_httpd]
+    set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+                 -timeout 5000 -channel $chan -keepalive 1 \
+		 -headers {accept-encoding deflate}]
+    http::wait $tok
+    seek $chan 0
+    set data [read $chan]
+    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+        [meta $tok connection] [meta $tok content-encoding]\
+        [meta $tok transfer-encoding]\
+        [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+    http::cleanup $tok
+    close $chan
+    removeFile testfile.tmp
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
+
 test http11-2.11 "-channel,identity,keepalive" -setup {
     variable httpd [create_httpd]
     set chan [open [makeFile {} testfile.tmp] wb+]
@@ -621,7 +718,7 @@ test http11-2.12 "-channel,negotiate,keepalive" -setup {
     close $chan
     removeFile testfile.tmp
     halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}
+} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate 0}
 
 
 # -------------------------------------------------------------------------
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index d0624f8..6570ee9 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -160,6 +160,12 @@ proc Service {chan addr port} {
         if {$protocol eq "HTTP/1.1"} {
 	    foreach enc [split [dict get? $meta accept-encoding] ,] {
 		set enc [string trim $enc]
+		# The current implementation of "compress" appears to be
+		# incorrect (bug [a13b9d0ce1]).  Keep it here for
+		# experimentation only.  The tests that use it have the
+		# constraint "badCompress".  The client code in http has
+		# been removed, but can be restored from comments if
+		# experimentation is desired.
 		if {$enc in {deflate gzip compress}} {
 		    set encoding $enc
 		    break
@@ -171,6 +177,7 @@ proc Service {chan addr port} {
         }
 
         set nosendclose 0
+        set msdeflate 0
         foreach pair [split $query &] {
             if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
             switch -exact -- $key {
@@ -178,6 +185,7 @@ proc Service {chan addr port} {
                 close        {set close 1 ; set transfer 0}
                 transfer     {set transfer $val}
                 content-type {set type $val}
+                msdeflate    {set msdeflate $val}
             }
         }
         if {$protocol eq "HTTP/1.1"} {
@@ -211,10 +219,23 @@ proc Service {chan addr port} {
         flush $chan
 
         chan configure $chan -buffering full -translation binary
+        if {$encoding eq {deflate}} {
+            # When http.tcl uses the correct decoder (bug [a13b9d0ce1]) for
+            # "accept-encoding deflate", i.e. "zlib decompress", this choice of
+            # encoding2 allows the tests to pass.  It appears to do "deflate"
+            # correctly, but this has not been verified with a non-Tcl client.
+            set encoding2 compress
+        } else {
+            set encoding2 $encoding
+        }
         if {$transfer eq "chunked"} {
-            blow-chunks $data $chan $encoding
-        } elseif {$encoding ne "identity"} {
-            puts -nonewline $chan [zlib $encoding $data]
+            blow-chunks $data $chan $encoding2
+        } elseif {$encoding2 ne "identity" && $msdeflate eq {1}} {
+            puts -nonewline $chan [string range [zlib $encoding2 $data] 2 end-4]
+            # Used in some tests of "deflate" to produce the non-RFC-compliant
+            # Microsoft version of "deflate".
+        } elseif {$encoding2 ne "identity"} {
+            puts -nonewline $chan [zlib $encoding2 $data]
         } else {
             puts -nonewline $chan $data
         }