summaryrefslogtreecommitdiffstats
path: root/tcl8.6/tests/httpd11.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tcl8.6/tests/httpd11.tcl')
-rw-r--r--tcl8.6/tests/httpd11.tcl255
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
+}