blob: 64601a9c22395c9ffa751df986268f51129563c6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
# 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 {a_data {compression gzip}} {
switch -exact -- $compression {
gzip { set data [zlib gzip $a_data] }
deflate { set data [zlib deflate $a_data] }
compress { set data [zlib compress $a_data] }
default { set data [zlib gzip $a_data] }
}
set data ""
set chunker [make-chunk-generator $data 512]
while {[string length [set chunk [$chunker]]]} {
append data $chunk
}
return $data
}
proc blow-chunks {a_data {ochan stdout} {compression gzip}} {
switch -exact -- $compression {
gzip { set data [zlib gzip $a_data] }
deflate { set data [zlib deflate $a_data] }
compress { set data [zlib compress $a_data] }
default { set data [zlib gzip $a_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}}
default {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 [list]
chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
chan configure $chan -blocking 0
yield
while {[chan gets $chan line] < 0} {
if {[chan eof $chan]} {
chan event $chan readable {}
chan close $chan
return
}
yield
}
if {[eof $chan]} {
chan event $chan readable {}
chan close $chan
return
}
lassign {GET {} HTTP/1.1} req url protocol
regexp {^(\S+)\s+(.*)\s(\S+)?$} $line ___ req url protocol
chan puts $line
while {[chan gets $chan line] > 0} {
if {[regexp {^([^:]+):(.*)$} $line ___ key val]} {
chan 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 [chan 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]} {
lassign [mime-type $path] what type
set f [open $path r]
if {$what eq "binary"} {chan configure $f -translation binary}
set data [chan read $f]
chan close $f
set code "200 OK"
set close [expr {[dict get? $meta connection] eq "close"}]
}
if {$protocol eq "HTTP/1.1"} {
if {[string match "*deflate*" [dict get? $meta accept-encoding]]} {
set encoding deflate
} elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} {
set encoding gzip
} elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} {
set encoding compress
}
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}
default {}
}
}
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"
}
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"
}
chan puts $chan ""
chan flush $chan
chan configure $chan -buffering full -translation binary
if {$transfer eq "chunked"} {
blow-chunks $data $chan $encoding
} elseif {$encoding ne "identity"} {
chan puts -nonewline $chan [zlib $encoding $data]
} else {
chan puts -nonewline $chan $data
}
if {$close} {
chan event $chan readable {}
chan close $chan
chan puts "close $chan"
return
} else {
chan flush $chan
}
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
}
|
