- 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: +ad_library { + + Procs for http client comunication + + @author Antonio Pisano + @creation-date 2014-02-13 +} + + +#################################### +## New HTTP client implementation ## +#################################### + +namespace eval util {} +namespace eval util::http {} + + +ad_proc -private util::http::apis_not_cached { +} { + Obtains implemented apis for http communication +} { + set http [list] + set https [list] + if {[util::which curl] ne ""} { + lappend http "curl" + lappend https "curl" + } + if {[info commands ns_http] ne ""} { + lappend http "native" + } + if {[info commands ns_ssl] ne ""} { + lappend https "native" + } + return [list $http $https] +} + +ad_proc -private util::http::apis { +} { + Obtains implemented apis for http communication +} { + return [util_memoize [list util::http::apis_not_cached]] +} + + +# +## Procs common to both implementations +# + +ad_proc -private util::http::get_channel_settings { + content_type +} { + Helper proc to get encoding based on content_type (From xotcl/tcl/http-client-procs) +} { + # In the following, I realise a IANA/MIME charset resolution + # scheme which is compliant with RFC 3023 which deals with + # treating XML media types properly. + # + # see http://tools.ietf.org/html/rfc3023 + # + # This makes the use of [ns_encodingfortype] obsolete as this + # helper proc does not consider RFC 3023 at all. In the future, + # RFC 3023 support should enter a revised [ns_encodingfortype], + # for now, we fork. + # + # The mappings between Tcl encoding names (as shown by [encoding + # names]) and IANA/MIME charset names (i.e., names and aliases in + # the sense of http://www.iana.org/assignments/character-sets) is + # provided by ... + # + # i. a static, built-in correspondence map: see nsd/encoding.c + # ii. an extensible correspondence map (i.e., the ns/charsets + # section in config.tcl). + # + # For mapping charset to encoding names, I use + # [ns_encodingforcharset]. + # + # Note, there are also alternatives for resolving IANA/MIME + # charset names to Tcl encoding names, however, they all have + # issues (non-extensibility from standard configuration sites, + # incompleteness, redundant thread-local storing, scripted + # implementation): + # 1. tcllib/mime package: ::mime::reversemapencoding() + # 2. tdom: tDOM::IANAEncoding2TclEncoding(); see lib/tdom.tcl + + # + # RFC 3023 support (at least in my reading) demands the following + # resolution order (see also Section 3.6 in RFC 3023), when + # applied along with RFC 2616 (see especially Section 3.7.1 in RFC 2616) + # + # (A) Check for the "charset" parameter on certain (!) media types: + # an explicitly stated, yet optional "charset" parameter is + # permitted for all text/* media subtypes (RFC 2616) and selected + # the XML media type classes listed by RFC 3023 (beyond the text/* + # media type; e.g. "application/xml*", "*/*+xml", etc.). + # + # (B) If the "charset" is omitted, certain default values apply (!): + # + # (B.1) RFC 3023 text/* registrations default to us-ascii (!), + # and not iso-8859-1 (overruling RFC 2616). + # + # (B.2) RFC 3023 application/* and non-text "+xml" registrations + # are to be left untreated (in our context, no encoding + # filtering is to be applied -> "binary") + # + # (B.3) RFC 2616 text/* registration (if not covered by B.1) + # default to iso-8859-1 + # + # (C) If neither A or B apply (e.g., because an invalid charset + # name was given to the charset parameter), we default to + # "binary". This corresponds to the behaviour of + # [ns_encodingfortype]. Also note, that the RFCs 3023 and 2616 do + # not state any procedure when "invalid" charsets etc. are + # identified. I assume, RFC-compliant clients have to ignore them + # which means keep the channel in- and output unfiltered (encoding + # = "binary"). This requires the client of the *HttpRequest* to + # treat the data accordingly. + # + + set enc "" + if {[regexp {^text/.*$|^.*/xml.*$|^.*\+xml.*$} $content_type]} { + # Case (A): Check for an explicitly provided charset parameter + if {[regexp {;\s*charset\s*=([^;]*)} $content_type _ charset]} { + set enc [ns_encodingforcharset [string trim $charset]] + } + # Case (B.1) + if {$enc eq "" && [regexp {^text/xml.*$|text/.*\+xml.*$} $content_type]} { + set enc [ns_encodingforcharset us-ascii] + } + + # Case (B.3) + if {$enc eq "" && [string match "text/*" $content_type]} { + set enc [ns_encodingforcharset iso-8859-1] + } + } + # Cases (C) and (B.2) are covered by the [expr] below. + set enc [expr {$enc eq ""?"binary":$enc}] + + return $enc +} + +ad_proc util::http::get { + -url + {-headers ""} + {-timeout 30} + {-depth 0} + {-max_depth 1} + -force_ssl:boolean + -gzip_response:boolean + {-spool_file ""} + {-preference {native curl}} +} { +
+ 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 GET} + {-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 GET} + {-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: