# ------------------------------------------------------------ # Copyright (c) 2020-2022 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::itcl::class ::qw::odb::spoke_socket { protected variable _database ""; protected variable _database_path ""; method spoke_socket_callback {Socket Type Message} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb_debug,qw_odb_spoke_socket_handler,1000.0,Socket==$Socket,Type==$Type,Message==$Message";} ::switch -- $Type { request { ::return; } close { ::return; } connect { ::return; } disconnect { ::return; } binary { ::return; } text { ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.0";} ::set sargs $Message; # ::websocket::send $Socket text "$Message on the TclHttpd Web Server" ::if {$Message ne ""&&[::sargs::is_primitive $Message]} { ::qw::bug 314120201205125124 "[::namespace current]::[::qw::methodname] - invalid sargs $sargs."; } ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.1";} ::set TcpPriority [::sargs::get $sargs .tcp.priority]; ::set TcpCommand [::sargs::get $sargs .tcp.command] ::switch -- $TcpCommand { "call" { ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.2";} ::if {$TcpPriority ne "foreground"} { ::websocket::send $Socket text .exception "Badly formed sargs $sargs"; ::return; } ::set Exception ""; ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.3";} ::qw::try { # ------------------------------------------------------------ # Make the application call. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.4";} ::set Result [tcp_interface $sargs]; ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.5";} } catch Exception { # ------------------------------------------------------------ # Exception was thrown by application. # ------------------------------------------------------------ ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.6";} ::websocket::send $Socket text [::sargs \ .tcp.command return \ .exception $Exception ]; ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.7";} } catch dummy { ::qw::warning 314120201205125526 "[::namespace current]::[::qw::methodname] - can't write socket, exception:$dummy"; } ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.8";} ::return; } # ------------------------------------------------------------ # Application succeeded and returned a result. # ------------------------------------------------------------ ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.9";} ::websocket::send $Socket text [::sargs \ .tcp.command return \ .result $Result; ]; ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.10";} } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.11";} ::qw::warning 314120200405152219 "[::namespace current]::[::qw::methodname] - can't write socket, exception:$Exception"; ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,spoke_socket_callback,text,1000.12";} ::return; } } ::websocket::send $Socket text [::sargs \ .tcp.command return \ .exception "invalid tcp command $TcpCommand" \ ]; } } } method tcp_interface {sargs} { /* { For now we will forgo a destination. The caller creates a database handle. He can then use it remotely. We will try that for now. But how will the server ever know how to signal the client? */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tcp_interface,1000.0";} ::set Command [::sargs::get $sargs .command]; ::if {$rwb1_debug} {::puts "rwb1_debug,tcp_interface,1000.1,Command==$Command";} ::set Result [::eval $Command]; ::if {$rwb1_debug} {::puts "rwb1_debug,tcp_interface,1000.2,result==$Result";} ::return $Result; } } ::itcl::class ::qw::odb::spoke_server { /* { There is a single spoke_server singleton object that is created when the qw_odb_spoke_server package is required. The spoke_server requires qw::httpd and installs a connection handler. */ } constructor {} { } method destructor {} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,spoek_server,destructor,1000.0";} } method main {sargs} { /* { */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,odb::spoke_server,main,1000.0";} ::wm deiconify .; ::package require qw::httpd; ::if {$rwb1_debug} {::puts "rwb1_debug,odb::spoke_server,main,1000.1";} ::if {$::tcl_version eq "8.4"} { ::package require websocket; } else { ::set Version [::package require -exact websocket 1.5]; ::puts "rwb_debug,package require websocekt 1.5,version==$Version"; } ::Url_PrefixInstall /qw_odb_spoke_server [::list $this connection_handler /qw_odb_spoke_server]; ::if {$rwb1_debug} {::puts "rwb1_debug,odb::spoke_server,main,1000.99";} } /* { method spoke_server_callback {Socket Type Message} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb_debug,websocket_test_callback,1000.0,Socket==$Socket,Type==$Type,Message==$Message";} ::switch -- $Type { close { ::return; } connect { ::return; } disconnect { ::return; } binary { ::return; } text { ::if {$rwb1_debug} {::puts "rwb_debug,websocket_test_callback,1000.1";} ::websocket::send $Socket text "$Message on the TclHttpd Web Server" ::if {$rwb1_debug} {::puts "rwb_debug,websocket_test_callback,1000.2";} } } } */ } method connection_handler {Prefix Socket Suffix} { /* { This is the connection handler for the spoke_server. We create a spoke_socket for each incoming websocket connection. This is hit only when opening a connection. The websocket is created and control from then on is passed to it. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.0,Prefix==$Prefix,Socket==$Socket,Suffix==$Suffix";} ::upvar #0 Httpd$Socket Data; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.1";} ::websocket::server $Socket; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.2";} ::set SpokeSocket [::qw::odb::spoke_socket ::qw::odb::spoke_socket::#auto]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.3";} ::websocket::live $Socket /qw_odb_spoke_server [::list $SpokeSocket spoke_socket_callback]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.4";} ::set IsWebsocket [::websocket::test $Socket $Socket /qw_odb_spoke_server $Data(headerlist) $Data(query)]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.5,IsWebsocket==$IsWebsocket";} ::if {$IsWebsocket == 1} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.6";} ::Httpd_Suspend $Socket 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.7";} ::websocket::upgrade $Socket; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.8";} } else { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.9";} ::Httpd_ReturnData $Socket text/html "Not a valid Websocket connection!" ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.10";} } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_odb_spoke_server_connection_handler,1000.11";} # $SpokeSocket main; ??? } } ::qw::odb::spoke_server ::qw::odb::spoke_server::singleton; ::qw::odb::spoke_server::singleton main;