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