+ Issue an http GET request to url.
+
+ -headers specifies an ns_set of extra headers to send to the server when doing the request. + Some options exist that allow to avoid the need to specify headers manually, but headers will always take precedence over options. +
+ +
+ -gzip_response_p informs the server that we are capable of receiving gzipped responses. + If server complies to our indication, the result will be automatically decompressed. +
+ ++ -force_ssl_p specifies wether we want to use SSL despite the url being in http:// form. + Default behavior is to use SSL on https:// urls only. +
+ ++ -spool_file enables file spooling of the request on the file specified. It is useful when we expect large responses from the server. +
+ ++ -preference decides which available implementation prefer in respective order. Choice is between 'native', based on ns_ api, available for Naviserver + only and giving the best performances and 'curl', which wraps the command line utility (available on every system with curl installed). +
+ + Returns the data in array get form with array elements page, status, and modified. +} { + return [util::http::request \ + -url $url \ + -method GET \ + -force_ssl=$force_ssl_p \ + -gzip_response=$gzip_response_p \ + -headers $headers \ + -timeout $timeout \ + -max_depth $max_depth \ + -depth $depth \ + -spool_file $spool_file \ + -preference $preference] +} + +ad_proc util::http::post { + -url + {-files {}} + -base64:boolean + {-formvars ""} + {-body ""} + {-headers ""} + {-timeout 30} + {-depth 0} + {-max_depth 1} + -force_ssl:boolean + -multipart:boolean + -gzip_request:boolean + -gzip_response:boolean + -post_redirect:boolean + {-spool_file ""} + {-preference {native curl}} +} { ++ Implement client-side HTTP POST request. +
+ +
+ -body is the payload for the request and will be passed as is (useful for many purposes, such as webDav).
+ A convenient way to specify form variables through this argument is passing a string obtained by export_vars -url.
+
+ File upload can be specified using actual files on the filesystem or binary strings of data using the -files parameter.
+ -files must be a list of array-lists in the form returned by array get.
+ Keys of -files parameter are:
+
-base64 flag is set, files will be base64 encoded (useful for some kind of form).
+
+
+ Other form variables can be passes in-formvars easily by the use of export_vars -url and will be translated
+ for the proper type of form. URL variables, as with GET requests, are also sent, but an error is thrown if URL variables conflict with those specified
+ in other ways.
+
+ Default behavior is to build payload as an 'application/x-www-form-urlencoded' payload if no files are specified,
+ and 'multipart/form-data' otherwise. If -multipart flag is set, format will be forced to multipart.
+
+ -headers specifies an ns_set of extra headers to send to the server when doing the request. + Some options exist that allow to avoid the need to specify headers manually, but headers will always take precedence over options. +
+ ++ -gzip_request_p informs the server that we are sending data in gzip format. Data will be automatically compressed. + Notice that not all servers can treat gzipped requests properly, and in such cases response will likely be an error. +
+ ++ -gzip_response_p informs the server that we are capable of receiving gzipped responses. + If server complies to our indication, the result will be automatically decompressed. +
+ ++ -force_ssl_p specifies wether we want to use SSL despite the url being in http:// form. + Default behavior is to use SSL on https:// urls only. +
+ ++ -spool_file enables file spooling of the request on the file specified. It is useful when we expect large responses from the server. +
+ ++ -post_redirect decides what happens when we are POSTing and server replies with 301, 302 or 303 redirects. RFC 2616/10.3.2 states that method + should not change when 301 or 302 are returned, and that GET should be used on a 303 response, but most HTTP clients fail in respecting this and switch + to a GET request independently. This options forces this kinds of redirect to conserve their original method. +
+ ++ -max_depth is the maximum number of redirects the proc is allowed to follow. Be aware that when following redirects, unless it is a code 303 + redirect, url and POST urlencoded variables will be sent again to the redirected host. Multipart variables won't be sent again. + Sending to the redirected host can be dangerous, if such host is not trusted or uses a lower level of secutiry. The default behavior is to not follow + redirects. +
+ ++ -preference decides which available implementation prefer in respective order. Choice is between 'native', based on ns_ api, available for Naviserver + only and giving the best performances and 'curl', which wraps the command line utility (available on every system with curl installed). +
+} { + set this_proc [lindex [info level 0] 0] + + # Retrieve variables sent by the URL... + set vars [lindex [split $url ?] 1] + foreach var [split $vars &] { + set var [split $var =] + set key [lindex $var 0] + set urlvars($key) 1 + } + + # Check wether we don't have multiple variable definition in url and payload + foreach var [split $formvars &] { + set var [split $var =] + set key [lindex $var 0] + if {[info exists urlvars($key)]} { + return -code error "${this_proc}: Variable '$key' already specified as url variable" + } + } + + if {$headers eq ""} { + set headers [ns_set create headers] + } + + # If required from headers, force a multipart form + set req_content_type [ns_set iget $headers "content-type"] + if {$req_content_type ne ""} { + set multipart_p [string match -nocase "*multipart/form-data*" $req_content_type] + # avoid duplicated headers + ns_set idelkey $headers "Content-type" + } + + ## Construction of the payload + # By user choice, or because we have files, this will be a 'multipart/form-data' payload... + if {$multipart_p || $files ne [list]} { + + set boundary [ns_sha1 [list [clock clicks -milliseconds] [clock seconds]]] + ns_set put $headers "Content-type" "multipart/form-data; boundary=$boundary" + + set payload {} + + # Transform files into binaries + foreach file $files { + array set f $file + + if {![info exists f(data)]} { + if {![info exists f(file)]} { + return -code error "${this_proc}: No file or binary data specified" + } + if {![file exists $f(file)]} { + return -code error "${this_proc}: Error reading file: $f(file) not found" + } + if {![file readable $f(file)]} { + return -code error "${this_proc}: Error reading file: $f(file) permission denied" + } + + set fp [open $f(file)] + fconfigure $fp -translation binary + set f(data) [read $fp] + close $fp + + if {![info exists f(filename)]} { + set f(filename) [file tail $f(file)] + } + } + + foreach key {data filename fieldname} { + if {![info exists f($key)]} { + return -code error "${this_proc}: '$key' missing for binary data" + } + } + + # Check that we don't already have this var specified in the url + if {[info exists urlvars($f(fieldname))]} { + return -code error "${this_proc}: file field '$f(fieldname)' already specified as url variable" + } + # Track form variables sent as files + set filevars($f(fieldname)) 1 + + if {![info exists f(mime_type)]} { + set f(mime_type) [ns_guesstype $f(filename)] + if {$f(mime_type) in {"*/*" ""}} { + set f(mime_type) "application/octet-stream" + } + } + + if {$base64_p} { + set f(data) [base64::encode $f(data)] + set transfer_encoding base64 + } else { + set transfer_encoding binary + } + + append payload --$boundary \ + \r\n \ + "Content-Disposition: form-data; " \ + "name=\"$f(fieldname)\"; filename=\"$f(filename)\"" \ + \r\n \ + "Content-Type: $f(mime_type)" \ + \r\n \ + "Content-transfer-encoding: $transfer_encoding" \ + \r\n \ + \r\n \ + $f(data) \ + \r\n + + } ; unset files + + # Translate urlencoded vars into multipart variables + foreach formvar [split $formvars &] { + set formvar [split $formvar =] + set key [lindex $formvar 0] + set val [join [lrange $formvar 1 end] =] + + if {[info exists filevars($key)]} { + return -code error "${this_proc}: Variable '$key' already specified as file variable" + } + + append payload --$boundary \ + \r\n \ + "Content-Disposition: form-data; name=\"$key\"" \ + \r\n \ + \r\n \ + $val \ + \r\n + + } ; unset formvars + + append payload --$boundary-- \r\n + + # ...otherwise this will be an 'application/x-www-form-urlencoded' payload + } else { + ns_set put $headers "Content-type" "application/x-www-form-urlencoded" + set payload $formvars; unset formvars + } + + # Body will be appended as is to the payload + append payload $body; unset body + + return [util::http::request -method POST \ + -body $payload \ + -headers $headers \ + -url $url \ + -timeout $timeout \ + -depth $depth \ + -max_depth $max_depth \ + -force_ssl=$force_ssl_p \ + -gzip_request=$gzip_request_p \ + -gzip_response=$gzip_response_p \ + -post_redirect=$post_redirect_p \ + -spool_file $spool_file \ + -preference $preference] +} + +ad_proc util::http::request { + -url + -method + {-headers ""} + {-body ""} + {-timeout 30} + {-depth 0} + {-max_depth 1} + -force_ssl:boolean + -gzip_request:boolean + -gzip_response:boolean + -post_redirect:boolean + {-spool_file ""} + {-preference {native curl}} +} { ++ Issue an HTTP request either GET or POST to the url specified. +
+ ++ -headers specifies an ns_set of extra headers to send to the server when doing the request. + Some options exist that allow to avoid the need to specify headers manually, but headers will always take precedence over options. +
+ +
+ -body is the payload for the request and will be passed as is (useful for many purposes, such as webDav).
+ A convenient way to specify form variables for POST payloads through this argument is passing a string obtained by export_vars -url.
+
+ -gzip_request_p informs the server that we are sending data in gzip format. Data will be automatically compressed. + Notice that not all servers can treat gzipped requests properly, and in such cases response will likely be an error. +
+ ++ -gzip_response_p informs the server that we are capable of receiving gzipped responses. + If server complies to our indication, the result will be automatically decompressed. +
+ ++ -force_ssl_p specifies wether we want to use SSL despite the url being in http:// form. Default behavior is to use SSL on https:// urls only. +
+ ++ -spool_file enables file spooling of the request on the file specified. It is useful when we expect large responses from the server. +
+ ++ -post_redirect decides what happens when we are POSTing and server replies with 301, 302 or 303 redirects. RFC 2616/10.3.2 states that method + should not change when 301 or 302 are returned, and that GET should be used on a 303 response, but most HTTP clients fail in respecting this and switch + to a GET request independently. This options forces this kinds of redirect to conserve their original method. Notice that, as from RFC, a 303 redirect + won't send again any data to the server, as specification says we can assume variables to have been received. +
+ ++ -max_depth is the maximum number of redirects the proc is allowed to follow. Be aware that when following redirects, unless it is a code 303 + redirect, url and POST urlencoded variables will be sent again to the redirected host. Multipart variables won't be sent again. + Sending to the redirected host can be dangerous, if such host is not trusted or uses a lower level of secutiry. The default behavior is to not follow + redirects. +
+ ++ -preference decides which available implementation prefer in respective order. Choice is between 'native', based on ns_ api, available for Naviserver + only and giving the best performances and 'curl', which wraps the command line utility (available on every system with curl installed). +
+} { + set this_proc [lindex [info level 0] 0] + + if {$force_ssl_p || [string match "https://*" $url]} { + set apis [lindex [apis] 1] + } else { + set apis [lindex [apis] 0] + } + + foreach p $preference { + if {$p in $apis} { + set impl $p; break + } + } + if {![info exists impl]} { + return -code error "${this_proc}: HTTP client functionalities for this protocol are not available with current system configuration." + } + + return [util::http::${impl}::request -method $method \ + -body $body \ + -headers $headers \ + -url $url \ + -timeout $timeout \ + -depth $depth \ + -max_depth $max_depth \ + -force_ssl=$force_ssl_p \ + -gzip_request=$gzip_request_p \ + -gzip_response=$gzip_response_p \ + -post_redirect=$post_redirect_p \ + -spool_file $spool_file] +} + + +# +## Native Naviserver implementation +# + +namespace eval util::http::native {} + +ad_proc -private util::http::native::request { + -url + -method + {-headers ""} + {-body ""} + {-timeout 30} + {-depth 0} + {-max_depth 1} + -force_ssl:boolean + -gzip_request:boolean + -gzip_response:boolean + -post_redirect:boolean + {-spool_file ""} +} { ++ Issue an HTTP request either GET or POST to the url specified. +
+ ++ -headers specifies an ns_set of extra headers to send to the server when doing the request. + Some options exist that allow to avoid the need to specify headers manually, but headers will always take precedence over options. +
+ +
+ -body is the payload for the request and will be passed as is (useful for many purposes, such as webDav).
+ A convenient way to specify form variables for POST payloads through this argument is passing a string obtained by export_vars -url.
+
+ -gzip_request_p informs the server that we are sending data in gzip format. Data will be automatically compressed. + Notice that not all servers can treat gzipped requests properly, and in such cases response will likely be an error. +
+ ++ -gzip_response_p informs the server that we are capable of receiving gzipped responses. + If server complies to our indication, the result will be automatically decompressed. +
+ ++ -force_ssl_p specifies wether we want to use SSL despite the url being in http:// form. Default behavior is to use SSL on https:// urls only. +
+ ++ -spool_file enables file spooling of the request on the file specified. It is useful when we expect large responses from the server. +
+ ++ -post_redirect decides what happens when we are POSTing and server replies with 301, 302 or 303 redirects. RFC 2616/10.3.2 states that method + should not change when 301 or 302 are returned, and that GET should be used on a 303 response, but most HTTP clients fail in respecting this and switch + to a GET request independently. This options forces this kinds of redirect to conserve their original method. Notice that, as from RFC, a 303 redirect + won't send again any data to the server, as specification says we can assume variables to have been received. +
+ ++ -max_depth is the maximum number of redirects the proc is allowed to follow. Be aware that when following redirects, unless it is a code 303 + redirect, url and POST urlencoded variables will be sent again to the redirected host. Multipart variables won't be sent again. + Sending to the redirected host can be dangerous, if such host is not trusted or uses a lower level of secutiry. The default behavior is to not follow + redirects. +
++ Issue an HTTP request either GET or POST to the url specified. +
+ ++ -headers specifies an ns_set of extra headers to send to the server when doing the request. + Some options exist that allow to avoid the need to specify headers manually, but headers will always take precedence over options. +
+ +
+ -body is the payload for the request and will be passed as is (useful for many purposes, such as webDav).
+ A convenient way to specify form variables for POST payloads through this argument is passing a string obtained by export_vars -url.
+
+ -gzip_request_p informs the server that we are sending data in gzip format. Data will be automatically compressed. + Notice that not all servers can treat gzipped requests properly, and in such cases response will likely be an error. +
+ ++ -gzip_response_p informs the server that we are capable of receiving gzipped responses. + If server complies to our indication, the result will be automatically decompressed. +
+ ++ -force_ssl_p is ignored when using curl http client implementation and is only kept for cross compatibility +
+ ++ -spool_file enables file spooling of the request on the file specified. It is useful when we expect large responses from the server. +
+ ++ -post_redirect decides what happens when we are POSTing and server replies with 301, 302 or 303 redirects. RFC 2616/10.3.2 states that method + should not change when 301 or 302 are returned, and that GET should be used on a 303 response, but most HTTP clients fail in respecting this and switch + to a GET request independently. This options forces this kinds of redirect to conserve their original method. +
+ ++ -max_depth is the maximum number of redirects the proc is allowed to follow. Be aware that when following redirects, unless it is a code 303 + redirect, url and POST urlencoded variables will be sent again to the redirected host. Multipart variables won't be sent again. + Sending to the redirected host can be dangerous, if such host is not trusted or uses a lower level of secutiry. The default behavior is to not follow + redirects. +
++ post is encoded as application/x-www-form-urlencoded. See util_http_file_upload + for file uploads via post (encoded multipart/form-data). +
+ @see util_http_file_upload +} { + if { [catch { + if {[incr depth] > 10} { + return -code error "util_httppost: Recursive redirection: $url" + } + set http [util_httpopen POST $url "" $timeout $http_referer] + set rfd [lindex $http 0] + set wfd [lindex $http 1] + + #headers necesary for a post and the form variables + + _ns_http_puts $timeout $wfd "Content-type: application/x-www-form-urlencoded \r" + _ns_http_puts $timeout $wfd "Content-length: [string length $formvars]\r" + _ns_http_puts $timeout $wfd \r + _ns_http_puts $timeout $wfd "$formvars\r" + flush $wfd + close $wfd + + set rpset [ns_set new [_ns_http_gets $timeout $rfd]] + while 1 { + set line [_ns_http_gets $timeout $rfd] + if { $line eq "" } break + ns_parseheader $rpset $line + } + + set headers $rpset + set response [ns_set name $headers] + set status [lindex $response 1] + if {$status == 302} { + set location [ns_set iget $headers location] + if {$location ne ""} { + ns_set free $headers + close $rfd + return [util_httpget $location {} $timeout $depth] + } + } + set length [ns_set iget $headers content-length] + if { "" eq $length } {set length -1} + set type [ns_set iget $headers content-type] + set_encoding $type $rfd + set err [catch { + while 1 { + set buf [_ns_http_read $timeout $rfd $length] + append page $buf + if { "" eq $buf } break + if {$length > 0} { + incr length -[string length $buf] + if {$length <= 0} break + } + } + } errMsg] + ns_set free $headers + close $rfd + if {$err} { + return -code error -errorinfo $::errorInfo $errMsg + } + } errmgs ] } {return -1} + return $page +} + +# system by Tracy Adams (teadams@arsdigita.com) to permit AOLserver to POST +# to another Web server; sort of like ns_httpget + +ad_proc -deprecated -public util_httpopen { + method + url + {rqset ""} + {timeout 30} + {http_referer ""} +} { + Like ns_httpopen but works for POST as well; called by util_httppost +} { + + if { ![string match "http://*" $url] } { + return -code error "Invalid url \"$url\": _httpopen only supports HTTP" + } + set url [split $url /] + set hp [split [lindex $url 2] :] + set host [lindex $hp 0] + set port [lindex $hp 1] + if { [string match $port ""] } {set port 80} + set uri /[join [lrange $url 3 end] /] + set fds [ns_sockopen -nonblock $host $port] + set rfd [lindex $fds 0] + set wfd [lindex $fds 1] + if { [catch { + _ns_http_puts $timeout $wfd "$method $uri HTTP/1.0\r" + _ns_http_puts $timeout $wfd "Host: $host\r" + if {$rqset ne ""} { + for {set i 0} {$i < [ns_set size $rqset]} {incr i} { + _ns_http_puts $timeout $wfd \ + "[ns_set key $rqset $i]: [ns_set value $rqset $i]\r" + } + } else { + _ns_http_puts $timeout $wfd \ + "Accept: */*\r" + + _ns_http_puts $timeout $wfd "User-Agent: Mozilla/1.01 \[en\] (Win95; I)\r" + _ns_http_puts $timeout $wfd "Referer: $http_referer \r" + } + + } errMsg] } { + #close $wfd + #close $rfd + if { [info exists rpset] } {ns_set free $rpset} + return -1 + } + return [list $rfd $wfd ""] + +} + +ad_proc -deprecated -public util_http_file_upload { -file -data -binary:boolean -filename + -name {-mime_type */*} {-mode formvars} + {-rqset ""} url {formvars {}} {timeout 30} + {depth 10} {http_referer ""} +} { + Implement client-side HTTP file uploads as multipart/form-data as per + RFC 1867. +
+ + Similar to util_httppost, + but enhanced to be able to upload a file as multipart/form-data. + Also useful for posting to forms that require their input to be encoded + as multipart/form-data instead of as + application/x-www-form-urlencoded. + +
+ + The switches -file /path/to/file and -data $raw_data + are mutually exclusive. You can specify one or the other, but not + both. NOTE: it is perfectly valid to not specify either, in which + case no file is uploaded, but form variables are encoded using + multipart/form-data instead of the usual encoding (as + noted aboved). + +
+ + If you specify either -file or -data you + must supply a value for -name, which is + the name of the <INPUT TYPE="file" NAME="..."> form + tag. + +
+ + Specify the -binary switch if the file (or data) needs + to be base-64 encoded. Not all servers seem to be able to handle + this. (For example, http://mol-stage.usps.com/mml.adp, which + expects to receive an XML file doesn't seem to grok any kind of + Content-Transfer-Encoding.) + +
+ + If you specify -file then -filename is optional + (it can be infered from the name of the file). However, if you + specify -data then it is mandatory. + +
+ + If -mime_type is not specified then ns_guesstype + is used to try and find a mime type based on the filename. + If ns_guesstype returns */* the generic value + of application/octet-stream will be used. + +
+ + Any form variables may be specified in one of four formats: +
+ + -rqset specifies an ns_set of extra headers to send to + the server when doing the POST. + +
+ + timeout, depth, and http_referer are optional, and are included + as optional positional variables in the same order they are used + in util_httppost. NOTE: util_http_file_upload does + not (currently) follow any redirects, so depth is superfulous. + + @author Michael A. Cleverly (michael@cleverly.com) + @creation-date 3 September 2002 +} { + + # sanity checks on switches given + if {$mode ni {formvars array ns_set vars}} { + error "Invalid mode \"$mode\"; should be one of: formvars,\ + array, ns_set, vars" + } + + if {[info exists file] && [info exists data]} { + error "Both -file and -data are mutually exclusive; can't use both" + } + + if {[info exists file]} { + if {![file exists $file]} { + error "Error reading file: $file not found" + } + + if {![file readable $file]} { + error "Error reading file: $file permission denied" + } + + set fp [open $file] + fconfigure $fp -translation binary + set data [read $fp] + close $fp + + if {![info exists filename]} { + set filename [file tail $file] + } + + if {$mime_type eq "*/*" || $mime_type eq ""} { + set mime_type [ns_guesstype $file] + } + } + + set boundary [ns_sha1 [list [clock clicks -milliseconds] [clock seconds]]] + set payload {} + + if {[info exists data] && [string length $data]} { + if {![info exists name]} { + error "Cannot upload file without specifing form variable -name" + } + + if {![info exists filename]} { + error "Cannot upload file without specifing -filename" + } + + if {$mime_type eq "*/*" || $mime_type eq ""} { + set mime_type [ns_guesstype $filename] + + if {$mime_type eq "*/*" || $mime_type eq ""} { + set mime_type application/octet-stream + } + } + + if {$binary_p} { + set data [base64::encode base64] + set transfer_encoding base64 + } else { + set transfer_encoding binary + } + + append payload --$boundary \ + \r\n \ + "Content-Disposition: form-data; " \ + "name=\"$name\"; filename=\"$filename\"" \ + \r\n \ + "Content-Type: $mime_type" \ + \r\n \ + "Content-transfer-encoding: $transfer_encoding" \ + \r\n \ + \r\n \ + $data \ + \r\n + } + + + set variables [list] + switch -- $mode { + array { + set variables $formvars + } + + formvars { + foreach formvar [split $formvars &] { + set formvar [split $formvar =] + set key [lindex $formvar 0] + set val [join [lrange $formvar 1 end] =] + lappend variables $key $val + } + } + + ns_set { + for {set i 0} {$i < [ns_set size $formvars]} {incr i} { + set key [ns_set key $formvars $i] + set val [ns_set value $formvars $i] + lappend variables $key $val + } + } + + vars { + foreach key $formvars { + upvar 1 $key val + lappend variables $key $val + } + } + } + + foreach {key val} $variables { + append payload --$boundary \ + \r\n \ + "Content-Disposition: form-data; name=\"$key\"" \ + \r\n \ + \r\n \ + $val \ + \r\n + } + + append payload --$boundary-- \r\n + + if { [catch { + if {[incr depth -1] <= 0} { + return -code error "util_http_file_upload:\ + Recursive redirection: $url" + } + + lassign [util_httpopen POST $url $rqset $timeout $http_referer] rfd wfd + + _ns_http_puts $timeout $wfd \ + "Content-type: multipart/form-data; boundary=$boundary\r" + _ns_http_puts $timeout $wfd "Content-length: [string length $payload]\r" + _ns_http_puts $timeout $wfd \r + _ns_http_puts $timeout $wfd "$payload\r" + flush $wfd + close $wfd + + set rpset [ns_set new [_ns_http_gets $timeout $rfd]] + while 1 { + set line [_ns_http_gets $timeout $rfd] + if { $line eq "" } break + ns_parseheader $rpset $line + } + + set headers $rpset + set response [ns_set name $headers] + set status [lindex $response 1] + set length [ns_set iget $headers content-length] + if { "" eq $length } { set length -1 } + set type [ns_set iget $headers content-type] + set_encoding $type $rfd + set err [catch { + while 1 { + set buf [_ns_http_read $timeout $rfd $length] + append page $buf + if { "" eq $buf } break + if {$length > 0} { + incr length -[string length $buf] + if {$length <= 0} break + } + } + } errMsg] + + ns_set free $headers + close $rfd + + if {$err} { + return -code error -errorinfo $::errorInfo $errMsg + } + } errmsg] } { + if {[info exists wfd] && $wfd in [file channels]} { + close $wfd + } + + if {[info exists rfd] && $rfd in [file channels]} { + close $rfd + } + + set page -1 + } + + return $page +} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 4 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl,v diff -u -N -r1.133.2.38 -r1.133.2.39 --- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 16 Apr 2014 18:38:26 -0000 1.133.2.38 +++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 17 Apr 2014 17:05:40 -0000 1.133.2.39 @@ -1361,135 +1361,6 @@ } } -# system by Tracy Adams (teadams@arsdigita.com) to permit AOLserver to POST -# to another Web server; sort of like ns_httpget - -ad_proc -public util_httpopen { - method - url - {rqset ""} - {timeout 30} - {http_referer ""} -} { - Like ns_httpopen but works for POST as well; called by util_httppost -} { - - if { ![string match "http://*" $url] } { - return -code error "Invalid url \"$url\": _httpopen only supports HTTP" - } - set url [split $url /] - lassign [split [lindex $url 2] :] host port - if { [string match $port ""] } {set port 80} - - set uri /[join [lrange $url 3 end] /] - lassign [ns_sockopen -nonblock $host $port] rfd wfd - - if { [catch { - _ns_http_puts $timeout $wfd "$method $uri HTTP/1.0\r" - _ns_http_puts $timeout $wfd "Host: $host\r" - if {$rqset ne ""} { - for {set i 0} {$i < [ns_set size $rqset]} {incr i} { - _ns_http_puts $timeout $wfd \ - "[ns_set key $rqset $i]: [ns_set value $rqset $i]\r" - } - } else { - _ns_http_puts $timeout $wfd \ - "Accept: */*\r" - - _ns_http_puts $timeout $wfd "User-Agent: Mozilla/1.01 \[en\] (Win95; I)\r" - _ns_http_puts $timeout $wfd "Referer: $http_referer \r" - } - - } errMsg] } { - global errorInfo - #close $wfd - #close $rfd - if { [info exists rpset] } {ns_set free $rpset} - return -1 - } - return [list $rfd $wfd ""] - -} - -# httppost; give it a URL and a string with formvars, and it -# returns the page as a Tcl string -# formvars are the posted variables in the following form: -# arg1=value1&arg2=value2 - -# in the event of an error or timeout, -1 is returned - -ad_proc -public util_httppost { - url - formvars - {timeout 30} - {depth 0} - {http_referer ""} -} { - Returns the result of POSTing to another Web server or -1 if there is an error or timeout. - formvars should be in the form \"arg1=value1&arg2=value2\". -
- post is encoded as application/x-www-form-urlencoded. See util_http_file_upload - for file uploads via post (encoded multipart/form-data). -
- @see util_http_file_upload -} { - if { [catch { - if {[incr depth] > 10} { - return -code error "util_httppost: Recursive redirection: $url" - } - lassign [util_httpopen POST $url "" $timeout $http_referer] rfd wfd - #headers necesary for a post and the form variables - - _ns_http_puts $timeout $wfd "Content-type: application/x-www-form-urlencoded \r" - _ns_http_puts $timeout $wfd "Content-length: [string length $formvars]\r" - _ns_http_puts $timeout $wfd \r - _ns_http_puts $timeout $wfd "$formvars\r" - flush $wfd - close $wfd - - set rpset [ns_set new [_ns_http_gets $timeout $rfd]] - while {1} { - set line [_ns_http_gets $timeout $rfd] - if { $line eq "" } break - ns_parseheader $rpset $line - } - - set headers $rpset - set response [ns_set name $headers] - set status [lindex $response 1] - if {$status == 302} { - set location [ns_set iget $headers location] - if {$location ne ""} { - ns_set free $headers - close $rfd - return [util_httpget $location {} $timeout $depth] - } - } - set length [ns_set iget $headers content-length] - if { "" eq $length } {set length -1} - set type [ns_set iget $headers content-type] - set_encoding $type $rfd - set err [catch { - while {1} { - set buf [_ns_http_read $timeout $rfd $length] - append page $buf - if { "" eq $buf } break - if {$length > 0} { - incr length -[string length $buf] - if {$length <= 0} break - } - } - } errMsg] - ns_set free $headers - close $rfd - if {$err} { - global errorInfo - return -code error -errorinfo $errorInfo $errMsg - } - } errmgs ] } {return -1} - return $page -} - ad_proc -public util_report_successful_library_load { {extra_message ""} } { @@ -1627,95 +1498,6 @@ fconfigure $channel -translation $trl -encoding $enc } -ad_proc -public ad_httpget { - -url - {-headers ""} - {-timeout 30} - {-depth 0} -} { - Just like ns_httpget, but first headers is an ns_set of - headers to send during the fetch. - - ad_httpget also makes use of Conditional GETs (if called with a - Last-Modified header). - - Returns the data in array get form with array elements page status modified. -} { - ns_log debug "Getting {$url} {$headers} {$timeout} {$depth}" - - if {[incr depth] > 10} { - return -code error "ad_httpget: Recursive redirection: $url" - } - - lassign [ns_httpopen GET $url $headers $timeout] rfd wfd headers - - close $wfd - set response [ns_set name $headers] - set status [lindex $response 1] - set last_modified [ns_set iget $headers last-modified] - - if {$status == 302 || $status == 301} { - set location [ns_set iget $headers location] - if {$location ne ""} { - ns_set free $headers - close $rfd - return [ad_httpget -url $location -timeout $timeout -depth $depth] - } - } elseif { $status == 304 } { - # The requested variant has not been modified since the time specified - # A conditional get didn't return anything. return an empty page and - set page {} - - ns_set free $headers - close $rfd - } else { - set length [ns_set iget $headers content-length] - if { $length eq "" } {set length -1} - - set type [ns_set iget $headers content-type] - set_encoding $type $rfd - - set err [catch { - while {1} { - set buf [_ns_http_read $timeout $rfd $length] - append page $buf - if { "" eq $buf } break - if {$length > 0} { - incr length -[string length $buf] - if {$length <= 0} break - } - } - } errMsg] - ns_set free $headers - close $rfd - - if {$err} { - global errorInfo - return -code error -errorinfo $errorInfo $errMsg - } - } - - # order matters here since we depend on page content - # being element 1 in this list in util_httpget - return [list page $page \ - status $status \ - modified $last_modified] -} - -ad_proc -public util_httpget { - url - {headers ""} - {timeout 30} - {depth 0} -} { - util_httpget simply calls ad_httpget which also returns - status and last_modfied - - @see ad_httpget -} { - return [lindex [ad_httpget -url $url -headers $headers -timeout $timeout -depth $depth] 1] -} - # some procs to make it easier to deal with CSV files (reading and writing) # added by philg@mit.edu on October 30, 1999 @@ -3266,276 +3048,6 @@ return 1 } -ad_proc -public util_http_file_upload { - -file - -data - -binary:boolean - -filename - -name - {-mime_type */*} - {-mode formvars} - {-rqset ""} - url - {formvars {}} - {timeout 30} - {depth 10} - {http_referer ""} -} { - Implement client-side HTTP file uploads as multipart/form-data as per - RFC 1867. -
- - Similar to util_httppost, - but enhanced to be able to upload a file as multipart/form-data. - Also useful for posting to forms that require their input to be encoded - as multipart/form-data instead of as - application/x-www-form-urlencoded. - -
- - The switches -file /path/to/file and -data $raw_data - are mutually exclusive. You can specify one or the other, but not - both. NOTE: it is perfectly valid to not specify either, in which - case no file is uploaded, but form variables are encoded using - multipart/form-data instead of the usual encoding (as - noted aboved). - -
- - If you specify either -file or -data you - must supply a value for -name, which is - the name of the <INPUT TYPE="file" NAME="..."> form - tag. - -
- - Specify the -binary switch if the file (or data) needs - to be base-64 encoded. Not all servers seem to be able to handle - this. (For example, http://mol-stage.usps.com/mml.adp, which - expects to receive an XML file doesn't seem to grok any kind of - Content-Transfer-Encoding.) - -
- - If you specify -file then -filename is optional - (it can be infered from the name of the file). However, if you - specify -data then it is mandatory. - -
- - If -mime_type is not specified then ns_guesstype - is used to try and find a mime type based on the filename. - If ns_guesstype returns */* the generic value - of application/octet-stream will be used. - -
- - Any form variables may be specified in one of four formats: -
- - -rqset specifies an ns_set of extra headers to send to - the server when doing the POST. - -
- - timeout, depth, and http_referer are optional, and are included - as optional positional variables in the same order they are used - in util_httppost. NOTE: util_http_file_upload does - not (currently) follow any redirects, so depth is superfulous. - - @author Michael A. Cleverly (michael@cleverly.com) - @creation-date 3 September 2002 -} { - - # sanity checks on switches given - if {$mode ni {formvars array ns_set vars}} { - error "Invalid mode \"$mode\"; should be one of: formvars,\ - array, ns_set, vars" - } - - if {[info exists file] && [info exists data]} { - error "Both -file and -data are mutually exclusive; can't use both" - } - - if {[info exists file]} { - if {![file exists $file]} { - error "Error reading file: $file not found" - } - - if {![file readable $file]} { - error "Error reading file: $file permission denied" - } - - set fp [open $file] - fconfigure $fp -translation binary - set data [read $fp] - close $fp - - if {![info exists filename]} { - set filename [file tail $file] - } - - if {"*/*" eq $mime_type || $mime_type eq ""} { - set mime_type [ns_guesstype $file] - } - } - - set boundary [ns_sha1 [list [clock clicks -milliseconds] [clock seconds]]] - set payload {} - - if {[info exists data] && [string length $data]} { - if {![info exists name]} { - error "Cannot upload file without specifing form variable -name" - } - - if {![info exists filename]} { - error "Cannot upload file without specifing -filename" - } - - if {$mime_type eq "*/*" || $mime_type eq ""} { - set mime_type [ns_guesstype $filename] - - if {$mime_type eq "*/*" || $mime_type eq ""} { - set mime_type application/octet-stream - } - } - - if {$binary_p} { - set data [base64::encode base64] - set transfer_encoding base64 - } else { - set transfer_encoding binary - } - - append payload --$boundary \ - \r\n \ - "Content-Disposition: form-data; " \ - "name=\"$name\"; filename=\"$filename\"" \ - \r\n \ - "Content-Type: $mime_type" \ - \r\n \ - "Content-transfer-encoding: $transfer_encoding" \ - \r\n \ - \r\n \ - $data \ - \r\n - } - - - set variables [list] - switch -- $mode { - array { - set variables $formvars - } - - formvars { - foreach formvar [split $formvars &] { - set formvar [split $formvar =] - set key [lindex $formvar 0] - set val [join [lrange $formvar 1 end] =] - lappend variables $key $val - } - } - - ns_set { - for {set i 0} {$i < [ns_set size $formvars]} {incr i} { - set key [ns_set key $formvars $i] - set val [ns_set value $formvars $i] - lappend variables $key $val - } - } - - vars { - foreach key $formvars { - upvar 1 $key val - lappend variables $key $val - } - } - } - - foreach {key val} $variables { - append payload --$boundary \ - \r\n \ - "Content-Disposition: form-data; name=\"$key\"" \ - \r\n \ - \r\n \ - $val \ - \r\n - } - - append payload --$boundary-- \r\n - - if { [catch { - if {[incr depth -1] <= 0} { - return -code error "util_http_file_upload:\ - Recursive redirection: $url" - } - - lassign [util_httpopen POST $url $rqset $timeout $http_referer] rfd wfd - - _ns_http_puts $timeout $wfd \ - "Content-type: multipart/form-data; boundary=$boundary\r" - _ns_http_puts $timeout $wfd "Content-length: [string length $payload]\r" - _ns_http_puts $timeout $wfd \r - _ns_http_puts $timeout $wfd "$payload\r" - flush $wfd - close $wfd - - set rpset [ns_set new [_ns_http_gets $timeout $rfd]] - while {1} { - set line [_ns_http_gets $timeout $rfd] - if { $line eq "" } break - ns_parseheader $rpset $line - } - - set headers $rpset - set response [ns_set name $headers] - set status [lindex $response 1] - set length [ns_set iget $headers content-length] - if { "" eq $length } { set length -1 } - set type [ns_set iget $headers content-type] - set_encoding $type $rfd - set err [catch { - while {1} { - set buf [_ns_http_read $timeout $rfd $length] - append page $buf - if { "" eq $buf } break - if {$length > 0} { - incr length -[string length $buf] - if {$length <= 0} break - } - } - } errMsg] - - ns_set free $headers - close $rfd - - if {$err} { - global errorInfo - return -code error -errorinfo $errorInfo $errMsg - } - } errmsg] } { - if {[info exists wfd] && $wfd in [file channels]} { - close $wfd - } - - if {[info exists rfd] && $rfd in [file channels]} { - close $rfd - } - - set page -1 - } - - return $page -} - ad_proc -public util_list_of_ns_sets_to_list_of_lists { {-list_of_ns_sets:required} } {