# ------------------------------------------------------------ # Copyright (c) 2017-2022 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::itcl::class ::qw::babyship { protected variable _mothership_url ""; protected variable _babyship_open_message_log_path ""; protected variable _babyship_nic ""; protected variable _babyship_unique_message_id 0; protected variable _babyship_boot_clock_seconds ""; # protected variable _babyship_open_message_queue [::sargs]; # open messages held in memory protected variable _flush_nv2_open_message_log_interval [::expr {15*60*1000}]; # milliseconds (15 minutes) protected variable _babyship_mutex_is_enabled 1; # 2.38.5 - turned this flag on method set_default_url {sargs} { ::set rwb1_debug 0; ::if {[::string first "benn" [::info hostname]]==0} { /* { If we're on a benn computer always send to benn_2020. The only problem is we have to use an IP when on benn-2025, i.e. the benn linux computer. */ } ::switch -glob -- [::string tolower [::info hostname]] { "benn-2025" { /* { We can't use the domain name. We don't know why. But the ip works so we are using it. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,babyship,main,1000.0.0";} ::set _mothership_url "https://192.168.0.215:80"; # original ::set _mothership_url "https://192.168.0.141"; # ipconfig current # ::set _mothership_url "https://benn_2020"; ::return; } } ::set _mothership_url "https://benn_2020"; ::return; } /* { If we're not on a benn machine then it all depends on whether we're a release of not. Austin will get a release for user machines and a non-release for internal testing. */ } ::if {!$::qw::control(is_release)} { ::set _mothership_url "https://benn_2020"; ::return; } ::set _mothership_url "https://ms.newviews.com"; } method main {sargs} { /* { We open the open messages file and send the messages, if any, to the mothership. The open file accumulates whenever messages sent to the mothership are not acknowledged. For example, messages might accumulate if the babyship has no access to the internet, or if the mothership is not running. 2.33.2 - added .message_list and .response_list 2.34.7a - if is release we send to the real mothership - if not a release then we don't send unless .force 1 - eliminated in 2.35.5 - .force not necessary. babyship is always enabled - just ends to local mothership is not a release 2.35.5 - if not a release then we send to benn_2020 mothership */ } ::set rwb1_debug 0; set_default_url $sargs; ::http::register https 443 [::list ::tls::socket -tls1 1]; ::if {$rwb1_debug} {::puts "rwb1_debug,babyship_main,1000.0,_mothership_url==$_mothership_url";} ::set _babyship_boot_clock_seconds [::clock seconds]; ::switch $::tcl_platform(platform) { "windows" { # nics have a "-" separator on windows ::set _babyship_nic [::string map [::list "-" ""] [[::qw::system] cpp_nic_get]]; } "unix" { # nics have a ":" separator on linux ::set _babyship_nic [::string map [::list ":" ""] [[::qw::system] cpp_nic_get]]; } } ::if {$rwb1_debug} {::puts "rwb1_debug,babyship_main,1000.1,_babyship_nic==$_babyship_nic";} ::set _babyship_open_message_log_path [::file join $::qw_program_folder nv2_open_message.log]; ::if {$rwb1_debug} {::puts "rwb1_debug,babyship_main,1000.98";} flush_nv2_open_message_log_background; ::if {$rwb1_debug} {::puts "rwb1_debug,babyship_main,1000.99";} } method generate_babyship_message_id {} { /* { 2.34.5 Eliminated the nic from babyship message id. Rather than depend on the nic, we use a counter and a uuid to make it unique. This will also try to sort the messages in the order produced. Note that we left pad the counter with zeros to make it fixed length. We also eliminate the hyphens from the uuid because hyphens are not valid sargs field characters. */ } ::if {0} { ::set Result [::clock seconds]; ::append Result "[::string repeat 0 [::expr {8-[::string length $_babyship_unique_message_id]}]]$_babyship_unique_message_id"; ::incr _babyship_unique_message_id 1; ::append Result [::string map [::list "-" ""] [::uuid::uuid generate]]; ::return $Result; } # 2.34.5 still using old method, new method is above. ::set Result "${_babyship_nic}_[::pid]_${_babyship_boot_clock_seconds}_${_babyship_unique_message_id}"; ::incr _babyship_unique_message_id 1; ::return $Result; } method asynch_post_to_mothership {sargs} { /* { Usage: ::qw::babyship::singleton asynch_post_to_mothership \ .message $Message \ ?.callback xxx? \ ?.mothership_url xxx? \ ; Returns empty or returns exception on failure so caller can take appropriate action. We don't throw because some calls really don't care. The open_message_flush does care because it breaks when a problem occurs. The .message is arbitrary in general. For example, connection_statistics is the "command" which is hit on the mothership side but it has it's own protocol where the data contains the sub-sommand and it's arguments. There may or may not be a callback. If the callback is not specified then a default is provided. If the callback is supplied but is empty, then there is no callback. The .babyship.message_id is normally not supplied and is generated. But it is supplied if we are re-sending. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.0,sargs==\n[::sargs::format $sargs]";} ::switch -glob -- $::qw::control(app_name) { "app_name_message_database*" { /* { If the message_database posts to itself we could face potential freezes. If the message database is in trouble we accumulate the messages it is intending to send in a special file. Note we could get trickey here. We could send the message from the local mdb to the general mdb and vice versa. */ } ::if {$::qw::verbose(exception)} { # 2.38.4 ::puts "app_name $::qw::control(app_name) tried to send a message with sargs:\n[::sargs::format $sargs]"; } ::return; } } ::set Message [::sargs::get $sargs .message]; /* { qw registration customer_support_registration processor tcl_platform tcl tk memory screen */ } ::if {[::sargs::boolean_get $sargs .post_raw_message]} { ::set BabyshipMessageId [::sargs::get $Message .babyship.message_id]; ::if {$BabyshipMessageId eq ""} { ::qw::bug 314120250623111639 "Invalid BabyshipMessageId \"$BabyshipMessageId\"."; } } ::if {![::sargs::boolean_get $sargs .post_raw_message]} { /* { 2.38.5 - importing open message logs from c0x computers. Needed to process messages "as is" instead of adding header information to them. */ } # ------------------------------------------------------------ # Add boilerplate info fields to each message. # ------------------------------------------------------------ ::set FieldList [::list]; ::lappend FieldList qw; ::lappend FieldList registration; ::lappend FieldList customer_support_registration; ::lappend FieldList processor; /* { eliminated these - useless info inflating message sizes ::lappend FieldList tcl_platform; ::lappend FieldList tcl; ::lappend FieldList tk; ::lappend FieldList memory; ::lappend FieldList screen; */ } ::sargs::var::set Message .computer_information [::qw::computer_information .field_list $FieldList]; # ------------------------------------------------------------ # Add .babyship field, including unique .babyship.message_id. # ------------------------------------------------------------ /* { Comment on the Mothership Url ----------------------------- Prior to 2.33.2 we stored the mothership url in each message. Therefore we could write each message to a different mothership url. When we flushed the message queue, each message was sent independently and could potentially be sent to a different url. With release 2.33.2 we flush the entire message queue in one send operation so they now all have to go to the same mothership url. Doesn't seem to be a problem and the ability was never used anyway. So also eliminated .babyship.mothership_url field from the message. Mothership and Babyship message_ids ----------------------------------- A unique mothership_message is easy because we only have one mothership process and it has a database to generate the unique id. The babyship_message_id is generated on any number of computers, perhaps also from multiple processes on the same computer. We want a "globally" unique message id. The babyship_nic should separate the message id from those on other machines. But we could be running multiple programs on the same computer with the same nic, so we also put the process id in the babyship_id. We also add the clock and a counter. That should do it. */ } ::if {$rwb1_debug} { ::puts "rwb1_debug,babyship,2000.0,_babyship_nic==$_babyship_nic"; ::puts "rwb1_debug,babyship,2000.0,::pid==[::pid]"; ::puts "rwb1_debug,babyship,2000.0,_babyship_unique_message_id==$_babyship_unique_message_id"; } #2.34.5 ::set BabyshipMessageId "${_babyship_nic}_[::pid]_${_babyship_boot_clock_seconds}_${_babyship_unique_message_id}"; ::set BabyshipMessageId [generate_babyship_message_id]; ::sargs::var::set Message .babyship.message_id $BabyshipMessageId; ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.3,BabyshipMessageId==$BabyshipMessageId";} ::set BabyshipSeconds [::clock seconds]; ::set BabyshipYMDHMS "[::clock format $BabyshipSeconds -format %Y%m%d%H%M%S]"; ::sargs::var::set Message .babyship.clock_seconds $BabyshipSeconds; ::sargs::var::set Message .babyship.ymdhms $BabyshipYMDHMS; #::sargs::var::set Message .babyship.mothership_url $_mothership_url; } # ------------------------------------------------------------ # Add message to nv2_open_message.log # ------------------------------------------------------------ ::if {$_babyship_mutex_is_enabled} { ::if {![::qw::mutex_manager mutex_is_locked .mutex_name $_babyship_open_message_log_path]} { ::qw::mutex_manager mutex_lock .mutex_name $_babyship_open_message_log_path .lock_caller "[::qw::methodname]"; ::qw::finally [::list ::qw::mutex_manager mutex_unlock .mutex_name $_babyship_open_message_log_path .unlock_caller "[::qw::methodname]"]; } } ::sargs::file::set $_babyship_open_message_log_path .$BabyshipMessageId $Message # ------------------------------------------------------------ # Can override _mothership_url. For example, used while testing to avoid recompiles. # ------------------------------------------------------------ ::set MothershipUrl $_mothership_url; ::if {[::sargs::get $sargs .mothership_url] ne ""} { ::set MothershipUrl [::sargs::get $sargs .mothership_url]; } # ------------------------------------------------------------ # Format the message as a query and post it. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.4,babyship_message==\n[::sargs::format $Message]";} ::if {$::qw::control(babyship_send_original)} { ::set Query [::qw::http::formatQuery mothership_message $Message]; } else { ::set Query [::http::formatQuery mothership_message $Message]; } ::qw::try { ::if {$rwb1_debug} { ::set rwb1_debug_seconds [::clock seconds]; ::set rwb1_debug_milliseconds [::clock clicks -milliseconds]; } ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.6.0";} ::switch -- $::tcl_platform(platform) { "windows" { ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.6.1,this==$this";} ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.6.2,MothershipUrl==$MothershipUrl";} ::set Token [::http::geturl "$MothershipUrl/asynch_post_to_mothership" \ -query $Query \ -type "application/x-www-form-urlencoded" \ -command [::list $this asynch_post_to_mothership_callback] \ -timeout 5000 \ ]; ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.6.3";} } "unix" { /* { It was hard to get ::http::geturl working on unix. Added -headers below to work around the problem. The net said that maybe tcl 86 zlib is not working properly. Also had to use ip instead of domain name. */ } # 2.38.5 added tineout ::set Token [::http::geturl "$MothershipUrl/asynch_post_to_mothership" \ -query $Query \ -type "application/x-www-form-urlencoded" \ -command [::list $this asynch_post_to_mothership_callback] \ -headers [::list Accept-Encoding ""] \ -timeout 5000 \ ]; } } ::if {$rwb1_debug} { debug_dump $Token babyship_posted_entry; } ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.7,seconds==[::expr {[::clock seconds]-$rwb1_debug_seconds}],milliseconds==[::expr {[::clock clicks -milliseconds]-$rwb1_debug_milliseconds}]";} } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.8,seconds==[::expr {[::clock seconds]-$rwb1_debug_seconds}],milliseconds==[::expr {[::clock clicks -milliseconds]-$rwb1_debug_milliseconds}]";} ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.9,exception==$Exception";} #2.32.3 ::return $Exception; } ::if {[::sargs::boolean_get $sargs .force]} { # flush_nv2_open_message_log; } ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.10,BabyshipMessageId==$BabyshipMessageId";} ::if {$rwb1_debug} {::puts "rwb1_debug,asynch_post_to_mothership,1000.99";} ::return ""; } method debug_dump {Token {Text ""}} { ::upvar #0 $Token State; ::puts "${Text}{-----------------------------------------------------------$Token"; ::foreach Name [::lsort [::array names State]] { ::puts "rwb1_debug,babyship,State($Name)==$State($Name)"; } ::puts "${Text}-----------------------------------------------------------$Token}"; } method asynch_post_to_mothership_callback {Token} { /* { We receive the verification responses from the mothership here. We use the .babyship.message_id to identify the message in the open message list, and we remove it from that list. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} { debug_dump $Token babyship_callback_entry; } ::if {$rwb1_debug} {::puts "rwb1_debug,babyship,asynch_post_to_mothership_callback,enter,1000.0,status==[::http::status $Token],code==[::http::ncode $Token],data==\n[::http::data $Token]";} ::if {[::http::data $Token] eq ""} { ::if {$rwb1_debug} { debug_dump $Token "Empty data"; } } ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,enter,1000.0.0,status==[::http::status $Token]";} ::switch -- [::http::status $Token] { "ok" { ::set Response [::http::data $Token]; ::http::cleanup $Token; ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,ok,1000.3,Response==$Response";} ::if {[::sargs::exists $Response .response_list]} { /* { 2.33.2 We added message lists. Older versions will continue to send single messages and the updated mothership continues to handle them. The mothership will only return a message list in response to a message list sent by the babyship so the updated mothership will be compatible with older babyships. */ } ::set ResponseList [::sargs::get $Response .response_list]; } else { ::set ResponseList [::list $Response]; } ::foreach Response $ResponseList { ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,ok,1000.7,Response==$Response";} ::set BabyshipMessageId [::sargs::get $Response .babyship.message_id]; ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,ok,1000.8,BabyshipMessageId==$BabyshipMessageId";} ::if {$BabyshipMessageId eq ""} { /* { Getting the following on linux hubs: .text ::qw::babyship::asynch_post_to_mothership_callback\ -\ no\ .babyship.message_id,\ invalid\ response\ \"\n\ \ \ \ Httpd_Error:\ 500\n\ \ \ \ Got\ the\ error\ Server\ Internal\ Error
\n\ \ \ \ while\ trying\ to\ obtain\ /asynch_post_to_mothership.\n
invalid\ command\ name\ "\;rwb1_debug,can't\ load\ asynch_post_to_mothership,2100.2"\;\n\ \ \ \ while\ executing\n"\;::unknown_qw\ \{rwb1_debug,can't\ load\ asynch_post_to_mothership,2100.2\}"\;\n\ \ \ \ invoked\ from\ within\n"\;"\;rwb1_debug,can't\ load\ \$Suffix,2100.2"\;"\;\n\ \ \ \ (object\ "\;::qw::httpd::singleton"\;\ method\ "\;::qw::httpd::root_handler"\;\ body\ line\ 100)\n\ \ \ \ invoked\ from\ within\n"\;::qw::httpd::singleton\ root_handler\ /\ sock1308\ asynch_post_to_mothership"\;\n\ \ \ \ ("\;eval"\;\ body\ line\ 1)\n\ \ \ \ invoked\ from\ within\n"\;eval\ \$Url(command,\$prefix)\ \[list\ \$sock\ \$suffix\]"\;

Tcl\ Call\ Trace

6:\ Do .text ::qw::babyship::asynch_post_to_mothership_callback - no .babyship.message_id, invalid response " Httpd_Error: 500 Got the error Server Internal Error
while trying to obtain /asynch_post_to_mothership.
invalid command name ";rwb1_debug,can't load asynch_post_to_mothership,2100.2"; while executing ";::unknown_qw {rwb1_debug,can't load asynch_post_to_mothership,2100.2}"; invoked from within ";";rwb1_debug,can't load $Suffix,2100.2";"; (object ";::qw::httpd::singleton"; method ";::qw::httpd::root_handler"; body line 100) invoked from within ";::qw::httpd::singleton root_handler / sock1308 asynch_post_to_mothership"; (";eval"; body line 1) invoked from within ";eval $Url(command,$prefix) [list $sock $suffix]";

Tcl Call Trace

6: Do */ } ::qw::warning 314120180525081147 "[::namespace current]::[::qw::methodname] - no .babyship.message_id, invalid response \"$Response\""; ::return; ::qw::bug 314120180525081147 "[::namespace current]::[::qw::methodname] - no babyship message id."; } # ------------------------------------------------------------ # Remove the message from open message queue. # ------------------------------------------------------------ /* { We remove the message from the memory cache and also write the cache out. We save the original message received from the mothership for potential processing. The fact that it has been removed from the open message cache indecates that we received the result from the mothership and that it never needs resending. */ } ::if {$_babyship_mutex_is_enabled} { ::if {![::qw::mutex_manager mutex_is_locked .mutex_name $_babyship_open_message_log_path]} { ::qw::mutex_manager mutex_lock .mutex_name $_babyship_open_message_log_path .lock_caller "[::qw::methodname]"; ::qw::finally [::list ::qw::mutex_manager mutex_unlock .mutex_name $_babyship_open_message_log_path .unlock_caller "[::qw::methodname]"]; } } ::sargs::file::unset $_babyship_open_message_log_path .$BabyshipMessageId ::if {$::qw::control(subscription_model)} { /* { We only have to process registrations or other information in nv3. */ } ::if {[::sargs::exists $Response .result.registration]} { # ------------------------------------------------------------ # registration information was returned # ------------------------------------------------------------ /* { The mothership adds registration information to most, if not all messages. We process that information here and update the babyship registration information if it has changed. program.qw_reg contents: ------------------------ .warning1 {**************************** WARNING ***************************} .warning2 {Uncontrolled changes to this file will render NewViews unusable.} .warning3 {**************************** WARNING ***************************} .serial INTERNAL-BENN-5 .nic F4-6D-04-61-A5-CE .date 20111202 .checksum BE21E3EBE69A8398649ECFD2B8911A76 mothership registration contents: --------------------------------- .nv2_serial_number INTERNAL-BENN-5 .nv2_upgrades_expiry_date 20191231 .customer_number INTERNAL-BENN the mothership message looks like: ---------------------------------- .result { .registration { .nv2_serial_number INTERNAL-BENN-5 .nv2_upgrades_expiry_date 20191231 .customer_number INTERNAL-BENN .maximum_connection_count 2 } } */ } ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.0,Response==\n[::sargs::format $Response]";} ::set MothershipRegistration [::sargs::get $Response .result.registration]; ::if {![[::qw::system] cpp_encryption_checksum_check $MothershipRegistration]} { ::qw::warning 314120180525082656 "babyship - registration checksum failure."; ::return; } ::set BabyshipRegistrationBefore [[::qw::system] cpp_registration_get]; ::set BabyshipRegistrationAfter $BabyshipRegistrationBefore; ::set BabyshipSerialNumber [::sargs::get $BabyshipRegistrationAfter .serial]; ::set MothershipSerialNumber [::sargs::get $MothershipRegistration .nv2_serial_number]; ::if {$BabyshipSerialNumber ne $MothershipSerialNumber} { ::qw::bug 314120180524094139 "[::namespace current]::[::qw::methodname] - expected serial number \"$BabyshipSerialNumber\" but encountered \"$MothershipSerialNumber\"."; } ::set BabyshipCustomerNumber [::sargs::get $BabyshipRegistrationAfter .customer_number]; ::set MothershipCustomerNumber [::sargs::get $MothershipRegistration .customer_number]; ::if {$BabyshipCustomerNumber eq ""} { /* { nv2 babyship registration actually has no customer number. In that case it gets set right here and will be written because that changes the registration. */ } ::set BabyshipCustomerNumber $MothershipCustomerNumber; ::sargs::var::set BabyshipRegistrationAfter .customer_number $MothershipCustomerNumber; } ::if {$BabyshipCustomerNumber ne $MothershipCustomerNumber} { ::qw::bug 314120180524094140 "[::namespace current]::[::qw::methodname] - expected customer number \"$BabyshipCustomerNumber\" but encountered \"$MothershipCustomerNumber\"."; } ::sargs::var::set BabyshipRegistrationAfter .maximum_connection_count [::sargs::get $MothershipRegistration .maximum_connection_count]; ::sargs::var::set BabyshipRegistrationAfter .nv2_upgrades_expiry_date [::sargs::get $MothershipRegistration .nv2_upgrades_expiry_date]; ::sargs::var::set BabyshipRegistrationAfter .nv3_release [::sargs::get $MothershipRegistration .nv3_release]; ::if {![::sargs::values_are_equal $BabyshipRegistrationAfter $BabyshipRegistrationBefore]} { # ------------------------------------------------------------ # Babyship Registration changed. # ------------------------------------------------------------ /* { The ::qw::system's registration record is updated and the registration is also written to program.qw_reg. But also, because the registration changed, we do need to set it's checksum. Note that the checksum was copied to BabyshipRegistrationAfter so no special consideration is needed. rwb_todo question: should nv2.dat be renamed to nv3.dat? */ } ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.1,MothershipRegistration==\n[::sargs::format $MothershipRegistration]";} ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.2,BabyshipRegistrationBefore==\n[::sargs::format $BabyshipRegistrationBefore]";} ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.3,BabyshipRegistrationAfter==\n[::sargs::format $BabyshipRegistrationAfter]";} ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.4,BabyshipRegistrationAfter==\n[::sargs::format $BabyshipRegistrationAfter]";} ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.5";} ::set BabyshipRegistrationAfter [[::qw::system] cpp_encryption_checksum_set $BabyshipRegistrationAfter]; ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.6";} [::qw::system] cpp_registration_set $BabyshipRegistrationAfter; ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.7";} ::sargs::file::set [::file join $::qw_program_folder nv2.dat program.qw_reg] $BabyshipRegistrationAfter; ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.8";} } ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,2000.9";} } } } ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,1000.99";} } "eof" { ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,eof encountered.";} ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.2,eof";} ::http::cleanup $Token; ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.3,eof";} } "error" { ::set Exception [::http::error $Token]; ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,error==$Exception";} ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.4,error";} ::http::cleanup $Token; ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.5,error";} } "timeout" { ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,timeout encountered,clock==[::clock seconds]";} ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.6,timeout";} # rwb__debug - why was the next line commented out - put is back in 2.28.5 ::http::cleanup $Token; ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.7,timeout";} } default { ::if {$rwb1_debug} {::puts "babyship,asynch_post_to_mothership_callback,invalid token==$Token";} ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.8,default";} ::http::cleanup $Token; ::if {$rwb1_debug} {::puts "rwb1_debug,calling ::http::cleanup,3000.9,default";} } } } method flush_nv2_open_message_log_background {} { # ------------------------------------------------------------ # Reschedule next flush before doing anything else. # ------------------------------------------------------------ ::after $_flush_nv2_open_message_log_interval [::subst -nocommands { ::if {[::qw::command_exists $this]} { $this flush_nv2_open_message_log_background; } }]; # ------------------------------------------------------------ # Flush the queue. # ------------------------------------------------------------ flush_nv2_open_message_log; } method flush_nv2_open_message_log {sargs} { /* { We flush any open messages when we boot but we also flush periodically in background. A server could go down and come back up and in the meantime open messages can accumulate without limit on the babyship. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.00,seconds==[::clock seconds]"} ::if {$_babyship_mutex_is_enabled} { ::if {![::qw::mutex_manager mutex_is_locked .mutex_name $_babyship_open_message_log_path]} { ::qw::mutex_manager mutex_lock .mutex_name $_babyship_open_message_log_path .lock_caller "[::qw::methodname]"; ::qw::finally [::list ::qw::mutex_manager mutex_unlock .mutex_name $_babyship_open_message_log_path .unlock_caller "[::qw::methodname]"]; } } ::set OpenMessages [::sargs::file::read $_babyship_open_message_log_path]; ::if {[::sargs::size $OpenMessages]==0} { /* { Nothing to do. Don't want to send an empty message, so we're out of here. */ } ::return; } /* { # ------------------------------------------------------------ # 2.33.2 Message lists introduced. # ------------------------------------------------------------ We used to send every message in the open message queue in a loop. We will not do that anymore, but instead send the entire queue in one message. A major reason occurred when the mothership was down for a while and the open message queues built up. Sending them in a loop from time to time slowed everything down./ Better to just send one big message than potentially hundreds of little messages. The babyship can assume the mothership is using vectors. The reverse is not true. The motership, altrough updated, still has to process messages from babyships that have not been updated to message_vectors. Therefore the mothership must check the babyship version and send vectors iff the babyship version is 2.33.2 or greater. Rule: Both sides can send/process individual messages. They will use vectors only when sending/processing multiple-message queues. However, the mothership will send a queue as individual messages if the babyship version is less than 2.33.2. */ } # ------------------------------------------------------------ # Build the .message_list from the message queue. # ------------------------------------------------------------ /* { The message queue is a sargs where the field name of each message is .$BabyshipMessageId. This allows random access when responses are received so we can identify and remove messages randomly. But it also means we have to build a flat list of messages to send to the mothership because that's the way we did it. */ } ::set MothershipUrl $_mothership_url; ::if {[::sargs::get $sargs .mothership_url] ne ""} { ::set MothershipUrl [::sargs::get $sargs .mothership_url]; } ::set MessageList [::list]; ::foreach {Name Value} $OpenMessages { ::lappend MessageList $Value; } ::sargs::var::set Message .message_list $MessageList; ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.02,clock==[::clock seconds]";} ::if {0} { ::set Query [::qw::http::formatQuery mothership_message $Message]; } ::if {1} { ::set Query [::http::formatQuery mothership_message $Message]; } ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.03,clock==[::clock seconds]";} ::qw::try { ::switch -- $::tcl_platform(platform) { "windows" { ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.04,clock==[::clock seconds]";} ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.05$MothershipUrl==$MothershipUrl";} /* { 2.38.5 - added the timeout The lack of a timeout could have been a cause of the mexxage_database freezing. There is really no way to test this. Note that used 30 seconds instead of 5 seconds to give the server time to insert all the messages in the open_message log. */ } ::http::geturl "$MothershipUrl/asynch_post_to_mothership" \ -query $Query \ -type "application/x-www-form-urlencoded" \ -command [::list ::qw::babyship::singleton asynch_post_to_mothership_callback] \ -timeout 30000 \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.06,clock==[::clock seconds]";} } "unix" { /* { It was hard to get ::http::geturl working on unix. Added -headers below to work around the problem. The net said that maybe tcl 86 zlib is not working properly. */ } # 2.38.5 added tineout ::http::geturl "$MothershipUrl/asynch_post_to_mothership" \ -query $Query \ -type "application/x-www-form-urlencoded" \ -command [::list ::qw::babyship::singleton asynch_post_to_mothership_callback] \ -headers [::list Accept-Encoding ""] \ -timeout 30000 \ ; } } } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,flush_nv2_open_message_log,1000.07,exception==$Exception";} } } } ::qw::babyship ::qw::babyship::singleton; ::qw::babyship::singleton main;