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 12package provide http 1.0 13 14array set http { 15 -accept */* 16 -proxyhost {} 17 -proxyport {} 18 -useragent {Tcl http client package 1.0} 19 -proxyfilter httpProxyRequired 20} 21proc 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} 71proc 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} 82proc 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} 195proc http_data {token} { 196 upvar #0 $token state 197 return $state(body) 198} 199proc http_status {token} { 200 upvar #0 $token state 201 return $state(status) 202} 203proc http_code {token} { 204 upvar #0 $token state 205 return $state(http) 206} 207proc 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} 308proc 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 324proc 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} 380