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