# ------------------------------------------------------------ # Copyright (c) 2020-2021 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::http::register https 443 ::tls::socket; ::namespace eval ::qw::http {} ::itcl::class ::qw::http::plug { protected variable _scheme "http"; protected variable _host ""; protected variable _port 80; protected variable _path ""; #2.38.5 protected variable _timeout 10000; protected variable _timeout 20000; protected variable _return_code_array; protected variable _content_type "application/x-www-form-urlencoded"; method constructor {sargs} { ::array set _return_code_array { 200 {Data follows} 204 {No Content} 302 {Found} 304 {Not Modified} 400 {Bad Request} 401 {Authorization Required} 403 {Permission denied} 404 {Not Found} 408 {Request Timeout} 411 {Length Required} 419 {Expectation Failed} 500 {Server Internal Error} 501 {Server Busy} 503 {Service Unavailable} 504 {Service Temporarily Unavailable} 505 {Http Version not supported} } ::set Scheme [::sargs::get $sargs .scheme]; ::if {$Scheme ne ""} { ::set _scheme $Scheme; } ::set Host [::sargs::get $sargs .host]; ::if {$Host ne ""} { ::set _host $Host; } ::set Port [::sargs::get $sargs .port]; ::if {$Port ne ""} { ::if {![::string is integer $Port]} { ::qw::error 314120200823152705 "[::namespace current]::[::qw::methodname] - .port is not an integer."; } ::set _port $Port; } ::set Path [::sargs::get $sargs .path]; ::if {$Path ne ""} { ::set _path $Path; } ::set Timeout [::sargs::get $sargs .timeout]; ::if {$Timeout ne ""} { ::if {![::string is integer $Timeout]} { ::qw::error 31412020241230113902 "[::namespace current]::[::qw::methodname] - .timeout is not an integer."; } ::set _timeout $Timeout; } ::set ContentType [::sargs::get $sargs .content_type]; ::if {$ContentType ne ""} { ::set _content_type $ContentType; } } method destructor {} { } method plug_check {} { ::if {$_scheme eq ""} { ::qw::error 314120250120100121 "[::namespace current]::[::qw::methodname] - .scheme not specified."; } ::if {$_host eq ""} { ::qw::error 314120250120100122 "[::namespace current]::[::qw::methodname] - .host not specified."; } ::if {$_port eq ""} { ::set _port 80; } ::if {$_path eq ""} { ::qw::error 314120250120100123 "[::namespace current]::[::qw::methodname] - .path not specified."; } } method remote_call {sargs} { /* { Usage: Create the plug with host, port and path. The path identifies the handler on the server. Can also specifiy timeout. ::set Result [$Plug remote_call .command [::list text_command .a.b value1 .a.c value2 .d value 3 ...]]; All of the sargs are passed to the server handler. Only the .command is mandatory. Returns a value or throws an exception. Foreground means suspended until done (or timeout). */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.0,sargs==$sargs";} plug_check; ::set Command [::sargs::get $sargs .command]; ::if {$Command eq ""} { ::qw::error 20200818100435 "[::namespace current]::[::qw::methodname] - invalid command \"$Command\"."; } # ------------------------------------------------------------ # Add a .tcp envelope to the sargs. # ------------------------------------------------------------ ::sargs::var::set sargs \ .tcp { .command call .priority foreground } \ ; ::switch -- $_content_type { "application/sargs" { ::set Query $sargs; } "application/json" { /* { As a client written in tcl our mother tongue is sargs. The server is capable of receiving sargs from tcl clients or json from JS clients, i.e. browsers. We are capable of sending JS to test the server. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_http_plug,remote_call,3000.0,sargs==$sargs";} ::qw::profile::begin "plug_sargs2json"; ::set Query [::sargs::sargs2json .sargs $sargs]; ::qw::profile::end "plug_sargs2json"; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_http_plug,remote_call,3000.1,query==\n$Query";} } default { ::qw::throw \ .text "[::qw::methodname] - invalid content-type \"$_content_type\"." \ .error_id 314120210121110107 \ ; } } # ------------------------------------------------------------ # Build url with appended encoded query. # ------------------------------------------------------------ /* { We don't need the query in the Url because we use a POST, not a GET. */ } ::set Url [::uri::join scheme $_scheme host $_host port $_port path $_path query ""]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.1,url==$Url";} ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.1,query==$Query";} ::qw::try { # ------------------------------------------------------------ # Make the http call. # ------------------------------------------------------------ ::tls::init -request 0; ::set Headers [::list User-Agent "NV2 $::qw_release"]; ::if {$rwb1_debug} { ::puts "rwb1_debug,command==\n \ ::http::geturl $Url\n \ -query $Query\n \ -timeout $_timeout\n \ -type $_content_type\n \ -headers $Headers\n \ -binary 1\n \ "; } ::set Token [::http::geturl $Url \ -query $Query \ -timeout $_timeout \ -type $_content_type \ -headers $Headers \ -binary 1 \ ]; } catch Exception { # ------------------------------------------------------------ # Manage problem with connection. # ------------------------------------------------------------ /* { A problem occurred trying to make the call, and was not generated by the application on the server. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.2,exception==$Exception";} ::set Exception [::qw::exception::nest .super "Exception occurred making connection." .sub $Exception]; ::qw::throw $Exception; } # ------------------------------------------------------------ # Ensure http token will not leak. # ------------------------------------------------------------ ::qw::finally [::list ::http::cleanup $Token]; ::if {$rwb1_debug} { # ------------------------------------------------------------ # Optional dump http state diagnostics. # ------------------------------------------------------------ ::upvar #0 $Token State; ::puts "----------------------------------------------------------------"; ::foreach Name [::lsort [::array names State]] { ::puts "http::geturl,State($Name)==$State($Name)"; } ::puts "----------------------------------------------------------------"; } ::set Status [::http::status $Token]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.3,Status==$Status";} ::if {$Status eq "ok"} { # ------------------------------------------------------------ # Call succeeded but could be a result or an exception. # ------------------------------------------------------------ /* { The returned content should contain .result or .exception. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.4,Token==$Token";} ::set Content [::http::data $Token]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.4.0,Content==\n$Content";} ::switch -- $_content_type { "application/sargs" { } "application/json" { ::if {$rwb1_debug} {::puts "rwb1_debug,json2sargs,4000.0,Content==\n$Content";} ::qw::profile::begin "plug_json2sargs"; ::set Content [::sargs::json2sargs .json $Content]; ::qw::profile::end "plug_json2sargs"; ::if {$rwb1_debug} {::puts "rwb1_debug,json2sargs,4000.1,Content==\n$Content";} } } ::if {[::sargs::exists $Content .result]} { ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.6.0";} # ------------------------------------------------------------ # Call returned a .result result. We return that result. # ------------------------------------------------------------ ::set Result [::sargs::get $Content .result]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.6.1,Result==$Result";} ::return $Result; } ::if {[::sargs::exists $Content .exception]} { # ------------------------------------------------------------ # Call returned an exception. We extract and throw the exception. # ------------------------------------------------------------ ::set Exception [::sargs::get $Content .exception]; # ::set Exception [::sargs::get $Content .exception]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.7,exception==$Exception";} ::qw::throw $Exception; } ::qw::error 314120200820180812 "[::namespace current]::[::qw::methodname] - expected result or exception, content==\n$Content"; } ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.8";} ::if {$Status eq "timeout"} { # ------------------------------------------------------------ # Call timed out. Throw a timeout exception. # ------------------------------------------------------------ ::set Exception "Call timed out,_path==$_path,command==[::sargs::get $sargs .command]"; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.9,exception==$Exception";} ::qw::throw $Exception; } # ------------------------------------------------------------ # General error. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.10";} ::set ReturnCode [::http::ncode $Token]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.11";} ::set ReturnText ""; ::if {[::info exists _return_code_array($ReturnCode)]} { ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.12";} ::set ReturnText $_return_code_array($ReturnCode); ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.13";} } ::if {$rwb1_debug} { ::upvar Token State; ::foreach name [::lsort [::array names State]] { ::puts "rwb1_debug,9876.0,State($Name)==$State($Name)"; } ::puts "rwb1_debug,remote_call,1000.11,ReturnText==$ReturnText"; } ::qw::error 314120200820180942 "[::namespace current]::[::qw::methodname] ReturnCode==\"$ReturnCode\",ReturnText==\"$ReturnText\""; } method synch_send {sargs} { /* { Usage: Create the plug with host, port and path. The path identifies the handler on the server. Can also specifiy timeout. ::set Result [$Plug remote_call .command [::list text_command .a.b value1 .a.c value2 .d value 3 ...]]; All of the sargs are passed on the server handler. Only the .command is mandatory. Returns a value or throws an exception. Foreground means suspended until done (or timeout). */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.0,sargs==$sargs";} # plug_check; ::set Path [::sargs::get $sargs .path]; ::if {$Path eq ""} { ::qw::error 20201124150917 "[::namespace current]::[::qw::methodname] - invalid path \"$Path\"."; } ::if {$Path ne ""} { ::set _path $Path; } ::set Query [::sargs::get $sargs .query]; ::if {$Query ne ""} { ::if {0} { ::set Query [::qw::http::formatQuery $Query]; } ::if {1} { ::set Query [::eval ::qw::http::formatQuery $Query]; } } # ------------------------------------------------------------ # Build url with appended encoded query. # ------------------------------------------------------------ # ::set Url [::uri::join scheme http host $_host port $_port path $_path query $Query]; ::set Url [::uri::join scheme $_scheme host $_host port $_port path $_path query ""]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.1,url==$Url";} ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.1,query==$Query";} ::qw::try { # ------------------------------------------------------------ # Make the http call. # ------------------------------------------------------------ ::tls::init -request 0; ::set Token [::http::geturl $Url \ -query $Query \ -timeout $_timeout \ -type "application/x-www-form-urlencoded" \ -headers [::list User-Agent "NV2 $::qw_release"] \ -binary 1 \ ]; } catch Exception { # ------------------------------------------------------------ # Manage problem with connection. # ------------------------------------------------------------ /* { A problem occurred trying to make the call, and was not generated by the application on the server. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.2,exception==$Exception";} ::set Exception [::qw::exception::nest .super "Exception occurred making connection." .sub $Exception]; ::qw::throw $Exception; } # ------------------------------------------------------------ # Ensure http token will not leak. # ------------------------------------------------------------ ::qw::finally [::list ::http::cleanup $Token]; ::if {$rwb1_debug} { # ------------------------------------------------------------ # Optional dump http state diagnostics. # ------------------------------------------------------------ ::upvar #0 $Token State; ::puts "----------------------------------------------------------------"; ::foreach Name [::lsort [::array names State]] { ::puts "http::geturl,State($Name)==$State($Name)"; } ::puts "----------------------------------------------------------------"; } ::set Status [::http::status $Token]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.3,Status==$Status";} ::if {$Status eq "ok"} { # ------------------------------------------------------------ # Call succeeded but could a regular result or exception. # ------------------------------------------------------------ /* { The returned content should contain .result or .exception. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.4,Token==$Token";} ::set Content [::http::data $Token]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.4.0,Content==\n$Content";} ::return $Content; } ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.8";} ::if {$Status eq "timeout"} { # ------------------------------------------------------------ # Call timed out. Throw a timeout exception. # ------------------------------------------------------------ ::set Exception "Call timed out,_path==$_path,command==[::sargs::get $sargs .command]"; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.9,exception==$Exception";} ::qw::throw $Exception; } # ------------------------------------------------------------ # General error. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.10";} ::set ReturnCode [::http::ncode $Token]; ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.11";} ::set ReturnText ""; ::if {[::info exists _return_code_array($ReturnCode)]} { ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.12";} ::set ReturnText $_return_code_array($ReturnCode); ::if {$rwb1_debug} {::puts "rwb1_debug,remote_call,1000.13";} } ::if {$rwb1_debug} { ::upvar Token State; ::foreach name [::lsort [::array names State]] { ::puts "rwb1_debug,9876.0,State($Name)==$State($Name)"; } ::puts "rwb1_debug,remote_call,1000.11,ReturnText==$ReturnText"; } ::qw::error 314120201124151344 "[::namespace current]::[::qw::methodname] ReturnCode==\"$ReturnCode\",ReturnText==\"$ReturnText\""; } }