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# SCCS: @(#) http.tcl 1.2 97/01/22 13:12:02 9# 10# See the http.n man page for documentation 11 12package provide http 1.0 13 14if {[info commands "unsupported0"] == "unsupported0"} { 15 rename unsupported0 copychannel 16} 17array set http { 18 -proxyhost {} 19 -proxyport {} 20 -useragent {Tcl http client package 1.0} 21 -proxyfilter httpProxyRequired 22} 23proc http_config {args} { 24 global http 25 if {[llength $args] == 0} { 26 set result {} 27 foreach name [lsort [array names http -*]] { 28 lappend result $name $http($name) 29 } 30 return $result 31 } elseif {[llength $args] == 1} { 32 set flag [lindex $args 0] 33 if {[regexp -- {^-(proxyhost|proxyport|proxyfilter|agent)$} $flag]} { 34 return $http($flag) 35 } else { 36 return -code error "Unknown option $flag, must be -proxyfilter, -proxyhost, -proxyport, or -useragent" 37 } 38 } else { 39 foreach {flag value} $args { 40 switch -- $flag { 41 -proxyhost - 42 -proxyport - 43 -proxyfilter - 44 -useragent { 45 set http($flag) $value 46 } 47 default { 48 return -code error "Unknown option $flag, must be -proxyfilter, -proxyhost, -proxyport, or -useragent" 49 } 50 } 51 } 52 } 53} 54 55proc http_reset { token } { 56 upvar #0 $token state 57 set state(status) reset 58 catch {fileevent $state(sock) readable {}} 59 catch {eval $state(-command) {$token}} 60 catch {close $state(sock)} 61 catch {unset state} 62} 63proc http_get { url args } { 64 global http 65 if ![info exists http(uid)] { 66 set http(uid) 0 67 } 68 set token http#[incr http(uid)] 69 upvar #0 $token state 70 http_reset $token 71 array set state { 72 -command {# } 73 -blocksize 8192 74 -validate 0 75 -headers {} 76 state header 77 meta {} 78 currentsize 0 79 totalsize 0 80 type text/html 81 body {} 82 status "" 83 } 84 foreach {flag value} $args { 85 switch -- $flag { 86 -blocksize - 87 -channel - 88 -command - 89 -headers - 90 -progress - 91 -query - 92 -validate { 93 set state($flag) $value 94 } 95 default { 96 return -code error "Unknown option $flag: can be -blocksize, -channel, -command, -headers, -progress, -query, or -validate" 97 } 98 } 99 } 100 if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)} $url \ 101 x proto host y port srvurl]} { 102 error "Unsupported URL: $url" 103 } 104 if {[string length $port] == 0} { 105 set port 80 106 } 107 if {[string length $proto] == 0} { 108 set url http://$url 109 } 110 set state(url) $url 111 if {![catch {$http(-proxyfilter) $host} proxy]} { 112 set phost [lindex $proxy 0] 113 set pport [lindex $proxy 1] 114 } 115 if {[info exists phost] && [string length $phost]} { 116 set srvurl $url 117 set s [socket $phost $pport] 118 } else { 119 set s [socket $host $port] 120 } 121 set state(sock) $s 122 # Send data in cr-lf format, but accept any line terminators 123 fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) 124 # this is disallowed in safe interpreters, but the socket 125 # is already in non-blocking mode in that case. 126 catch {fconfigure $s -blocking off} 127 set len 0 128 set how GET 129 if {[info exists state(-query)]} { 130 set len [string length $state(-query)] 131 if {$len > 0} { 132 set how POST 133 } 134 } elseif {$state(-validate)} { 135 set how HEAD 136 } 137 puts $s "$how $srvurl HTTP/1.0" 138 puts $s "Accept: */*" 139 puts $s "Host: $host" 140 puts $s "User-Agent: $http(-useragent)" 141 foreach {key value} $state(-headers) { 142 regsub -all \[\n\r\] $value {} value 143 set key [string trim $key] 144 if {[string length $key]} { 145 puts $s "$key: $value" 146 } 147 } 148 if {$len > 0} { 149 puts $s "Content-Length: $len" 150 puts $s "Content-Transfer-Encoding: x-url-encoding" 151 puts $s "" 152 fconfigure $s -translation {auto binary} 153 puts $s $state(-query) 154 } else { 155 puts $s "" 156 } 157 flush $s 158 fileevent $s readable [list httpEvent $token] 159 return $token 160} 161 162 proc httpEvent {token} { 163 upvar #0 $token state 164 set s $state(sock) 165 166 if [eof $s] then { 167 close $s 168 if {$state(state) == "header"} { 169 # Premature eof 170 set state(status) eof 171 } else { 172 set state(status) ok 173 } 174 set state(state) eof 175 eval $state(-command) {$token} 176 return 177 } 178 if {$state(state) == "header"} { 179 set n [gets $s line] 180 if {$n == 0} { 181 set state(state) body 182 if ![regexp -nocase ^text $state(type)] { 183 # Turn off conversions for non-text data 184 fconfigure $s -translation binary 185 } 186 } elseif {$n > 0} { 187 if [regexp -nocase {^content-type:(.+)$} $line x type] { 188 set state(type) [string trim $type] 189 } 190 if [regexp -nocase {^content-length:(.+)$} $line x length] { 191 set state(totalsize) [string trim $length] 192 } 193 if [regexp -nocase {^([^:]+):(.+)$} $line x key value] { 194 lappend state(meta) $key $value 195 } elseif {[regexp ^HTTP $line]} { 196 set state(http) $line 197 } 198 } 199 } else { 200 if [catch { 201# if [info exists state(-image)] { 202# $state(-image) config -channel $s 203# } else 204 if {[info exists state(-channel)]} { 205 set n [copychannel $s $state(-channel) $state(-blocksize)] 206 } else { 207 set block [read $s $state(-blocksize)] 208 set n [string length $block] 209 if {$n >= 0} { 210 append state(body) $block 211 } 212 } 213 if {$n >= 0} { 214 incr state(currentsize) $n 215 } 216 } err] { 217 set state(error) $err 218 http_reset $token 219 } else { 220 if [info exists state(-progress)] { 221 eval $state(-progress) {$token $state(totalsize) $state(currentsize)} 222 } 223 } 224 } 225} 226proc http_wait {token} { 227 upvar #0 $token state 228 if {![info exists state(status)] || [string length $state(status)] == 0} { 229 vwait $token\(status) 230 } 231 return $state(status) 232} 233 234# Call http_formatQuery with an even number of arguments, where the first is 235# a name, the second is a value, the third is another name, and so on. 236 237proc http_formatQuery {args} { 238 set result "" 239 set sep "" 240 foreach i $args { 241 append result $sep [httpMapReply $i] 242 if {$sep != "="} { 243 set sep = 244 } else { 245 set sep & 246 } 247 } 248 return $result 249} 250 251# do x-www-urlencoded character mapping 252# The spec says: "non-alphanumeric characters are replaced by '%HH'" 253# 1 leave alphanumerics characters alone 254# 2 Convert every other character to an array lookup 255# 3 Escape constructs that are "special" to the tcl parser 256# 4 "subst" the result, doing all the array substitutions 257 258 proc httpMapReply {string} { 259 global httpFormMap 260 set alphanumeric a-zA-Z0-9 261 if ![info exists httpFormMap] { 262 263 for {set i 1} {$i <= 256} {incr i} { 264 set c [format %c $i] 265 if {![string match \[$alphanumeric\] $c]} { 266 set httpFormMap($c) %[format %.2x $i] 267 } 268 } 269 # These are handled specially 270 array set httpFormMap { 271 " " + \n %0d%0a 272 } 273 } 274 regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string 275 regsub -all \n $string {\\n} string 276 regsub -all \t $string {\\t} string 277 regsub -all {[][{})\\]\)} $string {\\&} string 278 return [subst $string] 279} 280 281# Default proxy filter. 282 proc httpProxyRequired {host} { 283 global http 284 if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { 285 if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { 286 set http(-proxyport) 8080 287 } 288 return [list $http(-proxyhost) $http(-proxyport)] 289 } else { 290 return {} 291 } 292} 293