1# httpd11.tcl -- -*- tcl -*- 2# 3# A simple httpd for testing HTTP/1.1 client features. 4# Not suitable for use on a internet connected port. 5# 6# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 11package require Tcl 8.6- 12 13proc ::tcl::dict::get? {dict key} { 14 if {[dict exists $dict $key]} { 15 return [dict get $dict $key] 16 } 17 return 18} 19namespace ensemble configure dict \ 20 -map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?] 21 22proc make-chunk-generator {data {size 4096}} { 23 variable _chunk_gen_uid 24 if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0} 25 set lambda {{data size} { 26 set pos 0 27 yield 28 while {1} { 29 set payload [string range $data $pos [expr {$pos + $size - 1}]] 30 incr pos $size 31 set chunk [format %x [string length $payload]]\r\n$payload\r\n 32 yield $chunk 33 if {![string length $payload]} {return} 34 } 35 }} 36 set name chunker[incr _chunk_gen_uid] 37 coroutine $name ::apply $lambda $data $size 38 return $name 39} 40 41proc get-chunks {data {compression gzip}} { 42 switch -exact -- $compression { 43 gzip { set data [zlib gzip $data] } 44 deflate { set data [zlib deflate $data] } 45 compress { set data [zlib compress $data] } 46 } 47 48 set data "" 49 set chunker [make-chunk-generator $data 512] 50 while {[string length [set chunk [$chunker]]]} { 51 append data $chunk 52 } 53 return $data 54} 55 56proc blow-chunks {data {ochan stdout} {compression gzip}} { 57 switch -exact -- $compression { 58 gzip { set data [zlib gzip $data] } 59 deflate { set data [zlib deflate $data] } 60 compress { set data [zlib compress $data] } 61 } 62 63 set chunker [make-chunk-generator $data 512] 64 while {[string length [set chunk [$chunker]]]} { 65 puts -nonewline $ochan $chunk 66 } 67 return 68} 69 70proc mime-type {filename} { 71 switch -exact -- [file extension $filename] { 72 .htm - .html { return {text text/html}} 73 .png { return {binary image/png} } 74 .jpg { return {binary image/jpeg} } 75 .gif { return {binary image/gif} } 76 .css { return {text text/css} } 77 .xml { return {text text/xml} } 78 .xhtml {return {text application/xml+html} } 79 .svg { return {text image/svg+xml} } 80 .txt - .tcl - .c - .h { return {text text/plain}} 81 } 82 return {binary text/plain} 83} 84 85proc Puts {chan s} {puts $chan $s; puts $s} 86 87proc Service {chan addr port} { 88 chan event $chan readable [info coroutine] 89 while {1} { 90 set meta {} 91 chan configure $chan -buffering line -encoding iso8859-1 -translation crlf 92 chan configure $chan -blocking 0 93 yield 94 while {[gets $chan line] < 0} { 95 if {[eof $chan]} {chan event $chan readable {}; close $chan; return} 96 yield 97 } 98 if {[eof $chan]} {chan event $chan readable {}; close $chan; return} 99 foreach {req url protocol} {GET {} HTTP/1.1} break 100 regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol 101 102 puts $line 103 while {[gets $chan line] > 0} { 104 if {[regexp {^([^:]+):(.*)$} $line -> key val]} { 105 puts [list $key [string trim $val]] 106 lappend meta [string tolower $key] [string trim $val] 107 } 108 yield 109 } 110 111 set encoding identity 112 set transfer "" 113 set close 1 114 set type text/html 115 set code "404 Not Found" 116 set data "<html><head><title>Error 404</title></head>" 117 append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>" 118 119 if {[scan $url {%[^?]?%s} path query] < 2} { 120 set query "" 121 } 122 123 switch -exact -- $req { 124 GET - HEAD { 125 } 126 POST { 127 # Read the query. 128 set qlen [dict get? $meta content-length] 129 if {[string is integer -strict $qlen]} { 130 chan configure $chan -buffering none -translation binary 131 while {[string length $query] < $qlen} { 132 append query [read $chan $qlen] 133 if {[string length $query] < $qlen} {yield} 134 } 135 # Check for excess query bytes [Bug 2715421] 136 if {[dict get? $meta x-check-query] eq "yes"} { 137 chan configure $chan -blocking 0 138 append query [read $chan] 139 } 140 } 141 } 142 default { 143 # invalid request error 5?? 144 } 145 } 146 if {$query ne ""} {puts $query} 147 148 set path [string trimleft $path /] 149 set path [file join [pwd] $path] 150 if {[file exists $path] && [file isfile $path]} { 151 foreach {what type} [mime-type $path] break 152 set f [open $path r] 153 if {$what eq "binary"} {chan configure $f -translation binary} 154 set data [read $f] 155 close $f 156 set code "200 OK" 157 set close [expr {[dict get? $meta connection] eq "close"}] 158 } 159 160 if {$protocol eq "HTTP/1.1"} { 161 foreach enc [split [dict get? $meta accept-encoding] ,] { 162 set enc [string trim $enc] 163 if {$enc in {deflate gzip compress}} { 164 set encoding $enc 165 break 166 } 167 } 168 set transfer chunked 169 } else { 170 set close 1 171 } 172 173 set nosendclose 0 174 foreach pair [split $query &] { 175 if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} 176 switch -exact -- $key { 177 nosendclose {set nosendclose 1} 178 close {set close 1 ; set transfer 0} 179 transfer {set transfer $val} 180 content-type {set type $val} 181 } 182 } 183 if {$protocol eq "HTTP/1.1"} { 184 set nosendclose 0 185 } 186 187 chan configure $chan -buffering line -encoding iso8859-1 -translation crlf 188 Puts $chan "$protocol $code" 189 Puts $chan "content-type: $type" 190 Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]] 191 if {$req eq "POST"} { 192 Puts $chan [format "x-query-length: %d" [string length $query]] 193 } 194 if {$close && (!$nosendclose)} { 195 Puts $chan "connection: close" 196 } 197 Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" 198 if {$encoding eq "identity" && (!$nosendclose)} { 199 Puts $chan "content-length: [string length $data]" 200 } elseif {$encoding eq "identity"} { 201 # This is a blatant attempt to confuse the client by sending neither 202 # "Connection: close" nor "Content-Length" when in non-chunked mode. 203 # See test http11-3.4. 204 } else { 205 Puts $chan "content-encoding: $encoding" 206 } 207 if {$transfer eq "chunked"} { 208 Puts $chan "transfer-encoding: chunked" 209 } 210 puts $chan "" 211 flush $chan 212 213 chan configure $chan -buffering full -translation binary 214 if {$transfer eq "chunked"} { 215 blow-chunks $data $chan $encoding 216 } elseif {$encoding ne "identity"} { 217 puts -nonewline $chan [zlib $encoding $data] 218 } else { 219 puts -nonewline $chan $data 220 } 221 222 if {$close} { 223 chan event $chan readable {} 224 close $chan 225 puts "close $chan" 226 return 227 } else { 228 flush $chan 229 } 230 puts "pipeline $chan" 231 } 232} 233 234proc Accept {chan addr port} { 235 coroutine client$chan Service $chan $addr $port 236 return 237} 238 239proc Control {chan} { 240 if {[gets $chan line] >= 0} { 241 if {[string trim $line] eq "quit"} { 242 set ::forever 1 243 } 244 } 245 if {[eof $chan]} { 246 chan event $chan readable {} 247 } 248} 249 250proc Main {{port 0}} { 251 set server [socket -server Accept -myaddr localhost $port] 252 puts [chan configure $server -sockname] 253 flush stdout 254 chan event stdin readable [list Control stdin] 255 vwait ::forever 256 close $server 257 return "done" 258} 259 260if {!$tcl_interactive} { 261 set r [catch [linsert $argv 0 Main] err] 262 if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err} 263 exit $r 264} 265