Index: openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl,v diff -u -N -r1.8 -r1.9 --- openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 25 Mar 2008 13:17:57 -0000 1.8 +++ openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 4 Jun 2008 07:21:02 -0000 1.9 @@ -1,5 +1,7 @@ ad_library { - XOTcl implementation for synchronous and asynchronous HTTP and HTTPs requests + + XOTcl implementation for synchronous and asynchronous + HTTP and HTTPS requests @author Gustaf Neumann, Stefan Sobernig @creation-date 2007-10-05 @@ -9,10 +11,11 @@ namespace eval ::xo { # # Defined classes - # 1) HttpRequest - # 2) AsyncHttpRequest - # 3) HttpRequestTrace (mixin class) - # 4) Tls (mixin class, applicable to various protocols) + # 1) HttpCore (common base class) + # 2) HttpRequest (for blocking requests + timeout support) + # 3) AsyncHttpRequest (for non-blocking requests + timeout support) + # 4) HttpRequestTrace (mixin class) + # 5) Tls (mixin class, applicable to various protocols) # ###################### # @@ -38,9 +41,27 @@ # set r [::xo::HttpRequest new \ # -url http://yourhost.yourdomain/yourpath \ # -post_data [export_vars {var1 var2}] \ - # -content_type application/x-www-form-urlencoded \ - # ] + # -content_type application/x-www-form-urlencoded] # + # More recently, we added timeout support for blocking http + # requests. By passing a timeout parameter, you gain control + # on the total roundtrip time (in milliseconds, ms): + # + # set r [::xo::HttpRequest new \ + # -url http://www.openacs.org/ \ + # -timeout 1500] + # + # Please, make sure that you use a recent distribution of tclthread + # ( > 2.6.5 ) to have the blocking-timeout feature working + # safely. This newly introduced feature makes use of advanced thread + # synchronisation offered by tclthread that needed to be fixed in + # tclthread <= 2.6.5. At the time of this writing, there was no + # post-2.6.5 release of tclthread, hence, you are required to obtain a + # CVS snapshot, dating at least 2008-05-23. E.g.: + # + # cvs -z3 -d:pserver:anonymous@tcl.cvs.sourceforge.net:/cvsroot/tcl co \ + # -D 20080523 -d thread2.6.5~20080523 thread + # # Provided that the Tcl module tls (see e.g. http://tls.sourceforge.net/) # is available and can be loaded via "package require tls" into # the aolserver, you can use both TLS/SSL secured or unsecured requests @@ -53,7 +74,7 @@ # # 2 AsyncHttpRequest # - # AsyncHttpRequest is a subclass for HttpRequest implementing + # AsyncHttpRequest is a subclass for HttpCore implementing # asynchronous HTTP requests without vwait (vwait causes # stalls on aolserver). AsyncHttpRequest requires to provide a listener # or callback object that will be notified upon success or failure of @@ -96,40 +117,109 @@ # # 3 HttpRequestTrace # - # HttpRequestTrace can be used to trace the one or all requests. + # HttpRequestTrace can be used to trace one or all requests. # If activated, the class writes protocol data into # /tmp/req-. # # Use # - # ::xo::HttpRequest instmixin add ::xo::HttpRequestTrace + # ::xo::HttpCore instmixin add ::xo::HttpRequestTrace # # to activate trace for all requests, # or mixin the class into a single request to trace it. # - Class create HttpRequest \ - -parameter { - {host} - {protocol http} - {port} - {path /} - {url} - {post_data ""} - {content_type text/plain} - {request_manager} - {request_header_fields {}} - {user_agent xohttp/0.1} + Class create HttpCore \ + -slots { + Attribute host + Attribute protocol -default "http" + Attribute port + Attribute path -default "/" + Attribute url + Attribute post_data -default "" + Attribute content_type -default "text/plain" + Attribute request_header_fields -default {} + Attribute user_agent -default "xohttp/0.2" } - HttpRequest instproc set_default_port {protocol} { + # Provide for mapping from HTTP charset encoding labels + # to Tcl-specific ones + + HttpCore array set http_to_tcl_encodings { + iso-2022-jp iso2022-jp + iso-2022-kr iso2022-kr + iso-8859-1 iso8859-1 + iso-8859-2 iso8859-2 + iso-8859-3 iso8859-3 + iso-8859-4 iso8859-4 + iso-8859-5 iso8859-5 + iso-8859-6 iso8859-6 + iso-8859-7 iso8859-7 + iso-8859-8 iso8859-8 + iso-8859-9 iso8859-9 + korean ksc5601 + ksc_5601 ksc5601 + mac macRoman + mac-centeuro macCentEuro + mac-centraleupore macCentEuro + mac-croatian macCroatian + mac-cyrillic macCyrillic + mac-greek macGreek + mac-iceland macIceland + mac-japan macJapan + mac-roman macRoman + mac-romania macRomania + mac-thai macThai + mac-turkish macTurkish + mac-ukraine macUkraine + maccenteuro macCentEuro + maccentraleupore macCentEuro + maccroatian macCroatian + maccyrillic macCyrillic + macgreek macGreek + maciceland macIceland + macintosh macRoman + macjapan macJapan + macroman macRoman + macromania macRomania + macthai macThai + macturkish macTurkish + macukraine macUkraine + shift_jis shiftjis + us-ascii ascii + windows-1250 cp1250 + windows-1251 cp1251 + windows-1252 cp1252 + windows-1253 cp1253 + windows-1254 cp1254 + windows-1255 cp1255 + windows-1256 cp1256 + windows-1257 cp1257 + windows-1258 cp1258 + x-mac macRoman + x-mac-centeuro macCentEuro + x-mac-centraleupore macCentEuro + x-mac-croatian macCroatian + x-mac-cyrillic macCyrillic + x-mac-greek macGreek + x-mac-iceland macIceland + x-mac-japan macJapan + x-mac-roman macRoman + x-mac-romania macRomania + x-mac-thai macThai + x-mac-turkish macTurkish + x-mac-ukraine macUkraine + x-macintosh macRoman + } + + HttpCore instproc set_default_port {protocol} { switch $protocol { http {my set port 80} https {my set port 443} } } - HttpRequest instproc parse_url {} { + HttpCore instproc parse_url {} { my instvar protocol url host port path if {[regexp {^(http|https)://([^/]+)(/.*)?$} $url _ protocol host path]} { # Be friendly and allow strictly speaking invalid urls @@ -142,21 +232,29 @@ } } - HttpRequest instproc open_connection {} { + HttpCore instproc open_connection {} { my instvar host port S - set S [socket $host $port] + set S [socket -async $host $port] } - HttpRequest instproc set_encoding { + HttpCore instproc set_encoding { {-text_translation {auto binary}} content_type } { # - # for text, use translation with optional encodings, else set translation binary + # for text, use translation with optional encodings, + # else set translation binary # if {[string match "text/*" $content_type]} { if {[regexp {charset=([^ ]+)$} $content_type _ encoding]} { - fconfigure [my set S] -translation $text_translation -encoding [string tolower $encoding] + [self class] instvar http_to_tcl_encodings + set enc [string tolower $encoding] + if {[info exists http_to_tcl_encodings($enc)]} { + set enc $http_to_tcl_encodings($enc) + } + fconfigure [my set S] \ + -translation $text_translation \ + -encoding $enc } else { fconfigure [my set S] -translation $text_translation } @@ -165,7 +263,7 @@ } } - HttpRequest instproc init {} { + HttpCore instproc init {} { my instvar S post_data host port protocol my destroy_on_cleanup my set meta [list] @@ -193,6 +291,10 @@ my cancel "error during open connection via $protocol to $host $port: $err" return } + } + + HttpCore instproc write_to_socket {} { + my instvar S post_data host if {[catch { set method [expr {$post_data eq "" ? "GET" : "POST"}] puts $S "$method [my path] HTTP/1.0" @@ -206,18 +308,18 @@ } my $method } err]} { - my cancel "error send $host $port: $err" + my cancel "error send $host [my port]: $err" return } } - HttpRequest instproc GET {} { + HttpCore instproc GET {} { my instvar S puts $S "" my query_done } - HttpRequest instproc POST {} { + HttpCore instproc POST {} { my instvar S post_data puts $S "Content-Length: [string length $post_data]" puts $S "Content-Type: [my content_type]" @@ -227,40 +329,38 @@ puts -nonewline $S $post_data my query_done } - HttpRequest instproc query_done {} { + HttpCore instproc query_done {} { my instvar S flush $S my received_first_line } - HttpRequest instproc notify {method arg} { - if {[my exists request_manager]} { - [my request_manager] $method $arg [self] - } - } - HttpRequest instproc cancel {reason} { - my log "--- $reason" + + HttpCore instproc close {} { + my debug "--- closing socket" catch {close [my set S]} - my notify done $reason } - HttpRequest instproc finish {} { - catch {close [my set S]} - my log "--- [my host] [my port] [my path] has finished" - my notify deliver [my set data] + HttpCore instproc cancel {reason} { + my debug "--- $reason" + my close } - HttpRequest instproc getLine {var} { + + HttpCore instproc finish {} { + my close + my debug "--- [my host] [my port] [my path] has finished" + } + HttpCore instproc getLine {var} { my upvar $var response my instvar S set n [gets $S response] if {[eof $S]} { - my log "--premature eof" + my debug "--premature eof" return -2 } - if {$n == -1} {my log "--input pending, no full line"; return -1} - #my log "got $response" + if {$n == -1} {my debug "--input pending, no full line"; return -1} return $n } - HttpRequest instproc received_first_line {} { + HttpCore instproc received_first_line {} { my instvar S status_code fconfigure $S -translation crlf set n [my getLine response] @@ -272,22 +372,22 @@ responseHttpVersion status_code]} { my received_first_line_done } else { - my log "--unexpected response '$response'" + my debug "--unexpected response '$response'" my cancel unexpected-response } } - HttpRequest instproc received_first_line_done {} { + HttpCore instproc received_first_line_done {} { my header } - HttpRequest instproc header {} { + HttpCore instproc header {} { while {1} { set n [my getLine response] switch -exact -- $n { -2 {my cancel premature-eof; return} -1 {continue} 0 {break} default { - #my log "--header $response" + #my debug "--header $response" if {[regexp -nocase {^content-length:(.+)$} $response _ length]} { my set content_length [string trim $length] } elseif {[regexp -nocase {^content-type:(.+)$} $response _ type]} { @@ -301,8 +401,9 @@ } my received_header_done } - HttpRequest instproc received_header_done {} { - # we have received the header, including potentially the content_type of the returned data + HttpCore instproc received_header_done {} { + # we have received the header, including potentially the + # content_type of the returned data my set_encoding [my content_type] if {[my exists content_length]} { my set data [read [my set S] [my set content_length]] @@ -311,30 +412,121 @@ } } + HttpCore instproc set_status {key newStatus {value ""}} { + nsv_set bgdelivery $key [list $newStatus $value] + } + + HttpCore instproc unset_status {key} { + nsv_unset bgdelivery $key + } + + HttpCore instproc get_status {key} { + return [lindex [nsv_get bgdelivery $key] 0] + } + + HttpCore instproc get_value_for_status {key} { + return [lindex [nsv_get bgdelivery $key] 1] + } + + + # - # Asynchronous requests + # Synchronous (blocking) requests # - Class AsyncHttpRequest -superclass HttpRequest -parameter { - {timeout 10000} + Class HttpRequest -superclass HttpCore -slots { + Attribute timeout -type integer } + + HttpRequest instproc init {} { + if {[my exists timeout] && [my timeout] != 0} { + # create a cond and mutex + set cond [thread::cond create] + set mutex [thread::mutex create] + + thread::mutex lock $mutex + + # start the asynchronous request + set req [bgdelivery do -async ::xo::AsyncHttpRequest new \ + -mixin ::xo::AsyncHttpRequest::RequestManager \ + -url [my url] \ + -timeout [my timeout] \ + -post_data [my post_data] \ + -request_header_fields [my request_header_fields] \ + -content_type [my content_type] \ + -user_agent [my user_agent] \ + -condition $cond] + + my set_status $cond COND_WAIT_TIMEOUT + thread::cond wait $cond $mutex [my timeout] + + set status [my get_status $cond] + my debug "status after cond-wait $status" + + if {$status eq "COND_WAIT_TIMEOUT"} { + my set_status $cond "COND_WAIT_CANCELLED" + } + set status_value [my get_value_for_status $cond] + if {$status eq "JOB_COMPLETED"} { + my set data $status_value + } else { + set msg "Timeout-constraint, blocking HTTP request failed. Reason: '$status'" + if {$status_value ne ""} { + append msg " ($status_value)" + } + error $msg + } + thread::cond destroy $cond + thread::mutex unlock $mutex + thread::mutex destroy $mutex + my unset_status $cond + } else { + next;# HttpCore->init() + my write_to_socket + } + } + + # + # Asynchronous (non-blocking) requests + # + + Class AsyncHttpRequest -superclass HttpCore -slots { + Attribute timeout -type integer -default 10000 ;# 10 seconds + Attribute request_manager + } AsyncHttpRequest instproc init {} { + my debug "--- setting socket timeout: [my set timeout]" my set to_identifier [after [my set timeout] [self] cancel timeout] next + fileevent [my set S] writable [list [self] write_to_socket] } + AsyncHttpRequest instproc write_to_socket {} { + # remove fileevent handler explicitly + fileevent [my set S] writable {} + next + } AsyncHttpRequest instproc POST {} { if {[my exists S]} {fconfigure [my set S] -blocking false} next } + AsyncHttpRequest instproc notify {method arg} { + if {[my exists request_manager]} { + [my request_manager] $method $arg [self] + } + } AsyncHttpRequest instproc cancel {reason} { if {$reason ne "timeout"} { after cancel [my set to_identifier] } next + my debug "--- cancelled for $reason" + my notify done $reason } AsyncHttpRequest instproc finish {} { after cancel [my set to_identifier] next + my debug "--- deliver data [my set data]" + my notify deliver [my set data] } AsyncHttpRequest instproc query_done {} { my instvar S @@ -346,7 +538,8 @@ fileevent [my set S] readable [list [self] header] } AsyncHttpRequest instproc received_header_done {} { - # we have received the header, including potentially the content_type of the returned data + # we have received the header, including potentially the + # content_type of the returned data my set_encoding [my content_type] fileevent [my set S] readable [list [self] received_data] } @@ -357,10 +550,48 @@ } else { set block [read $S] my append data $block - #my log "reveived [string length $block] bytes" + #my debug "reveived [string length $block] bytes" } } + # + # Mixin class, used to turn instances of + # AsyncHttpRequest into result callbacks + # in the scope of bgdelivery, realising + # the blocking-timeout feature ... + # + + Class create AsyncHttpRequest::RequestManager \ + -slots { + Attribute condition + } \ + -instproc finalize {obj status value} { + # set the result and do the notify + my instvar condition + if {[my get_status $condition] eq "COND_WAIT_TIMEOUT"} { + my set_status $condition $status $value + catch {thread::cond notify $condition} + $obj debug "--- destroying after finish" + $obj destroy + } + } \ + -instproc deliver {payload obj} { + my finalize $obj "JOB_COMPLETED" $payload + } \ + -instproc done {reason obj} { + my finalize $obj "JOB_FAILED" $reason + } \ + -instproc init {} { + # register request object as its own request_manager + my request_manager [self] + next + } \ + -instproc cancel {reason} { + next + my debug "--- destroying after cancel" + my destroy + } + # # TLS/SSL support # @@ -430,5 +661,5 @@ # To activate trace for all requests, uncomment the following line. # To trace a single request, mixin ::xo::HttpRequestTrace into the request. # - # HttpRequest instmixin add ::xo::HttpRequestTrace + # HttpCore instmixin add ::xo::HttpRequestTrace }