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. `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] + } +}` <>TclHttpd