| 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 | } |