diff options
Diffstat (limited to 'tcl8.6/tests/httpd11.tcl')
| -rw-r--r-- | tcl8.6/tests/httpd11.tcl | 255 |
1 files changed, 255 insertions, 0 deletions
diff --git a/tcl8.6/tests/httpd11.tcl b/tcl8.6/tests/httpd11.tcl new file mode 100644 index 0000000..6eae2b71f --- /dev/null +++ b/tcl8.6/tests/httpd11.tcl @@ -0,0 +1,255 @@ +# httpd11.tcl -- -*- tcl -*- +# +# A simple httpd for testing HTTP/1.1 client features. +# Not suitable for use on a internet connected port. +# +# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6 + +proc ::tcl::dict::get? {dict key} { + if {[dict exists $dict $key]} { + return [dict get $dict $key] + } + return +} +namespace ensemble configure dict \ + -map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?] + +proc make-chunk-generator {data {size 4096}} { + variable _chunk_gen_uid + if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0} + set lambda {{data size} { + set pos 0 + yield + while {1} { + set payload [string range $data $pos [expr {$pos + $size - 1}]] + incr pos $size + set chunk [format %x [string length $payload]]\r\n$payload\r\n + yield $chunk + if {![string length $payload]} {return} + } + }} + set name chunker[incr _chunk_gen_uid] + coroutine $name ::apply $lambda $data $size + return $name +} + +proc get-chunks {data {compression gzip}} { + switch -exact -- $compression { + gzip { set data [zlib gzip $data] } + deflate { set data [zlib deflate $data] } + compress { set data [zlib compress $data] } + } + + set data "" + set chunker [make-chunk-generator $data 512] + while {[string length [set chunk [$chunker]]]} { + append data $chunk + } + return $data +} + +proc blow-chunks {data {ochan stdout} {compression gzip}} { + switch -exact -- $compression { + gzip { set data [zlib gzip $data] } + deflate { set data [zlib deflate $data] } + compress { set data [zlib compress $data] } + } + + set chunker [make-chunk-generator $data 512] + while {[string length [set chunk [$chunker]]]} { + puts -nonewline $ochan $chunk + } + return +} + +proc mime-type {filename} { + switch -exact -- [file extension $filename] { + .htm - .html { return {text text/html}} + .png { return {binary image/png} } + .jpg { return {binary image/jpeg} } + .gif { return {binary image/gif} } + .css { return {text text/css} } + .xml { return {text text/xml} } + .xhtml {return {text application/xml+html} } + .svg { return {text image/svg+xml} } + .txt - .tcl - .c - .h { return {text text/plain}} + } + return {binary text/plain} +} + +proc Puts {chan s} {puts $chan $s; puts $s} + +proc Service {chan addr port} { + chan event $chan readable [info coroutine] + 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} + yield + } + if {[eof $chan]} {chan event $chan readable {}; close $chan; return} + foreach {req url protocol} {GET {} HTTP/1.1} break + regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol + + puts $line + while {[gets $chan line] > 0} { + if {[regexp {^([^:]+):(.*)$} $line -> key val]} { + puts [list $key [string trim $val]] + lappend meta [string tolower $key] [string trim $val] + } + yield + } + + set encoding identity + set transfer "" + set close 1 + set type text/html + set code "404 Not Found" + 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]} { + foreach {what type} [mime-type $path] break + set f [open $path r] + if {$what eq "binary"} {chan configure $f -translation binary} + set data [read $f] + close $f + set code "200 OK" + set close [expr {[dict get? $meta connection] eq "close"}] + } + + if {$protocol eq "HTTP/1.1"} { + foreach enc [split [dict get? $meta accept-encoding] ,] { + set enc [string trim $enc] + if {$enc in {deflate gzip compress}} { + set encoding $enc + break + } + } + set transfer chunked + } else { + set close 1 + } + + foreach pair [split $query &] { + if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} + switch -exact -- $key { + close {set close 1 ; set transfer 0} + transfer {set transfer $val} + content-type {set type $val} + } + } + + chan configure $chan -buffering line -encoding iso8859-1 -translation crlf + Puts $chan "$protocol $code" + Puts $chan "content-type: $type" + 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" + } + Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" + if {$encoding eq "identity"} { + Puts $chan "content-length: [string length $data]" + } else { + Puts $chan "content-encoding: $encoding" + } + if {$transfer eq "chunked"} { + Puts $chan "transfer-encoding: chunked" + } + puts $chan "" + flush $chan + + chan configure $chan -buffering full -translation binary + if {$transfer eq "chunked"} { + blow-chunks $data $chan $encoding + } elseif {$encoding ne "identity"} { + puts -nonewline $chan [zlib $encoding $data] + } else { + puts -nonewline $chan $data + } + + if {$close} { + chan event $chan readable {} + close $chan + puts "close $chan" + return + } else { + flush $chan + } + puts "pipeline $chan" + } +} + +proc Accept {chan addr port} { + coroutine client$chan Service $chan $addr $port + return +} + +proc Control {chan} { + if {[gets $chan line] != -1} { + if {[string trim $line] eq "quit"} { + set ::forever 1 + } + } + if {[eof $chan]} { + chan event $chan readable {} + } +} + +proc Main {{port 0}} { + set server [socket -server Accept -myaddr localhost $port] + puts [chan configure $server -sockname] + flush stdout + chan event stdin readable [list Control stdin] + vwait ::forever + close $server + return "done" +} + +if {!$tcl_interactive} { + set r [catch [linsert $argv 0 Main] err] + if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err} + exit $r +} |