1# -*- tcl -*- 2# 3# The httpd_ procedures implement a stub http server. 4# 5# Copyright © 1997-1998 Sun Microsystems, Inc. 6# Copyright © 1999-2000 Scriptics Corporation 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 11#set httpLog 1 12 13# Do not use [info hostname]. 14# Name resolution is often a problem on OSX; not focus of HTTP package anyway. 15# Also a problem on other platforms for http-4.14 (test with bad port number). 16set HOST localhost 17 18proc httpd_init {{port 8015}} { 19 set s [socket -server httpdAccept $port] 20 # Save the actual port number in a global variable. 21 # This is important when we're called with port 0 22 # for picking an unused port at random. 23 set ::port [lindex [chan configure $s -sockname] 2] 24 return $s 25} 26proc httpd_log {args} { 27 global httpLog 28 if {[info exists httpLog] && $httpLog} { 29 puts stderr "httpd: [join $args { }]" 30 } 31} 32array set httpdErrors { 33 204 {No Content} 34 400 {Bad Request} 35 401 {Authorization Required} 36 404 {Not Found} 37 503 {Service Unavailable} 38 504 {Service Temporarily Unavailable} 39} 40 41proc httpdError {sock code args} { 42 global httpdErrors 43 puts $sock "$code $httpdErrors($code)" 44 httpd_log "error: [join $args { }]" 45} 46proc httpdAccept {newsock ipaddr port} { 47 global httpd 48 upvar #0 httpd$newsock data 49 50 fconfigure $newsock -blocking 0 -translation {auto crlf} 51 httpd_log $newsock Connect $ipaddr $port 52 set data(ipaddr) $ipaddr 53 after 50 [list fileevent $newsock readable [list httpdRead $newsock]] 54} 55 56# read data from a client request 57 58proc httpdRead { sock } { 59 upvar #0 httpd$sock data 60 61 if {[eof $sock]} { 62 set readCount -1 63 } elseif {![info exists data(state)]} { 64 65 # Read the protocol line and parse out the URL and query 66 67 set readCount [gets $sock line] 68 if {[regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} $line \ 69 -> data(proto) data(url) data(query) data(httpversion)]} { 70 set data(state) mime 71 httpd_log $sock Query $line 72 } else { 73 httpdError $sock 400 74 httpd_log $sock Error "bad first line:$line" 75 httpdSockDone $sock 76 } 77 return 78 } elseif {$data(state) == "mime"} { 79 80 # Read the HTTP headers 81 82 set readCount [gets $sock line] 83 if {[regexp {^([^:]+):(.*)$} $line -> key val]} { 84 lappend data(meta) $key [string trim $val] 85 } 86 87 } elseif {$data(state) == "query"} { 88 89 # Read the query data 90 91 if {![info exists data(length_orig)]} { 92 set data(length_orig) $data(length) 93 } 94 set line [read $sock $data(length)] 95 set readCount [string length $line] 96 incr data(length) -$readCount 97 } 98 99 # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 100 101 set state [string compare $readCount 0],$data(state),$data(proto) 102 httpd_log $sock $state 103 switch -- $state { 104 -1,mime,HEAD - 105 -1,mime,GET - 106 -1,mime,POST { 107 # gets would block 108 return 109 } 110 0,mime,HEAD - 111 0,mime,GET - 112 0,query,POST { 113 # Empty line at end of headers, 114 # or eof after query data 115 httpdRespond $sock 116 } 117 0,mime,POST { 118 # Empty line between headers and query data 119 if {![info exists data(mime,content-length)]} { 120 httpd_log $sock Error "No Content-Length for POST" 121 httpdError $sock 400 122 httpdSockDone $sock 123 } else { 124 set data(state) query 125 set data(length) $data(mime,content-length) 126 127 # Special case to simulate servers that respond 128 # without reading the post data. 129 130 if {[string match *droppost* $data(url)]} { 131 fileevent $sock readable {} 132 httpdRespond $sock 133 } 134 } 135 } 136 1,mime,HEAD - 137 1,mime,POST - 138 1,mime,GET { 139 # A line of HTTP headers 140 if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} { 141 set data(mime,[string tolower $key]) $value 142 } 143 } 144 -1,query,POST { 145 httpd_log $sock Error "unexpected eof on <$data(url)> request" 146 httpdError $sock 400 147 httpdSockDone $sock 148 } 149 1,query,POST { 150 append data(query) $line 151 if {$data(length) <= 0} { 152 set data(length) $data(length_orig) 153 httpdRespond $sock 154 } 155 } 156 default { 157 if {[eof $sock]} { 158 httpd_log $sock Error "unexpected eof on <$data(url)> request" 159 } else { 160 httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" 161 } 162 httpdError $sock 404 163 httpdSockDone $sock 164 } 165 } 166} 167proc httpdSockDone { sock } { 168 upvar #0 httpd$sock data 169 unset data 170 catch {close $sock} 171} 172 173# Respond to the query. 174 175proc httpdRespond { sock } { 176 global httpd bindata port 177 upvar #0 httpd$sock data 178 179 switch -glob -- $data(url) { 180 *binary* { 181 set html "$bindata${::HOST}:$port$data(url)" 182 set type application/octet-stream 183 } 184 *xml* { 185 set html [encoding convertto utf-8 "<test>\u1234</test>"] 186 set type "application/xml;charset=UTF-8" 187 } 188 *post* { 189 set html "Got [string length $data(query)] bytes" 190 set type text/plain 191 } 192 *headers* { 193 set html "" 194 set type text/plain 195 foreach {key value} $data(meta) { 196 append html [list $key $value] "\n" 197 } 198 set html [string trim $html] 199 } 200 default { 201 set type text/html 202 203 set html "<html><head><title>HTTP/1.0 TEST</title></head><body> 204<h1>Hello, World!</h1> 205<h2>$data(proto) $data(url)</h2> 206" 207 if {[info exists data(query)] && [string length $data(query)]} { 208 append html "<h2>Query</h2>\n<dl>\n" 209 foreach {key value} [split $data(query) &=] { 210 append html "<dt>$key<dd>$value\n" 211 if {$key == "timeout"} { 212 after $value ;# pause 213 } 214 } 215 append html </dl>\n 216 } 217 append html </body></html> 218 } 219 } 220 221 # Catch errors from premature client closes 222 223 catch { 224 if {$data(proto) == "HEAD"} { 225 puts $sock "HTTP/1.0 200 OK" 226 } else { 227 # Split the response to test for [Bug 26245326] 228 puts -nonewline $sock "HT" 229 flush $sock 230 puts $sock "TP/1.0 200 Data follows" 231 } 232 puts $sock "Date: [clock format [clock seconds] \ 233 -format {%a, %d %b %Y %H:%M:%S %Z}]" 234 puts $sock "Content-Type: $type" 235 puts $sock "Content-Length: [string length $html]" 236 foreach {key val} $data(meta) { 237 if {[string match "X-*" $key]} { 238 puts $sock "$key: $val" 239 } 240 } 241 puts $sock "" 242 flush $sock 243 if {$data(proto) != "HEAD"} { 244 fconfigure $sock -translation binary 245 puts -nonewline $sock $html 246 } 247 } 248 httpd_log $sock Done "" 249 httpdSockDone $sock 250} 251