mingw/lib/tcl8.5/http1.0/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 }