Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | # http.tcl |
2 | # Client-side HTTP for GET, POST, and HEAD commands. | |
3 | # These routines can be used in untrusted code that uses the Safesock | |
4 | # security policy. | |
5 | # These procedures use a callback interface to avoid using vwait, | |
6 | # which is not defined in the safe base. | |
7 | # | |
8 | # RCS: @(#) $Id: http.tcl,v 1.4 2000/02/01 11:48:30 hobbs Exp $ | |
9 | # | |
10 | # See the http.n man page for documentation | |
11 | ||
12 | package provide http 1.0 | |
13 | ||
14 | array set http { | |
15 | -accept */* | |
16 | -proxyhost {} | |
17 | -proxyport {} | |
18 | -useragent {Tcl http client package 1.0} | |
19 | -proxyfilter httpProxyRequired | |
20 | } | |
21 | proc http_config {args} { | |
22 | global http | |
23 | set options [lsort [array names http -*]] | |
24 | set usage [join $options ", "] | |
25 | if {[llength $args] == 0} { | |
26 | set result {} | |
27 | foreach name $options { | |
28 | lappend result $name $http($name) | |
29 | } | |
30 | return $result | |
31 | } | |
32 | regsub -all -- - $options {} options | |
33 | set pat ^-([join $options |])$ | |
34 | if {[llength $args] == 1} { | |
35 | set flag [lindex $args 0] | |
36 | if {[regexp -- $pat $flag]} { | |
37 | return $http($flag) | |
38 | } else { | |
39 | return -code error "Unknown option $flag, must be: $usage" | |
40 | } | |
41 | } else { | |
42 | foreach {flag value} $args { | |
43 | if {[regexp -- $pat $flag]} { | |
44 | set http($flag) $value | |
45 | } else { | |
46 | return -code error "Unknown option $flag, must be: $usage" | |
47 | } | |
48 | } | |
49 | } | |
50 | } | |
51 | ||
52 | proc httpFinish { token {errormsg ""} } { | |
53 | upvar #0 $token state | |
54 | global errorInfo errorCode | |
55 | if {[string length $errormsg] != 0} { | |
56 | set state(error) [list $errormsg $errorInfo $errorCode] | |
57 | set state(status) error | |
58 | } | |
59 | catch {close $state(sock)} | |
60 | catch {after cancel $state(after)} | |
61 | if {[info exists state(-command)]} { | |
62 | if {[catch {eval $state(-command) {$token}} err]} { | |
63 | if {[string length $errormsg] == 0} { | |
64 | set state(error) [list $err $errorInfo $errorCode] | |
65 | set state(status) error | |
66 | } | |
67 | } | |
68 | unset state(-command) | |
69 | } | |
70 | } | |
71 | proc http_reset { token {why reset} } { | |
72 | upvar #0 $token state | |
73 | set state(status) $why | |
74 | catch {fileevent $state(sock) readable {}} | |
75 | httpFinish $token | |
76 | if {[info exists state(error)]} { | |
77 | set errorlist $state(error) | |
78 | unset state(error) | |
79 | eval error $errorlist | |
80 | } | |
81 | } | |
82 | proc http_get { url args } { | |
83 | global http | |
84 | if {![info exists http(uid)]} { | |
85 | set http(uid) 0 | |
86 | } | |
87 | set token http#[incr http(uid)] | |
88 | upvar #0 $token state | |
89 | http_reset $token | |
90 | array set state { | |
91 | -blocksize 8192 | |
92 | -validate 0 | |
93 | -headers {} | |
94 | -timeout 0 | |
95 | state header | |
96 | meta {} | |
97 | currentsize 0 | |
98 | totalsize 0 | |
99 | type text/html | |
100 | body {} | |
101 | status "" | |
102 | } | |
103 | set options {-blocksize -channel -command -handler -headers \ | |
104 | -progress -query -validate -timeout} | |
105 | set usage [join $options ", "] | |
106 | regsub -all -- - $options {} options | |
107 | set pat ^-([join $options |])$ | |
108 | foreach {flag value} $args { | |
109 | if {[regexp $pat $flag]} { | |
110 | # Validate numbers | |
111 | if {[info exists state($flag)] && \ | |
112 | [regexp {^[0-9]+$} $state($flag)] && \ | |
113 | ![regexp {^[0-9]+$} $value]} { | |
114 | return -code error "Bad value for $flag ($value), must be integer" | |
115 | } | |
116 | set state($flag) $value | |
117 | } else { | |
118 | return -code error "Unknown option $flag, can be: $usage" | |
119 | } | |
120 | } | |
121 | if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ | |
122 | x proto host y port srvurl]} { | |
123 | error "Unsupported URL: $url" | |
124 | } | |
125 | if {[string length $port] == 0} { | |
126 | set port 80 | |
127 | } | |
128 | if {[string length $srvurl] == 0} { | |
129 | set srvurl / | |
130 | } | |
131 | if {[string length $proto] == 0} { | |
132 | set url http://$url | |
133 | } | |
134 | set state(url) $url | |
135 | if {![catch {$http(-proxyfilter) $host} proxy]} { | |
136 | set phost [lindex $proxy 0] | |
137 | set pport [lindex $proxy 1] | |
138 | } | |
139 | if {$state(-timeout) > 0} { | |
140 | set state(after) [after $state(-timeout) [list http_reset $token timeout]] | |
141 | } | |
142 | if {[info exists phost] && [string length $phost]} { | |
143 | set srvurl $url | |
144 | set s [socket $phost $pport] | |
145 | } else { | |
146 | set s [socket $host $port] | |
147 | } | |
148 | set state(sock) $s | |
149 | ||
150 | # Send data in cr-lf format, but accept any line terminators | |
151 | ||
152 | fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) | |
153 | ||
154 | # The following is disallowed in safe interpreters, but the socket | |
155 | # is already in non-blocking mode in that case. | |
156 | ||
157 | catch {fconfigure $s -blocking off} | |
158 | set len 0 | |
159 | set how GET | |
160 | if {[info exists state(-query)]} { | |
161 | set len [string length $state(-query)] | |
162 | if {$len > 0} { | |
163 | set how POST | |
164 | } | |
165 | } elseif {$state(-validate)} { | |
166 | set how HEAD | |
167 | } | |
168 | puts $s "$how $srvurl HTTP/1.0" | |
169 | puts $s "Accept: $http(-accept)" | |
170 | puts $s "Host: $host" | |
171 | puts $s "User-Agent: $http(-useragent)" | |
172 | foreach {key value} $state(-headers) { | |
173 | regsub -all \[\n\r\] $value {} value | |
174 | set key [string trim $key] | |
175 | if {[string length $key]} { | |
176 | puts $s "$key: $value" | |
177 | } | |
178 | } | |
179 | if {$len > 0} { | |
180 | puts $s "Content-Length: $len" | |
181 | puts $s "Content-Type: application/x-www-form-urlencoded" | |
182 | puts $s "" | |
183 | fconfigure $s -translation {auto binary} | |
184 | puts -nonewline $s $state(-query) | |
185 | } else { | |
186 | puts $s "" | |
187 | } | |
188 | flush $s | |
189 | fileevent $s readable [list httpEvent $token] | |
190 | if {! [info exists state(-command)]} { | |
191 | http_wait $token | |
192 | } | |
193 | return $token | |
194 | } | |
195 | proc http_data {token} { | |
196 | upvar #0 $token state | |
197 | return $state(body) | |
198 | } | |
199 | proc http_status {token} { | |
200 | upvar #0 $token state | |
201 | return $state(status) | |
202 | } | |
203 | proc http_code {token} { | |
204 | upvar #0 $token state | |
205 | return $state(http) | |
206 | } | |
207 | proc http_size {token} { | |
208 | upvar #0 $token state | |
209 | return $state(currentsize) | |
210 | } | |
211 | ||
212 | proc httpEvent {token} { | |
213 | upvar #0 $token state | |
214 | set s $state(sock) | |
215 | ||
216 | if {[eof $s]} { | |
217 | httpEof $token | |
218 | return | |
219 | } | |
220 | if {$state(state) == "header"} { | |
221 | set n [gets $s line] | |
222 | if {$n == 0} { | |
223 | set state(state) body | |
224 | if {![regexp -nocase ^text $state(type)]} { | |
225 | # Turn off conversions for non-text data | |
226 | fconfigure $s -translation binary | |
227 | if {[info exists state(-channel)]} { | |
228 | fconfigure $state(-channel) -translation binary | |
229 | } | |
230 | } | |
231 | if {[info exists state(-channel)] && | |
232 | ![info exists state(-handler)]} { | |
233 | # Initiate a sequence of background fcopies | |
234 | fileevent $s readable {} | |
235 | httpCopyStart $s $token | |
236 | } | |
237 | } elseif {$n > 0} { | |
238 | if {[regexp -nocase {^content-type:(.+)$} $line x type]} { | |
239 | set state(type) [string trim $type] | |
240 | } | |
241 | if {[regexp -nocase {^content-length:(.+)$} $line x length]} { | |
242 | set state(totalsize) [string trim $length] | |
243 | } | |
244 | if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { | |
245 | lappend state(meta) $key $value | |
246 | } elseif {[regexp ^HTTP $line]} { | |
247 | set state(http) $line | |
248 | } | |
249 | } | |
250 | } else { | |
251 | if {[catch { | |
252 | if {[info exists state(-handler)]} { | |
253 | set n [eval $state(-handler) {$s $token}] | |
254 | } else { | |
255 | set block [read $s $state(-blocksize)] | |
256 | set n [string length $block] | |
257 | if {$n >= 0} { | |
258 | append state(body) $block | |
259 | } | |
260 | } | |
261 | if {$n >= 0} { | |
262 | incr state(currentsize) $n | |
263 | } | |
264 | } err]} { | |
265 | httpFinish $token $err | |
266 | } else { | |
267 | if {[info exists state(-progress)]} { | |
268 | eval $state(-progress) {$token $state(totalsize) $state(currentsize)} | |
269 | } | |
270 | } | |
271 | } | |
272 | } | |
273 | proc httpCopyStart {s token} { | |
274 | upvar #0 $token state | |
275 | if {[catch { | |
276 | fcopy $s $state(-channel) -size $state(-blocksize) -command \ | |
277 | [list httpCopyDone $token] | |
278 | } err]} { | |
279 | httpFinish $token $err | |
280 | } | |
281 | } | |
282 | proc httpCopyDone {token count {error {}}} { | |
283 | upvar #0 $token state | |
284 | set s $state(sock) | |
285 | incr state(currentsize) $count | |
286 | if {[info exists state(-progress)]} { | |
287 | eval $state(-progress) {$token $state(totalsize) $state(currentsize)} | |
288 | } | |
289 | if {([string length $error] != 0)} { | |
290 | httpFinish $token $error | |
291 | } elseif {[eof $s]} { | |
292 | httpEof $token | |
293 | } else { | |
294 | httpCopyStart $s $token | |
295 | } | |
296 | } | |
297 | proc httpEof {token} { | |
298 | upvar #0 $token state | |
299 | if {$state(state) == "header"} { | |
300 | # Premature eof | |
301 | set state(status) eof | |
302 | } else { | |
303 | set state(status) ok | |
304 | } | |
305 | set state(state) eof | |
306 | httpFinish $token | |
307 | } | |
308 | proc http_wait {token} { | |
309 | upvar #0 $token state | |
310 | if {![info exists state(status)] || [string length $state(status)] == 0} { | |
311 | vwait $token\(status) | |
312 | } | |
313 | if {[info exists state(error)]} { | |
314 | set errorlist $state(error) | |
315 | unset state(error) | |
316 | eval error $errorlist | |
317 | } | |
318 | return $state(status) | |
319 | } | |
320 | ||
321 | # Call http_formatQuery with an even number of arguments, where the first is | |
322 | # a name, the second is a value, the third is another name, and so on. | |
323 | ||
324 | proc http_formatQuery {args} { | |
325 | set result "" | |
326 | set sep "" | |
327 | foreach i $args { | |
328 | append result $sep [httpMapReply $i] | |
329 | if {$sep != "="} { | |
330 | set sep = | |
331 | } else { | |
332 | set sep & | |
333 | } | |
334 | } | |
335 | return $result | |
336 | } | |
337 | ||
338 | # do x-www-urlencoded character mapping | |
339 | # The spec says: "non-alphanumeric characters are replaced by '%HH'" | |
340 | # 1 leave alphanumerics characters alone | |
341 | # 2 Convert every other character to an array lookup | |
342 | # 3 Escape constructs that are "special" to the tcl parser | |
343 | # 4 "subst" the result, doing all the array substitutions | |
344 | ||
345 | proc httpMapReply {string} { | |
346 | global httpFormMap | |
347 | set alphanumeric a-zA-Z0-9 | |
348 | if {![info exists httpFormMap]} { | |
349 | ||
350 | for {set i 1} {$i <= 256} {incr i} { | |
351 | set c [format %c $i] | |
352 | if {![string match \[$alphanumeric\] $c]} { | |
353 | set httpFormMap($c) %[format %.2x $i] | |
354 | } | |
355 | } | |
356 | # These are handled specially | |
357 | array set httpFormMap { | |
358 | " " + \n %0d%0a | |
359 | } | |
360 | } | |
361 | regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string | |
362 | regsub -all \n $string {\\n} string | |
363 | regsub -all \t $string {\\t} string | |
364 | regsub -all {[][{})\\]\)} $string {\\&} string | |
365 | return [subst $string] | |
366 | } | |
367 | ||
368 | # Default proxy filter. | |
369 | proc httpProxyRequired {host} { | |
370 | global http | |
371 | if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { | |
372 | if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { | |
373 | set http(-proxyport) 8080 | |
374 | } | |
375 | return [list $http(-proxyhost) $http(-proxyport)] | |
376 | } else { | |
377 | return {} | |
378 | } | |
379 | } |