# ------------------------------------------------------------ # Copyright (c) 2017-2025 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ /* { */ } # Usage: package require ::qw::tclhttpd /* { This package just wraps the tcl web server (tclhttpd). The tcl web server is a global entiry and has only one instance. Hopefully we can replace it in the future. We had to make two changes to the tclhttpd3.5.1 code: in auth.tcl and tclhttpd.rc. In each case the temporary folder was hard-wired to /tmp, and we just changed it to $::env(TMP). We might have to generalize this further in the future (or maybe not). This is commented on at https://sourceforge.net/p/tclhttpd/bugs/74/ 20201116 - downloaded openssl executables from: https://www.dll-files.com/vcruntime140.dll.html. 20201116 - Also had to download vc 64-bit runtime support for 2017 which I downloaded from https://www.dll-files.com/vcruntime140.dll.html. */ } ::itcl::class ::qw::httpd { protected variable _doc_root ""; protected variable _http_port ""; protected variable _https_port ""; method constructor {} { ::set _http_port $::qw::control(http_port); ::set _https_port $::qw::control(https_port);; } method destructor {} { } method main {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.2,sargs==$sargs";} ::if {[::llength [::sargs::select_field_value .structure $sargs .field .invoker .value commandline]]!=0} { /* { During testing we may be running from commandline so allow default tclwebserver window to display. */ } ::wm deiconify . } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.3";} ################################################################# # Override values here. ################################################################# /* { 2.38.4 We introduced oauth which uses the tclwebserver like any http server. But oauth is the first time we are running a tclwebserver on any computer other than a PAGE computer that has a c:/htdocs folder. In that case the tclwebserver errors out because it can't find htdocs. As a quick fix we supply the program folder as the root folder. If we really need htdocs for any reason we can supply it in the .doc_root folder. */ } ::set _doc_root $::qw_program_folder; /* { 2.38.4 ::switch -glob -- [::info hostname] { benn7 { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.2.0";} # ::set _doc_root [::file join c:/ htdocs]; } benn_2020 { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.2.1";} ::set _doc_root [::file join c:/ htdocs]; } default { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.2.2";} ::set _doc_root $::qw_program_folder; } } */ } ::if {[::sargs::get $sargs .doc_root] ne ""} { ::set _doc_root [::sargs::get $sargs .doc_root]; } ################################################################# # Command line arguments can override code settings. ################################################################# #nv2.33.1(.5) (new feature) - command line argument -http_port and -https_port ::if {[::sargs::get $::qw_sargv .http_port] ne ""} { ::set _http_port [::sargs::get $::qw_sargv .http_port]; } ::if {[::sargs::get $::qw_sargv .https_port] ne ""} { ::set _https_port [::sargs::get $::qw_sargv .https_port]; } ################################################################# /* { tclhttpd is global and this causes some problems. It is created when we source httpd.tcl and that is done on demand when we package require qw::tclhttpd. It would be better if we created an object for each httpd port. We would have to re-wrap the entire httpd app to accomplish this. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.4";} # ------------------------------------------------------------ # Make sure the ports are not already in use. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.5";} ::if {$rwb1_debug} { debug_dump_config; } /* { - just for testing - need way to specify ipaddr ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.6,_http_port==$_http_port";} ::set Handle [::socket -server {} $_http_port]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.7";} ::close $Handle } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.8";} ::qw::throw "Can't run web server on port $_http_port; probably in use. Error:\"$Exception\""; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.9";} debug_dump_config; ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.10.0,info hostname==[::info hostname]";} ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.10.1,_https_port==$_https_port";} ::set Handle [::socket -server {} $_https_port]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.11";} ::close $Handle; } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.12";} ::qw::throw "Can't run web server on port $_https_port; probably in use. Error:\"$Exception\""; } */ } ::switch -glob -- $::qw::control(commandline_script_path) { *timecard_server.qw_script { } *timecard_traffic.qw_script { } *workorder_server.qw_script { } *workorder_traffic.qw_script { } default { # ------------------------------------------------------------ # Create doc_root folder on demand. # ------------------------------------------------------------ ::if {![::file exists $_doc_root]} { ::qw::fileutil::make_folder_exist .folder_path $_doc_root; } # ------------------------------------------------------------ # Install favicon.ico on demand # ------------------------------------------------------------ ::if {![::file exists [::file join $_doc_root favicon.ico]]} { ::file copy -force [::file join $::qw_program_path nv2.ico] [::file join $_doc_root favicon.ico]; } } } ::if {!$::qw::control(ssl_key_generate)} { # ------------------------------------------------------------ # Install crypto files into program folder on demand. # ------------------------------------------------------------ # 2.34.5 #rwb_master # SSL_CAFILE - the file containing the Certificate Authority # certificate. If this is empty, then the directory specified by # SSL_CADIR is scanned for certificate files. #rwb_master Config SSL_CAFILE [::file join c:/ qw.lib tclhttpd3.5.1 certs server_request.pem]; #rwb_master Config SSL_CAFILE [::file join c:/ qw.lib tclhttpd3.5.1 certs server_request.pem]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13";} /* { Tried to use the temporary folder. The files were created and then, when the connection was made, they were deleted, right before my eyes. I have no idea why we can't use the temp folder. 2.34.7 - no longer use .tmp extension because *.tmp is deleted whenever possible. That's why the files were disappearing from time to time. Instead, we change the extension and we also put the files in nv2.dat. We'll let the old .tmp files eventually disappear during *.tmp cleanups. ::qw::filutil::mkdir only creates a folder if not already there. */ } ::if {$::qw::control(ssl_use_openssl_key)} { ::set CertFolder [::file join $::qw_program_folder nv2.dat nv2_cert]; ::qw::fileutil::mkdir .path $CertFolder; #rwb__debug - delete these old files on demand of in nv2_install ::set CAFile [::file join $CertFolder 314120250331105402.ca]; ::if {![::file exists $CAFile]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.0";} ::file copy [::file join $::qw_program_path system tcp 314120250331105402.ca] $CAFile; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.1";} } ::set CertFile [::file join $CertFolder 314120250331105402.crt]; ::if {![::file exists $CertFile]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.2";} ::file copy [::file join $::qw_program_path system tcp 314120250331105402.crt] $CertFile; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.3";} } ::set KeyFile [::file join $CertFolder 314120250331105402.key]; ::if {![::file exists $KeyFile]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.4";} ::file copy [::file join $::qw_program_path system tcp 314120250331105402.key] $KeyFile; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.5";} } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.14";} } ::if {!$::qw::control(ssl_use_openssl_key)} { ::set CertFolder [::file join $::qw_program_folder nv2.dat nv2_cert]; ::qw::fileutil::mkdir .path $CertFolder; #rwb__debug - delete these old files on demand of in nv2_install ::set CAFile [::file join $CertFolder 314120201110144037.pem]; ::if {![::file exists $CAFile]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.0";} ::file copy [::file join $::qw_program_path system tcp https_certificate.pem] $CAFile; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.1";} } ::set CertFile [::file join $CertFolder 314120201110144038.pem]; ::if {![::file exists $CertFile]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.2";} ::file copy [::file join $::qw_program_path system tcp https_certificate.pem] $CertFile; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.3";} } ::set KeyFile [::file join $CertFolder 314120201110144039.key]; ::if {![::file exists $KeyFile]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.4";} ::file copy [::file join $::qw_program_path system tcp https_private.key] $KeyFile; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.13.5";} } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.14";} } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.14";} } ::if {$::qw::control(ssl_key_generate)} { ::qw::tcp::tls_generate_self_signed_certificate; ::set CertFolder [::file dirname $::qw::tcp::tls_cert_path]; ::set CAFile $::qw::tcp::tls_cert_path; ::set CertFile $::qw::tcp::tls_cert_path; ::set KeyFile $::qw::tcp::tls_key_path; } /* { tclhttpd, beiong global, also expected to be configured by the command line or within config.tcl at boot. Unless we change config.tcl in the vfs, we have to send our options through ::argv. Here we save argv, use it to send options to httpd.tcl, and then restore it. Someday we should reimplement tclhttpd to allow multiple objects and ports. For now we will only be running a single web site per process. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.20";} ::set argc_save $::argc; ::set argv_save $::argv; ::set ::argc 0; ::set ::argv [::list]; # ::set LogFile [::file join $::qw_program_folder nv2_webserver.log]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.21,_https_port==$_https_port";} ::lappend ::argv -port $_http_port; ::lappend ::argv -https_port $_https_port; ::lappend ::argv -docRoot $_doc_root; ::set ::argc [::llength $::argv]; ::qw::try { /* { We source in the global namespace because the tclwebserver can't find variables otherwise. For example, it can't find "auto_path". */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.22";} /* { The httpd.tcl vwaits on ::forever. We don't need this and we don't want to avoid editing the httpd code, so we simply release the vwait by changing the vwait variable's value. */ } ::after 1 [::list ::set ::forever 1]; ::set ::Config(SSL_REQUIRE) 0; ::set ::Config(USE_SSL2) 0; ::set ::Config(USE_SSL3) 0; ::set ::Config(USE_TLS1) 1; ::set ::Config(SSL_CADIR) $CertFolder; ::set ::Config(SSL_CAFILE) $CAFile; ::set ::Config(SSL_CERTFILE) $CertFile; ::set ::Config(SSL_KEYFILE) $KeyFile; # ------------------------------------------------------------ # Create the actual tclwebserver, i.e. ::httpd # ------------------------------------------------------------ ::namespace eval :: {::source [::file join $::qw_program_path lib tclhttpd3.5.1 bin httpd.tcl]}; } catch Exception { ::puts "exception==\n$Exception"; ::qw::throw $Exception; } ::set ::argc $argc_save; ::set ::argv $argv_save; ::Mtype_Add .htm text/html; # trying to get web/chm working # Config LogFile [::file join $::qw_program_folder nv2_webserver.log]; # Config webmaster benn@qwpage.com; /* { Url_PrefixInstallOptions - page 386 -thread 0/1 -callback - on completion, gets socket and error arguments -readpost */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.23";} /* { main usage: httpd.tcl options: -virtual value Virtual host config list <> -config value Configuration File -main value Per-Thread Tcl script -docRoot value Root directory for documents -port value Port number server is to listen on <8015> -host value Server name, should be fully qualified -ipaddr value Interface server should bind to <> -https_port value SSL Port number <8016> -https_host value SSL Server name, should be fully qualified -https_ipaddr value Interface SSL server should bind to <> -webmaster value E-mail address for errors -uid value User Id that server runs under <50> -gid value Group Id for caching templates <50> -secs value Seconds per "minute" for time-based histograms <60> -threads value Number of worker threads (zero for non-threaded) <0> -library value Directory list where custom packages and auto loads are -debug value If true, start interactive command loop <0> -compat value version compatibility to maintain <3.3> -gui value flag for launching the user interface <1> -mail value Mail Servers for sending email from tclhttpd <> -- Forcibly stop option processing -help Print this message -? Print this message */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.24";} # ::array set _socket_array ""; ::array set _url_cache ""; ::set Title [::sargs::get $sargs .title]; ::if {$Title ne ""} { ::set _title $Title; } ::append Title ",[::info hostname]:$_http_port"; /* { ::set Command [::itcl::code $this server_connection_accept [::sargs .scheme $_scheme]]; ::qw::try { ::set _listening_socket [::socket -server $Command $_server_port]; } catch Exception { ::qw::try { ::itcl::delete object $this; } catch dummy { ::puts "warning 314120200420092652 - could not delete object, dummy==$dummy"; } ::qw::throw "[::info hostname] could not open server on port $Port, Exception:$Exception"; } ::if {$rwb1_debug} {::puts "rwb1_debug,mini,main,1000.10";} */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.25";} /* { 2.38.5 - get rid of these. Url_PrefixInstall /ping [::list ::qw::httpd::singleton ping_handler /ping]; Url_PrefixInstall /test [::list ::qw::httpd::singleton test_handler /test]; Url_PrefixInstall / [::list ::qw::httpd::singleton root_handler /]; */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::httpd::main,1000.99";} } method ping_handler {Prefix Socket Suffix} { ::Httpd_ReturnData $Socket text/html "pong"; } method root_handler {Prefix Socket Suffix} { ::set rwb1_debug 0; ::upvar #0 ::Httpd$Socket HttpdData; ::if {$rwb1_debug} { debug_dump $Socket "root_handler"; } ::if {$rwb1_debug} {::puts "rwb1_debug,root_handler,1000.0,Prefix==$Prefix,Socket==$Socket,Suffix==$Suffix"} # Trim the Suffix of any slashes. ::set Suffix [::string trim $Suffix "/"]; # ------------------------------------------------------------ # Empty suffix. # ------------------------------------------------------------ /* { rwb_todo want to provide both spokes in the same process But this will do for now. The problem is that we should have workorder or timecard as first item in the suffix. */ } ::switch -- $::qw::control(app_name) { app_name_workorder_spoke { ::set Suffix $_source_path/workorder_react/forward.html; } app_name_timecard_spoke { #::set Suffix $_source_path/timecard_react/forward.html; # followiung the original code ::set Suffix $_source_path/forward.html; } default { # ::set Suffix "index.html"; } } ::qw::try { ::switch -glob -- $Suffix { "*react" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.0";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root wgb index.html]]; ::Httpd_ReturnData $Socket "text/html" $Data; ::return; } "*.htm" - "*.html" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.1,Path==[::file join $_doc_root $Suffix]";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "text/html" $Data; ::return; } "*.css" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.2";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "text/css" $Data; ::return; } "*.js" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.3";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "text/javascript" $Data; ::return; } "*.json" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.4";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "application/json" $Data; ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.4.0";} ::return; } "*.png" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.5";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "image/png" $Data; ::return; } "*.map" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.6";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "text/html" $Data; ::return; } "*.svg" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.7";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix]]; ::Httpd_ReturnData $Socket "image/svg+xml" $Data; ::return; } "*.ico" { ::if {$rwb1_debug} {::puts "rwb1_debug,root handler,5000.8";} ::set Data [::qw::fileutil::file_read .path [::file join $_doc_root $Suffix] .translation "binary"]; ::Httpd_ReturnData $Socket "image/x-icon" $Data; ::return; } } } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,can't load $Suffix,2100.0,Exception==$Exception";} ::Httpd_Error $Socket 404 "Can't load $Suffix"; ::if {$rwb1_debug} {::puts "rwb1_debug,can't load $Suffix,2100.1,Exception==$Exception";} ::return; } ::if {$rwb1_debug} ::puts {"rwb1_debug,can't load $Suffix,2100.2";} ::Httpd_ReturnData $Socket "text/html" [debug_dump_html $Socket root_handler_done]; ::if {$rwb1_debug} ::puts {"rwb1_debug,can't load $Suffix,2100.3";} ::return; # Here is what we are expecting in the URL: /database_name/endpoint /* { What happens for https://benn7 HttpdArray(prefix)==/ HttpdArray(suffix)== HttpdArray(uri)==/ HttpdArray(url)==/ With a/b/c.xxx$a=1&b=2&c=3 HttpdArray(pathlist)==demo_canada abc database.nv2 HttpdArray(prefix)==/ HttpdArray(query)==a=1&b=2&c=3 HttpdArray(suffix)==demo_canada/abc/database.nv2 HttpdArray(uri)==/demo_canada/abc/database.nv2?a=1&b=2&c=3 HttpdArray(url)==/demo_canada/abc/database.nv2 What happens for https://benn7/ HttpdArray(prefix)==/ HttpdArray(suffix)== HttpdArray(uri)==/ HttpdArray(url)==/ With a/b/c.xxx$a=1&b=2&c=3 HttpdArray(pathlist)==demo_canada abc database.nv2 {} HttpdArray(prefix)==/ HttpdArray(query)==a=1&b=2&c=3 HttpdArray(suffix)==demo_canada/abc/database.nv2/ HttpdArray(uri)==/demo_canada/abc/database.nv2/?a=1&b=2&c=3 HttpdArray(url)==/demo_canada/abc/database.nv2/ What happens for https://benn7/demo_canada HttpdArray(pathlist)==demo_canada HttpdArray(prefix)==/ HttpdArray(suffix)==demo_canada HttpdArray(uri)==/demo_canada HttpdArray(url)==/demo_canada What happens for https://benn7/demo_canada/ HttpdArray(pathlist)==demo_canada {} HttpdArray(prefix)==/ HttpdArray(suffix)==demo_canada/ HttpdArray(uri)==/demo_canada/ HttpdArray(url)==/demo_canada/ What happens for https://benn7/demo_canada/abc/database.nv2 HttpdArray(pathlist)==demo_canada abc database.nv2 HttpdArray(prefix)==/ HttpdArray(suffix)==demo_canada/abc/database.nv2 HttpdArray(uri)==/demo_canada/abc/database.nv2 HttpdArray(url)==/demo_canada/abc/database.nv2 What happens for https://benn7/demo_canada/abc/database.nv2/ HttpdArray(pathlist)==demo_canada abc database.nv2 {} HttpdArray(prefix)==/ HttpdArray(suffix)==demo_canada/abc/database.nv2/ HttpdArray(uri)==/demo_canada/abc/database.nv2/ HttpdArray(url)==/demo_canada/abc/database.nv2/ */ } ::set PathList [::split $Suffix "/"]; ::if {[::llength $Suffix]==1} { # ------------------------------------------------------------ # /database_name # ------------------------------------------------------------ # URL contains "/database_name" or "/database_name/" # Relative URLs need a "/" at the end to work - redirect to "/database_name/" ::if {[::string index $HttpData(url) end] ne "/"} { /* { This seems like a serious kldge that surely could have been fixed another way. Don't really know what's happening here yet. */ } ::set NewURL [::append HttpdData(url) "/"]; ::Httpd_Redirect $NewURL $Socket; ::return; } # Return the index.html for this specific database #// /* {;#// one copy of react in each application database subfolder ::qw::try { ::set HTML [read_file "$_source_path${HttpdData(url)}index.html"]; } catch Error { ::set HTML [read_file "$_source_path/index.html"]; } ::qw::try { ::set HTML [read_file "$_source_path/workorder_react/index.html"]; } catch Error { ::set HTML [read_file "$_source_path/workorder_react/forward.html"]; } */} #// ::switch -- $::qw::control(app_name) { app_name_workorder_traffic { ::set HostsFilePath [::file join c:/ nv2_workorder_sandbox hosts]; ::set ForwardPath [::file join c:/ $_source_path workorder_react forward.html]; ::set IndexPath [::file join c:/ $_source_path workorder_react forward.html]; } app_name_timecard_traffic { ::set HostsFilePath [::file join c:/ nv2_timecard_sandbox hosts]; ::set ForwardPath [::file join c:/ $_source_path forward.html]; ::set IndexPath "$_source_path${HttpData(url)}index.html"; } } ::set HostsFileContents [::qw::fileutil::file_read .path $HostsFilePath]; ::set DatabaseList [::list]; ::foreach Line [::split $HostsFileContents "\n"] { # Example Line: 127.0.0.1 localhost # Ignore empty lines, comments, and IPs not starting with 127.0.0. ::if {$Line eq "" || [::string index $Line 0] eq "#" || [::string first "127.0.0." [::lindex $Line 0]] < 0} { ::continue; } ::lappend DatabaseList [::lindex $Line 1]; } ::if {[::lsearch $DatabaseList [::string range $HttpdData(url) 1 [::expr {[::string length $HttpdData(url)]-2}]]]<0} { ::set HTML [::qw::fileutil::file_read $ForwardPath]; # ::set HTML [read_file "$_source_path/workorder_react/forward.html"]; } else { ::set HTML [::qw::fileutil::file_read $IndexPth]; #::set HTML [read_file "$_source_path/workorder_react/index.html"]; } ::Httpd_ReturnData $Socket "text/html" $HTML; ::return; } # ------------------------------------------------------------ # /database/endpoint # ------------------------------------------------------------ #//::puts "pgq,debugShortcut...handle_request ::switch case default ::switch default HttpdData(proto)==$HttpdData(proto) HttpdData(url)==$HttpdData(url)"; # URL contains "/database_name/endpoint" - forward request to spoke web server ::set DBname [::lindex $PathList 0]; # Check the semaphore. If exists, return database busy error to browser. ::if {[check_semaphore $DBname]} { ::Httpd_ReturnData $Socket "application/json" [::json::write::object "databaseBusyPage" [::json::write::string "true"]]; ::return; } # Copy the desired headers from the inbound request to forward to the spoke web server ::set RelayRequestHeaders [::list]; ::foreach Header [::array names HttpdData -glob "mime,*"] { ::lappend RelayRequestHeaders [::string map {"mime," ""} $Header] $HttpdData($Header); } ::foreach Header [::array names HttpdData -glob "query*"] { ::lappend RelayRequestHeaders $Header $HttpdData($Header); } # Each web server is running on port 2615 at a local domain equal to the name of # the database. ::set URL "http://${DBname}:2615$HttpdData(url)"; ::qw::try { ::set ResponseToken [::http::geturl $URL -headers $RelayRequestHeaders -protocol 1.1]; ::upvar #0 $ResponseToken ResponseState; } catch Error { ::puts "[::clock format [::clock seconds] -format {%Y/%m/%d %H:%M:%S}] - relay request Error on $URL: $Error" ::Httpd_ReturnData $Socket "application/json" [::json::write::object "errorPage" [::json::write::string "true"]]; ::return; } # Copy cookie info from spoke web server response to the traffic cop's response ::foreach {Header Value} [::http::meta $ResponseToken] { ::switch [::string tolower $Header] { "set-cookie" { ::lappend HttpdData(set-cookie) $Value; } } } ::if {[::http::status $ResponseToken] eq "ok"} { ::set Response [::http::data $ResponseToken]; ::set ContentType $ResponseState(type); } else { ::puts "[::clock format [::clock seconds] -format {%Y/%m/%d %H:%M:%S}] - ResponseToken status not \"ok\"... [::http::meta $ResponseToken]" ::set Response [::json::write::object "errorPage" [::json::write::string "true"]]; ::set ContentType "application/json"; } ::http::cleanup $ResponseToken; ::Httpd_ReturnData $Socket $ContentType $Response; } method test_handler {Prefix Socket Suffix} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,test_handler,1000.0,Prefix==$Prefix,Socket==$Socket,Suffix==$Suffix"} ::upvar #0 Httpd$Socket HttpdData; # Generate page header ::set Html "Test Handler\n" ::append Html "

$Prefix$Suffix

\n" ::append Html "

Test Handler Date and Time

\n" ::append Html [clock format [clock seconds]] # Display query HttpdData ::if {[::info exists HttpdData(query)]} { ::append Html "

Query Data

\n" ::append Html "\n" ::foreach {Name Value} [::Url_DecodeQuery $HttpdData(query)] { ::append Html "\n" } ::append Html "
$Name$Value
\n" } ::append Html [debug_dump $Socket]; ::Httpd_ReturnData $Socket text/html [::sargs .result $Html]; } method debug_dump_config {} { ::set Result ""; ::if {[::info exists ::Config]} { ::append Result "-------------------------------------------------------\n" ::foreach Name [::lsort [::array names ::Config]] { ::append Result "::Config($Name)==$::Config($Name)\n"; } ::append Result "-------------------------------------------------------\n" } else { ::puts "rwb1_debug,debug_dump,1000.1,no Config"; } ::puts $Result; ::return $Result; } method debug_dump {Socket {Message ""}} { ::upvar #0 Httpd$Socket HttpdArray; ::set Result ""; ::if {$Message ne ""} { ::append Result "-------------------------------------------------------\n" ::append Result "$Message\n"; } ::append Result "-------------------------------------------------------\n" ::foreach Name [::lsort [::array names HttpdArray]] { ::if {$Name eq "headerlist"} { /* { HttpArray(headerlist) is always too wide to display properly so we send it as a name/value list later. */ } ::continue; } ::append Result "HttpdArray($Name)==$HttpdArray($Name)\n"; } ::if {[::info exists HttpdArray(headerlist)]} { ::append Result "-------------------------------------------------------\n" ::foreach {Name Value} $HttpdArray(headerlist) { ::append Result "Header($Name)==$Value\n"; } ::append Result "-------------------------------------------------------\n" } else { ::puts "rwb1_debug,debug_dump,1000.1,no HttpdArray(headerlist)"; } ::puts $Result; ::return $Result; /* { ------------------------------------------------------- HttpdArray(cancel)==after#12 HttpdArray(count)==0 HttpdArray(headerlist)==Host benn7 User-Agent {Mozilla/5.0 (Windows; U; Windows NT 6.1) http/2.9.1 Tcl/8.6.5} Connection close User-Agent {NV2 2.34.4.20200813} Accept */* Accept-Encoding gzip,deflate,compress Content-Type application/x-www-form-urlencoded Content-Length 154 HttpdArray(ipaddr)==fe80::18e5:2da8:b95d:39%11 HttpdArray(key)==content-length HttpdArray(left)==25 HttpdArray(line)==POST /message_database HTTP/1.1 HttpdArray(mime,accept)==*/* HttpdArray(mime,accept-encoding)==gzip,deflate,compress HttpdArray(mime,connection)==close HttpdArray(mime,content-length)==154 HttpdArray(mime,content-type)==application/x-www-form-urlencoded HttpdArray(mime,host)==benn7 HttpdArray(mime,user-agent)==Mozilla/5.0 (Windows; U; Windows NT 6.1) http/2.9.1 Tcl/8.6.5,NV2 2.34.4.20200813 HttpdArray(mimeorder)==host user-agent connection accept accept-encoding content-type content-length HttpdArray(pathlist)== HttpdArray(prefix)==/message_database HttpdArray(proto)==POST HttpdArray(query)==sargs=%2ecommand+message%5fdatabase%5fget+%2etcp+%7b%0d%0a++++++++++++++++%2ecommand+call%0d%0a++++++++++++++++%2epriority+foreground%0d%0a++++++++++++%7d HttpdArray(self)==http benn7 80 HttpdArray(state)==mime HttpdArray(suffix)== HttpdArray(uri)==/message_database HttpdArray(url)==/message_database HttpdArray(version)==1.1 ------------------------------------------------------- Header(Host)==benn7 Header(User-Agent)==Mozilla/5.0 (Windows; U; Windows NT 6.1) http/2.9.1 Tcl/8.6.5 Header(Connection)==close Header(User-Agent)==NV2 2.34.4.20200813 Header(Accept)==*/* Header(Accept-Encoding)==gzip,deflate,compress Header(Content-Type)==application/x-www-form-urlencoded Header(Content-Length)==154 ------------------------------------------------------- */ } } method debug_dump_html {Socket {Message ""}} { ::upvar #0 Httpd$Socket HttpdArray; # ::append Result "
";
        ::if {$Message ne ""} {
			::append Result "$Message\n"
            ::append Result "-------------------------------------------------------
\n"
            ::append Result "$Message
\n";
        }
        ::append Result "-------------------------------------------------------
\n"
        ::foreach Name [::lsort [::array names HttpdArray]] {
            ::if {$Name eq "headerlist"} {
                /* {
                HttpArray(headerlist) is always too wide to display properly so
                we send it as a name/value list later.
                */ }
                ::continue;
            }
            ::append Result "HttpdArray($Name)==$HttpdArray($Name)
\n";
        }
        ::append Result "-------------------------------------------------------
\n"
		::if {[::info exists HttpdArray(headerlist)]} {
            ::foreach {Name Value} $HttpdArray(headerlist) {
                ::append Result "Header($Name)==$Value
\n";
            }
		}
        ::puts "-------------------------------------------------------
\n"
#        ::append Result "
"; ::return $Result; } } ::proc ::qw::httpd::decode_query {sargs} { /* { What it does depends on the value of HttpdArray(mime,content-type). Currently recognizes JSON and assumes */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.0";} ::set Socket [::sargs::get $sargs .socket]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.1";} ::upvar #0 Httpd$Socket HttpdArray; ::if {[::info exists HttpdArray(query_sargs)]} { ::return $HttpdArray(query_sargs); } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.2";} ::set QueryString $HttpdArray(query); ::set ContentType "text/plain"; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.3";} ::if {[::info exists HttpdArray(mime,content-type)]} { ::set ContentType $HttpdArray(mime,content-type); } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.4,ContentType==$ContentType";} ::switch -- $ContentType { "application/json" { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.4.0,QueryString==\n$QueryString";} ::set Struct [::sargs::json2sargs .json $QueryString]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.4.1";} ::set HttpdArray(query_sargs) $Struct; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.4.2";} ::return $Struct; } default { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.5";} ::set Struct [::sargs]; ::set Query [Url_DecodeQuery $QueryString]; ::set Query [encoding convertfrom utf-8 $Query]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.6";} ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.7";} ::foreach {Path Value} $Query { ::switch -- [::string index $Path 0] { "." - "/" { ::sargs::var::set Struct $Path $Value; } default { ::sargs::var::set Struct ".$Path" $Value; } } } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.8";} ::set HttpdArray(query_sargs) $Struct; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.9";} ::return $Struct; } } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::tclhttpd::decode_query,1000.10";} ::return; /* { ::package require ncgi; ::set QueryList ""; ::foreach Pair [::split $QueryString "&"] { ::foreach {Name Value} [::split $Pair "="] { ::set $Name [::ncgi::decode $Name]; ::set Value [::ncgi::decode $Value]; ::lappend QueryList $Name $Value; } } ::set HttpdArray(query_list) $QueryList; ::return $QueryList; */ } } ::qw::httpd ::qw::httpd::singleton; ::qw::httpd::singleton main;