The following patch adds partial range requests support. Additionally a virtual hosts implementation is provided, it's a little bit more flexible than original one, doesn't require multiple interps, eats less memory, but, of course, is a little less secure.
Note: the text below is two space indented, you need to unindent it to apply the patch.
diff -r -u tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/doc.tcl tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/doc.tcl
--- tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/doc.tcl 2004-05-19 07:36:37.000000000 +0300
+++ tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/doc.tcl 2009-09-20 15:47:40.000000000 +0300
@@ -28,6 +28,7 @@
package require httpd::dirlist
package require httpd::doc_error
package require httpd::cookie
+package require httpd::vhost
# Doc_Root --
#
@@ -271,9 +272,9 @@
# into account other document roots.
if {[info exist Doc(root,$data(prefix))]} {
- set directory $Doc(root,$data(prefix))
+ set directory [file join $Doc(root,$data(prefix)) [lindex $data(vhost) 1]]
} else {
- set directory [file join $Doc(root,/) [string trimleft $data(prefix) /]]
+ set directory [file join $Doc(root,/) [lindex $data(vhost) 1] [string trimleft $data(prefix) /]]
}
# Look for .htaccess and .tclaccess files along the path
@@ -348,7 +349,7 @@
# pathnames outside the URL tree. We trim left the / and ~
# to prevent those attacks.
- set path [file join $directory [string trimleft $suffix /~]]
+ set path [file join $directory [lindex $data(vhost) 1] [string trimleft $suffix /~]]
set path [DocPathNormalize $path]
set data(path) $path ;# record this path for not found handling
diff -r -u tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/httpd.tcl tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/httpd.tcl
--- tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/httpd.tcl 2009-07-26 20:25:55.000000000 +0300
+++ tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/httpd.tcl 2009-09-20 16:00:18.000000000 +0300
@@ -25,7 +25,6 @@
# RCS: @(#) $Id: httpd.tcl,v 1.85 2004/04/29 01:34:16 coldstore Exp $
package provide httpd 1.7
-
# initialize all the global data
# Location of this package
@@ -35,6 +34,7 @@
array set Httpd_Errors {
200 {Data follows}
204 {No Content}
+ 206 {Partial content}
302 {Found}
304 {Not Modified}
400 {Bad Request}
@@ -614,6 +614,7 @@
# data(uri) is the complete URI
set data(uri) $data(url)
+ set data(vhost) [list * .]
if {[string length $data(query)]} {
append data(uri) ?$data(query)
}
@@ -694,7 +695,10 @@
variable virtual
if {[string compare host $key]} {return}
set host [lindex [split [string tolower $value] :] 0]
- if {[catch {set virtual($host)} i]} {return}
+ set data(vhost) [VHost_Match $host]
+ return
+
+ # old implementation follows
# Transfer $sock to interp $i
fileevent $sock readable {}
@@ -722,7 +729,7 @@
set data(count) $data(mime,content-length)
if {$data(version) >= 1.1 && [info exists data(mime,expect)]} {
if {$data(mime,expect) == "100-continue"} {
- puts $sock "100 Continue HTTP/1.1\n"
+ puts $sock "HTTP/1.1 100 Continue\n"
flush $sock
} else {
Httpd_Error $sock 419 $data(mime,expect)
@@ -1213,12 +1220,20 @@
append reply "HTTP/$data(version) $code [HttpdErrorString $code]" \n
append reply "Date: [HttpdDate [clock seconds]]" \n
append reply "Server: $Httpd(server)\n"
+ append reply "Accept-Ranges: bytes\n"
if {$close} {
append reply "Connection: Close" \n
} elseif {$data(version) == 1.0 && !$close} {
append reply "Connection: Keep-Alive" \n
}
+ if {[info exists data(partial)]} {
+ set c_start [lindex $data(partial) 0]
+ set c_end [lindex $data(partial) 1]
+ set c_length [lindex $data(partial) 2]
+ set content_range "bytes $c_start-$c_end/$c_length"
+ append reply "Content-Range: $content_range" \n
+ }
append reply "Content-Type: $type" \n
if {[string length $size]} {
append reply "Content-Length: $size" \n
@@ -1315,6 +1330,59 @@
}
}
+# Range parsing procedures; not fully implemented yet :-(
+
+proc Httpd_ParseSubrange {subrange} {
+ if {[regexp {^([0-9]*)-([0-9]*)$} $subrange dummy from to]} {
+ if {"x$from" != "x" && "x$to" != "x"} then {
+ if {$from > $to} {
+ set from {}
+ set to {}
+ }
+ }
+ } else {
+ set from {}
+ set to {}
+ }
+ return [list $from $to]
+}
+
+proc Httpd_AddSubrange {summary max subrange} {
+ set parsed [Httpd_ParseSubrange $subrange]
+ if {[llength $subrange] == 0} {
+ return $summary
+ }
+ # TODO: iterate existing subranges
+ set from [lindex $parsed 0]
+ set to [lindex $parsed 1]
+ if {"x$from"=="x" && "x$from" != "x$to"} {
+ set nto [expr {$max-1}]
+ set nfrom [expr {$nto-$to+1}]
+ set parsed [list $nfrom $nto]
+ }
+ if {"x$to"=="x" && "x$from" != "x$to"} {
+ set to [expr {$max-1}]
+ set parsed [list $from $to]
+ }
+ if {"x$to"!="x" && "x$from"!="x"} {
+ lappend summary $parsed
+ }
+ return $summary
+}
+
+proc Httpd_ParseRange {max range} {
+ set summary [list]
+ if {[regexp {bytes=(.*)} $range dummy ranges]} {
+ while {[string length $ranges] != 0} {
+ regexp {([^,]*)(,(.*))?} $ranges dummy0 subrange dummy other
+ set summary [Httpd_AddSubrange $summary $max $subrange]
+ set ranges $other
+ }
+ }
+ return $summary
+}
+
+
# Httpd_ReturnFile
# Return a file.
#
@@ -1355,10 +1423,20 @@
# side accounting information.
incr data(file_size) -$offset
+
+ if {[info exists data(mime,range)]} {
+ set ranges [Httpd_ParseRange $data(file_size) $data(mime,range)]
+ set c_start [lindex $ranges 0 0]
+ set c_end [lindex $ranges 0 1]
+ set c_length $data(file_size)
+ set data(partial) [list $c_start $c_end $c_length]
+ incr offset [expr {$c_start-1}]
+ set data(code) 206
+ }
if {[catch {
set close [HttpdCloseP $sock]
- HttpdRespondHeader $sock $type $close $data(file_size) 200
+ HttpdRespondHeader $sock $type $close $data(file_size) $data(code)
HttpdSetCookie $sock
puts $sock "Last-Modified: [HttpdDate [file mtime $path]]"
puts $sock ""
@@ -1371,7 +1449,11 @@
fconfigure $sock -translation binary -blocking $Httpd(sockblock)
set data(infile) $in
Httpd_Suspend $sock 0
- fcopy $in $sock -command [list HttpdCopyDone $in $sock $close]
+ if {$data(code)==200} {
+ fcopy $in $sock -command [list HttpdCopyDone $in $sock $close]
+ } else {
+ fcopy $in $sock -size [expr {$c_end-$c_start+1}] -command [list HttpdCopyDone $in $sock $close]
+ }
} else {
Httpd_SockClose $sock $close
}
diff -r -u tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/pkgIndex.tcl tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/pkgIndex.tcl
--- tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/pkgIndex.tcl 2004-03-23 11:35:15.000000000 +0200
+++ tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/pkgIndex.tcl 2009-09-20 14:52:33.000000000 +0300
@@ -45,5 +45,6 @@
package ifneeded httpd::url 1.2 \[list source \[file join [list $dir] url.tcl\]\]
package ifneeded httpd::utils 1.0 \[list source \[file join [list $dir] utils.tcl\]\]
package ifneeded httpd::version 3.5 \[list source \[file join [list $dir] version.tcl\]\]
+ package ifneeded httpd::vhost 0.1 \[list source \[file join [list $dir] vhost.tcl\]\]
package ifneeded tclcrypt 1.0 \[list source \[file join [list $dir] tclcrypt.tcl\]\]
"
diff -r -u tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/version.tcl tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/version.tcl
--- tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/lib/version.tcl 2004-05-27 21:00:52.000000000 +0300
+++ tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/version.tcl 2009-09-20 14:43:56.000000000 +0300
@@ -1,5 +1,5 @@
package provide httpd::version 3.5
proc Httpd_Version {} {
global Httpd
- set Httpd(version) "3.5.1 May 27, 2004"
+ set Httpd(version) "3.5.1-bdt September 20, 2009"
}
diff -r -u tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/bin/tclhttpd.rc tclhttpd3.5.1-dist/tclhttpd3.5.1/bin/tclhttpd.rc
--- tclhttpd3.5.1-dist.orig/tclhttpd3.5.1/bin/tclhttpd.rc 2009-07-26 21:03:55.000000000 +0300
+++ tclhttpd3.5.1-dist/tclhttpd3.5.1/bin/tclhttpd.rc 2009-09-20 16:08:55.000000000 +0300
@@ -40,7 +40,7 @@
}
}
-
+Config vhost [list [list *host1.org host1 host1-htdocs] [list * * .]]
# main - Main per-thread startup script.
# The old way to customize the server was to modify this file directly.
--- /dev/null 2009-09-18 17:04:13.511138139 +0300
+++ tclhttpd3.5.1-dist/tclhttpd3.5.1/lib/vhost.tcl 2009-09-20 16:08:16.000000000 +0300
@@ -0,0 +1,27 @@
+# vhost.tcl
+
+# Virtual hosts implementation
+
+package provide httpd::vhost 0.1
+
+set vhosts [list]
+# [list * {return [list * .]}]
+
+proc VHost_Add {glob name dir} {
+ global vhosts
+ # set vhosts [linsert $vhosts 0 $glob [list return [list $name $dir]]]
+ lappend vhosts $glob [list return [list $name $dir]]
+}
+
+proc VHost_Match {host} {
+ global vhosts
+ switch -glob $host $vhosts
+}
+
+if {[cget vhost]=={}} {
+ VHost_Add * * .
+} else {
+ foreach vh [cget vhost] {
+ VHost_Add [lindex $vh 0] [lindex $vh 1] [lindex $vh 2]
+ }--andrewsh