#!/usr/pkg/bin/perl # gus_xml-rpc_server.pl # Copyright 2005-2006 by Gan Uesli Starling # XML-RPC server script written in Perl. # See POD at EOF for full description. # 1350 lines of code & 358 comment lines. use Getopt::Long; use Frontier::Daemon; use Sys::Hostname::Long; use Digest::MD5::File qw( file_md5_base64 ); use File::Basename; use Log::Logger; use warnings; use strict; use vars qw( $script_path $okay_regex @okay_scripts ); our $formal_date = '2006-06-20'; # Get XML-RPC server host name for ID when replying to client. my $host_name = hostname_long(); ########################################### # BEGIN THINGS USER CAN AND SHOULD CHANGE # ########################################### # Full path to the line delimited, text file listing scripts which are safe to # execute. The list may contain only file names, no paths or arguments. Decending # directory paths are allow, but not any ascending ones. Be sure to enclose in # single quotes. our $script_list = ''; # Where the servers will listen. If you don't know what this is, best to # set at either 8080 or its less common alternate of 8888. A default of 8080 # if left SERVER completely unset. our $local_port = ''; # User's own default encryption key for startup. # If left empty will fall back to GUS::Crypt package default. our $cipher_key = ''; # Password which will be required of clients requesting any method at all. Options # given on the command line will override. A default of 'XML-RPC' will be imposed # if left completely unset. our $plain_pw = ''; # In the method 'add_doc_elsewhere' server receives a doc from the client for # storage not in the same directory as $safe_list, but 'elsewhere'. The locatioin # of 'elsewhere' is chosen by regex. Here is the hash of such 'elsewhere' paths. # The key to each individual 'elsewhere' is itself the regex string used to match # docs to that path. my %elsewhere = (); # Should server start by Comannd Line with a GUI for setup? # Boolean: 0 = CLI; 1 = Tk GUI my $gui_flag = 1; # NOTE: Any of the above user-options may be overridden by other values if # started on command line or by script. For info, start on command line as # exampled below (or use pull-down menu 'help -> options')... # EXAMPLE: perl gus_xml-rpc_server.pl --help # Whether and how much of transactions to log. # Integer: 0 = None; 1 = Some; 2 = More. my $log_level = 1; # How many logs to keep (when logging at all). # Boolean: 0 = Same always; 1 = One per session. my $log_multi = 0; # Where to keep logs (when logging at all). # Defaults to same directory as $script_list if left empty. our $log_path = ''; # Mainly for convenience of author during testing. Others # may ignore, delete or modify to suit own paths and domains. if ($host_name =~ /(amalekite|paulstra|milcom|mtslf5-8)/) { # Update documentation. GUS::Document::make_html(); # Some of author's test PCs. if ( $host_name =~ /amalekite/ ) { $script_list = '/home/aplonis/gus_pl/gus_xml-rpc_pl/safe_list.txt'; # Match *.log or *.txt docs from PCs at Paulstra to a path for Apache. %elsewhere = ( '.*\.(txt|log)$' => '/usr/pkg/share/httpd/htdocs/paulstra', '.*\.sql$' => '/usr/pkg/share/httpd/htdocs/sql', ); } else { $script_list = 'C:/XML-RPC/safe_list.txt'; %elsewhere = ( '.*\.log$' => 'C:/', '^(safe_list|server_urls)\.txt$' => 'C:/XML-RPC', ); } unlink('C:/XML-RPC/*~~') } ######################################### # END THINGS USER CAN AND SHOULD CHANGE # ######################################### # BEGIN DO-NOT-EXECUTE ARRAYS # ############################### # Here are RegExen for use with the 'execute_command' method. # Include any such fragments of commands which you want to insure # may not be remotely executed. Here I provide just the very start # of what will grow into a more comprehensive list. Feel free to # add to it. my @scary_on_unix = ( 'kill -9', 'rm -R', 'root', 'su\s', 'sudo',); my @scary_on_win32 = ( '\s?cmd(\.exe)?', 'format', 'restore'); # Auto-selects which set of terms to use on startup. my @do_not_execute = ($^O =~ /Win32/i)? @scary_on_win32: @scary_on_unix; ############################# # END DO-NOT-EXECUTE ARRAYS # ############################# # BEGIN FALLBACK DEFAULTS # ########################### # For when left completely unset at startup. $local_port = 8080 unless $local_port =~ /[0-9]+/; $host_name = '127.0.0.1' unless $host_name =~ /[0-9|A-Z|a-z]+/; $plain_pw = 'XML-RPC' unless $plain_pw =~ /[0-9|A-Z|a-z]+/; ######################### # END FALLBACK DEFAULTS # ######################### # PRE-OPTION SECURITY # ####################### # Note: These checks performed ahead of options because # otherwise @ARGV will have been shifted empty. # For when starting out with scripted-in values. # Need to know when they are only semi-secure # due to being scripted in (aka documented). my $startup_cipher_key = $cipher_key; my $startup_plain_pw = $plain_pw; # For when starting out with cipher key from @ARGV. # So that methods are not restricted on the above # assumption. foreach (@ARGV) { $startup_cipher_key = '' if $_ =~ /--cipher_key/; $startup_plain_pw = '' if $_ =~ /--password/; } ########################### # END PRE-OPTION SECURITY # ########################### # BEGIN OPTION OVERRIDES # ########################## # For when options are given at startup on the command line. my $help_flag = 0; &GetOptions( "local_port=i" => \$local_port, "script_list=s" => \$script_list, "cipher_key=s" => \$cipher_key, "password=s" => \$plain_pw, "gui=i" => \$gui_flag, "help=i" => \$help_flag, ); ######################## # END OPTION OVERRIDES # ################################### # BEGIN STARTUP SECURITY MEASURES # ################################### my $cipher; my $methods_href; my $md5; my $cipher_key_usage = 0; my $cipher_key_usage_warn = 50; # Below are the clear-text XML-RPC method method used in subroutine definitions. # Severly obfuscated variants thereof are what appear in network transmission. # This single list drives first the obfuscation hash, then the methods hash. my @method_names = qw( server_status server_log change_password change_cipher execute_command execute_script add_new_script add_doc_elsewhere remove_doc_elsewhere remove_scripts reboot_server kill_server relay_sql_query ); # Here is the hash where obfuscated method name variants will be stored. my %obfuscated; my $obfuscation_size = 32; # Char length of values therein. Used twice! # Make all keys of hash into same-length gibberish. sub mk_obfuscation_hash { my $length = shift; my %hash; # Salt the input so will not be same every time. my $salt; $salt .= substr($plain_pw, 0, 3) if $plain_pw; $salt .= substr($cipher_key, 0, 3) if $cipher_key; foreach (@_) { $hash{$_} = GUS::Crypt::obfuscate( $salt . $_, $length, ); } return %hash; } # Methods used by the server defined in an external sub so that # may be done again whenever cipher key is changed. sub obfuscate_methods { %obfuscated = mk_obfuscation_hash($obfuscation_size, @method_names); # Create an obfuscated methods hash. Keys are all gibberish while # values are references to actual methods. my %methods_hash; foreach (@method_names) { $methods_hash{$obfuscated{$_}} = \&{$_}; } return %methods_hash; } # Cobble together a log file name. my $log_fh; my $log_full_path; sub init_log { # $log_fh->close() if defined $log_fh; if ( $log_level ) { my $name = $host_name . '_server'; $name =~ s/\./_/g; # Lose dots from URL. # Some OSes disallow filenames to start with numerals. $name = "URL_$name" if $name =~ /^[0-9]+/; # If new log each session, append date-time group. $name .= '_' . format_DTG(time, 1) if $log_multi; # If left empty by user, revert to common directory. $log_path = $script_path unless $log_path =~ /[a-z|A-Z|0-9|_]+/; $log_full_path = "$log_path/$name.log"; $log_fh = new Log::Logger "$log_full_path" or print "Oops! Sub 'init_log' reports could not init file handle.\n"; } } # Write output to log depending on user-choice logging level. sub log_this { $log_fh->log( format_DTG(time, 0) . "\n$_[0]") if $log_level - $_[1] >= 0; } # Store MD5 digests of each designated safe script. my %script_digests; # Compose MD5 digest of single script. sub digest_one_script { my ($name) = @_; my $reply; my $digest; # Quicky test lest digest crash on phantom file. my $bool = open FOO, "<$script_path/$name"; close FOO; if ($bool && $md5->addpath("$script_path/$name")) { $digest = file_md5_base64("$script_path/$name"); $script_digests{"$name"} = $digest; $reply .= "Okay! Got MD5 digest: $digest from '$name'\n"; } else { $reply .= "Oops! Sub 'digest_one_script' reports that MD5 cannot digest file '$name' " . "from list at '$script_list': $!\n" ; } return $reply; } # Compose MD5 digest for each script in list. sub digest_all_scripts { my $reply; %script_digests = (); if (opendir OWN_PATH, $script_path){ my @file_list = sort readdir(OWN_PATH); foreach (@file_list) { $reply .= digest_one_script($_) if $_ =~ /^gus_xml-rpc_.*pl/; } closedir OWN_PATH; } else { $reply .= "Oops! Sub 'digest_all_scripts' could not open directory '$script_path'.\n" } my $ascii_pound = "\043"; # Confuses editor syntax highlighting. if ( open LIST_FILE, $script_list ) { while ( my $name = ) { next if $name =~ /^$ascii_pound/; $name = sans_quotes_and_args($name); next unless $name =~ /$okay_regex/; $reply .= digest_one_script($name) unless exists $script_digests{$name}; } } else { $reply .= "Oops! Sub 'digest_all_scripts' could not open file '$script_list'.\n" } return $reply; } ################################# # END STARTUP SECURITY MEASURES # ################################# # Sub used in command-line option overrides. sub quick_help { my $help_msg = < \$local_port, "script_list=s" => \$script_list, "cipher_key=s" => \$cipher_key, "password=s" => \$plain_pw, "gui=i" => \$gui_flag, "help=i" => \$help_flag, OPTIONS: --l[ocal_port] Default local port --s[cript_list] Text file listing 'execute_script' methods --c[ipher_key] Text key for Blowfish encryption --p[assword] Password required of clients --g[ui] Startup: 1 = GUI or 0 = CLI --h[elp] This message EXAMPLES (long): gus_xml-rpc_server.pl --dir_path '/foo/bar/' gus_xml-rpc_server.pl --script_list 'blah.txt' gus_xml-rpc_server.pl --help gus_xml-rpc_server.pl --local_port 8888 gus_xml-rpc_server.pl --password 'foobar' EXAMPLE (short): gus_xml-rpc_server.pl --l 8888 --s 'blah.pl' --p 'XML-RPC' NOTE: If no command-line options given, scripted-in defaults apply. END_HELP_MSG print "$help_msg"; } # Create the cipher and ob15530fuscation hash. sub call_locksmith { my $cipher_key = shift; # Servers reply with a copy of their old cipher. So this client # change its cipher only now...after gathering all replies. $cipher = GUS::Crypt::brew_cipher( GUS::Crypt::grind_key($cipher_key, 56), 'Blowfish', 1); # Using the new cipher, obfuscate method names. %$methods_href = obfuscate_methods(); } # Init the XML-RPC server itself. sub server_start { my $local_port = $_[0]; my $log_text = ''; $script_path = dirname($script_list); init_log(); # Create the cipher and obfuscation hash. # Note: Current $plain_pw used as salt on hash. call_locksmith($cipher_key); # Get script name less path. my $script_name = $0; $script_name =~ s/.*[\\|\/]//; # Compose MD5 digests of all safe-to-script files on startup. $md5 = Digest::MD5->new; $log_text .= "MD5 digest results from file list '$script_list' follow:\n" . digest_all_scripts("$script_list") . "\n"; # Won't trip on GUS::Crypt default password due to '?' versus '!' on 'Oops'. # This is deliberate as startup with default key may be preferred. if ($log_text =~ /Oops!/) { $log_text =~ s/.*Oops/Oops/s; # Pop up GUI to get user config if any problems. GUS::GUI_Setup::start_MainLoop($log_text); } else { # Prepare startup entry for log. $log_text = "XML-RPC server startup as $0 and PID $$ on " . format_DTG(time, 0) . "\n" . "Listening at URL $host_name:$local_port/RPC2\n" . $log_text; # Log script startup and time if has not died. log_this( $log_text, 1 ); # Fire up the server with obfuscated method names. Frontier::Daemon->new( methods => $methods_href, LocalPort => $local_port, ) or die "Oops! Cannot start XML-RPC server: $!"; } # EXECUTION LIMBO: Post 'new' method of Frontier::Daemon module. } # Return Date Time Group. sub format_DTG { my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime($_[0]); # The ISO 8601 approved way for text. my $DTG = sprintf( "%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec ); # Or sans colons and spaces for file names. if ($_[1]) { $DTG =~ s/:/-/g; $DTG =~ s/\s/_/g; } return ("$DTG"); } # Common reply header for all methods. Time shows at left. sub server_reply_head { my $header = format_DTG(time, 0) . " XML-RPC server at $host_name:$local_port/RPC2 replies:\n"; return $header; } # Given a quoted file name and args, strip away # the quotes and args. sub sans_quotes_and_args { my $cmd = shift; # Strip off lead/trailing whitespace. $cmd =~ s/^\s+//; $cmd =~ s/\s+$//; # If starts with quote... if ($cmd =~ /^\047/) { $cmd = substr($cmd, 1); # Lose 1st quote. $cmd =~ s/\047.*//; # Strip 2nd quote to end. } else { $cmd =~ s/\s.*//; # Strip 1st space to end. } return $cmd; } # Check if candidate script exists on list of those allowed. sub check_if_known { my $name = shift; my $list_file = "$script_list"; my $reply = "Oops! File '$name' not found in list '$list_file'. "; if (exists $script_digests{$name}) { $reply = "Okay! File '$name' found as key in hash of MD5 digests.\n"; } elsif ( open SAFE, $list_file ){ while () { $_ =~ s/^\s+//; # Strip LH whitespace. $_ =~ s/\s+$//; # Strip RH whitespace. if ( $name eq $_ ) { $reply = "Okay! File '$name' listed in $list_file.\n"; last; } } } else { $reply = "Oops! Could not open list '$list_file'.\n"} return $reply; } # Check if file modified after server startup. sub check_if_modified { my $file_name = $_[0]; my $reply = ''; # Compare current MD5 digest against that from startup or # from addition via add_new_script method. my $digest = file_md5_base64("$script_path/$file_name"); if ($digest eq $script_digests{$file_name}) { $reply .= "Okay! File '$file_name' unmodified. Its MD5 digest still matches exactly.\n"; } else { $reply .= "Oops! File '$file_name' modified. Non-matching MD5 digest: '$digest'\n"; } return $reply; } # Open, read in, and return lines from supposed pure-ASCII file. # Called as sub inside &check_ascii_only defined below. sub read_in_script { my $file_name = shift; my @file_lines; if ( open TEXT, "<$script_path/$file_name" ) { my @items_list = (); while () { $_ =~ s/\s*$//; # Chomp as if from another OS. push @file_lines, "$_\n"; } return @file_lines; } else { return ("Oops! Sub 'read_in_script' could not open script '$file_name': $!"); } } # Given a string, return 0 if pure ASCII, 1 otherwise. sub check_for_binary { my $bin_flag = 0; my @bytes = split '', $_[0]; foreach (@bytes) { next if $_ =~ /\s/; if (ord($_) < 32) { ++$bin_flag; last; } elsif (ord($_) > 126) { ++$bin_flag; last; } } return $bin_flag; } # Get lines from file, test if pure ASCII or not. sub check_ascii_only { my $reply = ''; my $file_name = $_[0]; my @file_lines = read_in_script($file_name); my $bin_cnt = 0; # Parse file looking for non-ASCII bytes. if ($file_lines[0] =~ /^Oops!/) { return shift(@file_lines) } else { foreach my $line (@file_lines) { last if $bin_cnt; # Waste no more time. $bin_cnt += check_for_binary($line); } # Continue if pure ASCII. Complain otherwise. if ($bin_cnt == 0) { return "Okay! File '$file_name' is pure ASCII.\n" } else { return "Oops! Sub 'check_ascii_only' found non-ASCII inside script '$file_name'.\n"} } } # Decide whether a given file is safe to script. sub check_script_safety { my $reply = ''; my $ref = $_[0]; # The scalar containing script is modified in place as a reference. $$ref =~ s/^\s+//; # Strip LH whitespace. $$ref =~ s/\s+$//; # Strip RH whitespace. $$ref =~ s/\.+/\./g; # Forbid ascending paths. # Prevent non-text scripts and binaries. my $sqaa = sans_quotes_and_args($$ref); # So can check script alone. $reply .= "Oops! Script '$$ref' failed file-type RegEx as !~ /$okay_regex/.\n" if $sqaa !~ /$okay_regex/; $reply .= check_ascii_only($sqaa); # Script pure ASCII? $reply .= check_if_known($sqaa); # Script known to server? $reply .= check_if_modified($sqaa); # Script modified since startup? $$ref =~ s/$sqaa//; # Strip out command. $$ref =~ s/^\047\s*\047//; # Strip out leading empty quotes. $$ref = qq|"$script_path/$sqaa" | . $$ref; # Prepend safe scripts path. $$ref =~ s/\s*$//; # Tidy up end space if no args. $$ref =~ s/\/\//\//g; # Tidy up double slashes. $$ref =~ s/\//\\/g if $^O =~ /Win32/i; # Translate / into \ for Win32. return ($reply); } # Show current MD5 digests. sub current_md5_digests { no warnings; # File may have blank/empty lines. my $reply = ''; my @list = sort keys %script_digests; foreach (@list) { $reply .= "\t$script_digests{$_} $_ \n" } my $ascii_pound = "\043"; # Confuses editor syntax highlighting. if ( open SAFE, "$_[0]" ) { while () { next if $_ =~ /^$ascii_pound/; $_ = sans_quotes_and_args($_); next unless $_ =~ /$okay_regex/; $reply .= "Oops! Script '$_' lacks a current MD5 digest. \n" unless exists $script_digests{$_}; } } return $reply; } # Search add unlink all scripts matching supplied Reg Exp. # Remove their keys from relevent hashes. sub delete_matching_scripts { my $reg_exp = shift; my $i = 0; my $replies .= "Deleting by RegExp match /$reg_exp/ from path '$script_path':\n"; foreach (keys %script_digests) { next unless $_ =~ /$reg_exp/; if (unlink "$script_path/$_") { $replies .= "\tOkay! File '$_' deleted from path '$script_path'.\n"; delete $script_digests{"$_"}; ++$i; } else { $replies .= "\tOops! Could not delete script $_.\n"; } } $replies .= "\tOkay! Total files deleted: $i\n"; log_this($replies, 1); return $replies; } # Output a new list file sans deleted script so that # next reboot will not crash on failure to locate same. sub shorten_list_file { my $reg_exp = shift; my @scripts; my $reply = ''; # Get list of executable scripts, excepting any matches. if ( open LIST, "<$script_list" ){ while () { push @scripts, $_ unless $_ =~ /$reg_exp/ } close LIST; sleep 5; # Write new, shorter list file. if ( open LIST, ">$script_list" ){ foreach (@scripts) { print LIST $_ } close LIST; } else { $reply .= "Oops! Sub 'shorten_list_file' could not re-write file '$script_list': $!"; } } else { $reply .= "Oops! Sub 'shorten_list_file' could not read file '$script_list': $!"; } return $reply; } # Start the server with or without GUI. if ($gui_flag) { GUS::GUI_Setup::start_MainLoop("Version: $formal_date") } else { server_start($local_port) } ################################ # Begin XML-RPC server methods # ################################ # Note that user password is last arg to all methods. # A default template for new server methods. Not used by # server. An example for you is all that it is. sub method_template { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { $reply .= "Say something about success here.\n"; log_this($reply, 1); } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Return server status to client sub server_status { my $reply = check_cipher_key($_[-1]); # Get script name less path. my $script_name = $0; $script_name =~ s/.*[\\|\/]//; if ( $reply !~ /Oops!/) { $reply .= "Running as $script_name version $formal_date and PID $$ under OS $^O\n" . "Listening at http://$host_name:$local_port/RPC2 since " . format_DTG($^T, 0) . "\n" . "List of MD5 digests for executable scripts follows:\n" . current_md5_digests(); log_this($reply, 2); } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 1); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Send back current log, if any. sub server_log { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { if ($log_level > 0) { $reply .= "Current server log follows:\n"; $reply .= fetch_log(); } else { $reply .= "Sever logging not enabled.\n";} } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } sub fetch_log { my $reply = ''; if (open LOG, "<$log_full_path") { while () { $reply .= $_ } } else { $reply .= "Oops! Could not open file '$log_full_path': $!" } return $reply; } # Change the password of running server. If starting up via script such that # documented startup values for cipher key and password see actual use, this # should be the first thing a user does via the client...followed immediately # by changing the cipher key. That hassle can be avoided by using the GUI # startup which insures unique, non-documented values for better security. sub change_password { my $reply = ''; if ( $reply !~ /Oops!/) { $plain_pw = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); $reply .= "Password has been changed.\n"; log_this($reply, 1); } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Change the encryption key of running server. sub change_cipher { # First-time change of cipher key should after first-time change of password # because the password is used as salt for method obfuscation. my $reply = check_password($_[-1]); my $cipher_old = $cipher; if ($plain_pw eq GUS::Crypt::gus_crypt( $cipher, $_[-1], 'decrypt', 64)) { $cipher_key = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); call_locksmith($cipher_key); $cipher_key_usage = 0; $reply .= "Cipher key has been changed.\n"; log_this($reply, 1); } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher_old, $reply, 'encrypt', 64); } # The execute_script method requires a RegEx to winnow what kind of # scripts it can run. Below is how it assembles that test. The RegEx # is more efficiently assembled at start-up than within the subroutine. BEGIN { # Create test for allowed okay-to-execute scripts. @okay_scripts = qw( php pl py rb tcl); my @okay_for_win32 = qw( cmd bat ); my @okay_for_Unix = qw( awk csh ksh sed sh ); # If running on Win32 use these... if ($^O =~ /win32/i) { push @okay_scripts, @okay_for_win32 } else { push @okay_scripts, @okay_for_Unix } # Now cobble a RegEx out from above. $okay_regex = '\.(' . (join '|', @okay_scripts) . ')$'; } # Report if the cipher key has been left at its startup default. sub check_cipher_key { no warnings; my $crypt_pw = shift; my $reply = ''; unless ($plain_pw eq GUS::Crypt::gus_crypt($cipher, $crypt_pw, 'decrypt', 64)) { $reply .= "Oops! Password not recognized.\n"; } if ($cipher_key eq $GUS::Crypt::DEFAULT_KEY) { $reply .= "Oops! Cipher key still at very insecure default setting.\n"; } if ($cipher_key eq $startup_cipher_key) { $reply .= "Oops! Cipher key still at only semi-secure startup setting.\n" unless $GUS::GUI_Setup::gui_cipher_key; } if ($cipher_key_usage > $cipher_key_usage_warn) { $reply .= "Note! Cipher key used $cipher_key_usage times. Time to change?\n"; } return $reply; } # Report if the pasword has been left at its startup default. sub check_password { no warnings; my $crypt_pw = shift; my $reply = ''; unless ($plain_pw eq GUS::Crypt::gus_crypt($cipher, $crypt_pw, 'decrypt', 64)) { $reply .= "Oops! Password not recognized.\n"; } if ($plain_pw eq $startup_plain_pw) { $reply .= "Oops! Password still at only semi-secure startup setting.\n" unless $GUS::GUI_Setup::gui_plain_pw; } return $reply; } # Forbid things too scary for remote execution. sub check_command_safety { my $command = shift; my $reply = ''; foreach (@do_not_execute) { next unless $command =~ /$_/; $reply .= "Oops! Sub 'check_command_safety' found RegEx match /$_/ in command. \n"; } return $reply; } # Run almost any command passed by the client. sub execute_command { my $reply = check_cipher_key($_[-1]); my $fdbk_1 = my $fdbk_2 = ''; if ( $reply !~ /Oops!/) { my $command = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); log_this("Method 'execute_command' called for string '$command'", 1); # If deemed unsafe holds 'Oops!' complaint. $reply .= check_command_safety($command); # If no complaint from safety check... if ($reply =~ /Oops!/) { $reply .= "Oops! Sub 'execute_command' has refused '$command'!\n"; } else { no warnings; # Feedback might be empty. # Because may be exessive length, keep out of reply until after # logging. $fdbk_1 .= "Feedback from execution of '$command' follow:\n"; eval { $fdbk_1 .= `$command` }; # FIX THIS: The lines below report false errors on Win32. if ($?) { $fdbk_2 .= "Oops? Possible error: '$!'\n" } # if ($^E) { $reply .= "Oops! Backtick failed: '$^E'\n" } } # Special treatment of sub log_level due to exess feedback. if ( $log_level > 1 ) { log_this("$reply\n$fdbk_1\n$fdbk_2", 2) } else { log_this("$reply\n$fdbk_2", 1) } $reply .= "$fdbk_1\n" if $fdbk_1; $reply .= "$fdbk_2\n" if $fdbk_2; } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Run any script w/args passed by the client, provided that... sub execute_script { my $reply = check_cipher_key($_[-1]); my $fdbk_1 = my $fdbk_2 = ''; if ( $reply !~ /Oops!/) { my $script = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); log_this("Method 'execute_script' called for string '$script'", 1); # If deemed unsafe holds 'Oops!' complaint. $reply .= check_script_safety(\$script); # If no complaint from safety check... if ($reply =~ /Oops!/) { $reply .= "Oops! Sub 'execute_script' has refused '$script'!\n"; } else { no warnings; # Feedback might be empty. # Because may be exessive length, keep out of reply until after # logging. $fdbk_1 .= "Feedback from execution of '$script' follow:\n"; eval { $fdbk_1 .= `$script` }; # FIX THIS: The lines below report false errors on Win32. if ($?) { $fdbk_2 .= "Oops? Possible error: '$!'\n" } # if ($^E) { $reply .= "Oops! Backtick failed: '$^E'\n" } } # Special treatment of sub log_level due to exess feedback. if ( $log_level > 1 ) { log_this("$reply\n$fdbk_1\n$fdbk_2", 2) } else { log_this("$reply\n$fdbk_2", 1) } $reply .= "$fdbk_1\n" if $fdbk_1; $reply .= "$fdbk_2\n" if $fdbk_2; } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Undo the all_in_one combining done by client. # Called in sub &add_new_script defined below. sub rectify_sent { # Swap nulls for line separator of this OS. $_[0] =~ tr/\000/\n/; my $name = my $buff = shift; $name =~ s/\n.*//g; # Strip away 2nd thru Nth lines. $buff =~ s/$name\n//; # Strip away 1st line. return ($name, $buff); } sub chmod_on_shebang { my $name = shift; my $buff = shift; # Get whole script. $buff =~ s/\n.*//g; # Keep top line only. my $reply = ''; my $bool = 0; # Assume no shebang. # Test against each allowed: *.pl, *.py, etc.. foreach (@okay_scripts) { $_ =~ s/^p(l|m)$/perl/; $_ =~ s/^py$/python/; $_ =~ s/^rb$/ruby/; ++$bool if $buff =~ /^#\!\/(usr\/)*(pkg\/)*bin\/$_/; } if ($bool) { if ( chmod(0700,"$script_path/$name") ) { $reply .= "Okay! Successful chmod 0700 to '$buff'.\n"; } else { $reply.= "Oops! Cannot chmod 0700 on '$buff': $!\n" } } else { $reply .= "Oops! Top line of '$buff' is unfamiliar shebang.\n" } return $reply; } # Keep script and append its name to local list of executable scripts. sub absorb_script { my $name = shift; my $buff = shift; my $reply = ''; # First try to (over-)write the script itself. if ( open SCRIPT, ">$script_path/$name" ){ print SCRIPT "$buff"; close SCRIPT; # If already in digest, then also on list. Avoid duplicates. unless (exists $script_digests{$name}) { # Then append its name to the list of executable scripts. if ( open LIST, ">>$script_list" ){ print LIST "$name\n"; close LIST; # If a UNIX box, test for shebang and make executable. $reply .= chmod_on_shebang($name, $buff) unless $^O =~ /Win32/i; } else { $reply .= "Oops! Sub 'absorb_script' could not append '$name' to '$script_list': $!"; } } # Compose a new(er) MD5 digest of newly (over)written script. $reply .= digest_one_script($name); } else { $reply .= "Oops! Sub 'absorb_script' could not write to file path '$script_path/$name': $!"; } return $reply; } # Add a new script for use with the 'execute_script' method. sub add_new_script { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { my ($name, $buff) = rectify_sent( GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64), ); $reply .= absorb_script($name, $buff); log_this("Sub 'add_new_script' reports: $reply.", 1) if $reply !~ /Oops!/; } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Add a new file to a path outside that used for scripts by thte server. # In other words, put the doc not here, but somewhere 'else', such as for # an Apache server, etc. sub add_doc_elsewhere { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { my $all_in_one = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); my ($name, $buff) = rectify_sent($all_in_one); if (my $where = where_else($name) ) { $reply .= move_elsewhere("$where/$name", $buff); } else { $reply .= "Oops! Sub 'where_else' reports '$name' matched no known RegEx.\n"; } log_this("Sub 'add_doc_elsewhere' reports: $reply.", 1) if $reply !~ /Oops!/; } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Keep script and append its name to local list of executable scripts. sub move_elsewhere { my $full_path = shift; my $buff = shift; my $reply = ''; # First try to (over-)write the script itself. if ( open DOC, ">$full_path" ){ my @lines = split "\n", $buff; foreach (@lines) {print DOC "$buff\n"} close DOC; $reply .= "Okay! Sub 'move_elsewhere' wrote file to path '$full_path': $!"; } else { $reply .= "Oops! Sub 'move_elsewhere' could not write to file path '$full_path': $!"; } return $reply; } # Determine which among the authorized 'elsewhere' directories # a submitted doc belongs. sub where_else { my $name = shift; my $where = ''; foreach (keys %elsewhere) { next unless $name =~ /$_/; $where = "$elsewhere{$_}"; last; } return ($where); } # Add a new file to a path outside that used for scripts by thte server. # In other words, put the doc not here, but somewhere 'else', such as for # an Apache server, etc. sub remove_doc_elsewhere { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { my $name = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); if (my $where = where_else($name) ) { if (unlink("$where/$name")) { $reply .= "Okay! File '$where/$name' unlinked.\n" } else { $reply .= "Oops! Could not unlink file '$where/$name': $! \n"} } else { $reply .= "Oops! Sub 'where_else' reports '$name' matched no known RegEx.\n"; } log_this("Sub 'remove_doc_elsewhere' reports: $reply.", 1) if $reply !~ /Oops!/; } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Remove one or more scripts entirely from the server PC. sub remove_scripts { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { my $reg_exp = GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); $reply .= delete_matching_scripts($reg_exp); $reply .= shorten_list_file($reg_exp); log_this("Sub 'remove_scripts' reports: $reply.", 1) if $reply !~ /Oops!/; } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Have the XML-RPC server die and restart itself. Client will see an error # since there can be no reply when server dies. sub reboot_server { my $reply = check_cipher_key($_[-1]); my $prefork_pid = $$; # Safety precauiton. my $boot_script = 'gus_xml-rpc_reboot.pl'; $reply .= check_script_safety(\$boot_script); if ( $reply !~ /Oops!/) { # Reboot the server if okay so far. unless ( $reply =~ /Oops/ ) { if ($^O =~ /Win32/i) { # Note: Since this is a string, not a list, any scalars # which are empty, may cause problems. Make sure empty # scalars are represented by empty double-quotes. my $win32_cmd = "wperl.exe $boot_script " . "$script_path $script_list " . "$local_port $prefork_pid " . qq|$plain_pw "$cipher_key"|; # Key might be empty! $reply .= win32_create_process($win32_cmd); } elsif ( defined( my $kid = fork )) { unless ($kid) { # Remove quotes so won't be double quoted for next. $boot_script =~ s/\042//g; # Launch the external update/restart script. system( "perl", "$boot_script", "$script_path", "$script_list", "$local_port", "$prefork_pid", "$plain_pw", "$cipher_key", ); } $reply .= "Okay! Unix forked new process for $boot_script.\n"; } else { $reply .= "Oops! Could not fork new process for $boot_script.\n"; } log_this($reply, 1); } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } # Launch a new process the Win32 way. sub win32_create_process { my $win32_cmd = shift; require Win32::Process; require Win32; no strict; my $reply = ''; my $obj; if ( Win32::Process::Create( $obj, 'C:\Perl\bin\wperl.exe', "$win32_cmd", 0, NORMAL_PRIORITY_CLASS, ".") ) { $reply .= "Okay! New Win32 process created for server reboot.\n"; } else { $reply .= "Oops! " . Win32::FormatMessage( Win32::GetLastError() ); } return $reply; } # Have the XML-RPC server kill itself. Client should see an error # since there can be no reply. sub kill_server { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { log_this("Shutdown of XML-RPC server at URL $host_name:$local_port/RPC2.", 1); kill 15, $$; sleep 5; kill 2, $$; sleep 5; kill 9, $$; $reply .= "Oops! Sub 'kill_server' reports failure to die on command.\n"; log_this($reply, 1); } else { $reply .= "Oops! Access denied.\n"; log_this($reply, 2); } # Note: If killed, as above, will not get down to here. $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } sub relay_sql_query { my $reply = check_cipher_key($_[-1]); if ( $reply !~ /Oops!/) { my ($db, $db_user, $db_pswd, $db_qry) = split /\000/, GUS::Crypt::gus_crypt( $cipher, $_[0], 'decrypt', 64); log_this($reply, 1); $reply .= "\000" . GUS::relay_sql::db_connect($db, $db_user, $db_pswd); unless ($reply =~ /Oops/) { $reply .= "\000" . GUS::relay_sql::db_pass_query($db_qry); $reply .= "\000" . GUS::relay_sql::db_disconnect(); } } else { $reply .= "Oops! Access denied.\n" . "\000 \000 \000"; log_this($reply, 2); } $reply = server_reply_head() . $reply; return GUS::Crypt::gus_crypt( $cipher, $reply, 'encrypt', 64); } ############################## # End XML-RPC server methods # ############################## END { log_this("Shutdown of XML-RPC server at URL $host_name:$local_port/RPC2.", 1); $log_fh->close(); } ######################## # Begin GUS::relay_sql # # Version 2005-11-13 # ######################## # Purpose is to take advantage of XML-RPC # for bridging firewalls and for encryption. package GUS::relay_sql; use DBI; use vars qw( $dbh0 $col_delimiter ); BEGIN { $col_delimiter = ' | '; } # Feedback any database errors after DBI 'sth0->execute' command. my $fdbk; sub dbi_fdbk { my ($good_news, $bad_news) = @_; if ($DBI::err) { $fdbk = "$bad_news $DBI::errstr"; } else { $fdbk = "$good_news"; } } # Query the SQL server for its own current date and time. my $now = ""; sub get_now { # Perform a SELECT to learn current year. my $sql_qry = qq{ SELECT now() }; my $sth0 = $dbh0->prepare( $sql_qry ); $sth0->execute; dbi_fdbk("Query for date and time","get_now sth0"); ($now) = $sth0->fetchrow_array; $sth0->finish; } # Connect to SQL database. # NOTE: Unless your DB is PostgreSQL, then you will have to tailor the first item # of the connect script for a different DBD (dbi:foo:bar) and however it is that # your own DB passes in the database name. sub db_connect { my ($data_base, $user_name, $pass_word) = @_; $dbh0 = DBI->connect( "dbi:Pg:dbname=$data_base", "$user_name", "$pass_word" ); &dbi_fdbk( "Connected.", "Connect failed at sub 'db_connect'." ); return $fdbk; } # Disconnect from SQL database. sub db_disconnect { $dbh0->disconnect(); dbi_fdbk( "Disconnected.", "Disconnect failed at sub 'db_disconnect'."); return $fdbk; } # Handle direct SQL queries. sub db_pass_query { my $sql_qry = qq{$_[0]}; my $sql_rsp = ''; my $row_cnt = -1; my @row = (); if ( $sql_qry =~ m/^\s+USE\s+.*/i ) { $fdbk = "WARN: SQL command 'USE' trapped by RegEx. May not switch databases."; } elsif ( $sql_qry =~ m/^(--.*\n)*\s*SELECT.*/i ) { # Above tests for SELECT statement optionally preceded by comments. # Sans any SELECT there will be no rows to fetch. my $sth0 = $dbh0->prepare($sql_qry); $sth0->execute(); dbi_fdbk('Okay! ','Oops! '); my @rows; my @widths; # Get col-name row and track column widths for same. push @rows, $sth0->{NAME}; for (my $i=0; $i<=$#{$rows[0]}; ++$i) { $widths[$i] = length "${$rows[0]}[$i]"; # Init each col width to own col name. } # Get data rows and track column widths for justification while ( my @cols = $sth0->fetchrow_array ) { no warnings; for (my $i=0; $i<=$#cols; ++$i) { $widths[$i] = length "$cols[$i]" if $widths[$i] < length "$cols[$i]"; # Col may be empty! } push @rows, \@cols; } $sth0->finish(); # Justify columns. while (@rows) { my $cols_ref = shift @rows; for (my $j=0; $j<=$#$cols_ref; ++$j) { no warnings; $cols_ref->[$j] = sprintf "%$widths[$j]s", $cols_ref->[$j]; } my $sql_row = join "$col_delimiter", @$cols_ref; # Make divider row under column-name header. if ($row_cnt == -1) { my $div_row = $sql_row; $div_row =~ s/./=/g; $sql_row .= "\n$div_row"; } ++$row_cnt; $sql_rsp .= "$sql_row\n"; } $fdbk .= $sth0->rows() . ' rows affected'; } else { $dbh0->do($sql_qry); dbi_fdbk('Okay! ','Oops! '); $sql_rsp = "No rows returned"; } # Show how many rows returned. $sql_rsp = "Oops! SQL error...\n" if $fdbk =~ /Oops/; $fdbk =~ s/\n+$//; $fdbk =~ s/\s+/ /g; return "$sql_rsp\000$fdbk."; } ###################### # End GUS::relay_sql # ############################# # Begin GUS::Crypt Package # # Version 2006-06-20 # ############################# package GUS::Crypt; use Crypt::CBC; use MIME::Base64; use strict; use vars qw( $DEFAULT_KEY $reply); BEGIN { # Default encryption key for startup defined here so that # it will pre-exist for a sub definition below. $GUS::Crypt::DEFAULT_KEY = "You must not fight too often with one enemy " . "or you will teach him all your art of war. " . "Napoleon Bonaparte"; } # When provided string is empty, supply a default. # When provided string is too short, re-double until long enough. # If too long, keep middle part thereof (slightly more random). sub grind_key { my ($s, $size ) = @_; # If undefined or empty, use default. # The '?' vesus '!' after 'Oops' in reply is deliberate. unless ( defined($s) && ($s ne '')) { $reply = "Oops? String for user's own custom encryption key undefined or empty.\n"; $reply .= " Using built in \$GUS::Crypt::DEFAULT_KEY as fallback.\n"; print $reply; $s = $GUS::Crypt::DEFAULT_KEY; } # If too short, lengthen it. while (length($s) < $size) {$s .= $s } # If string too long, keep only center part. if (length($s) > $size) { my $i = int( (length($s) - $size ) / 2); $s = substr($s, $i, $size); } # Ciphers want their key as binary, not ASCII. return pack("a*", $s); } # The initialization vector is allowed to be different for en- versus de-crypting. # Pseudo-randomly choose form the 87 printable ASCII characters above ordinal 32. sub rand_string { my $s = ''; while ( length($s) < $_[0] ) { $s .= chr(int(rand(87)) + 32) } return $s; } # Generate the cipher. Refer to Crypt::CBC module for details. sub brew_cipher { Crypt::CBC->new( # Version 2.17 tested only. { 'key' => $_[0], # Packed as binary string. 'cipher' => $_[1], # 'Blowfish', 'Rijndael', 'IDEA', etc. 'regenerate_key' => $_[2], # False for as-is. True for MD5 hash thereof. 'header' => 'randomiv', 'iv' => rand_string(8), 'padding' => 'space', 'prepend_iv' => 1 } ); } # All-in-one sub to encrypt or decrypt. # SYNOPSIS 1: gus_crypt( $ascii_key, $plaintext, 'encrypt', 64); # SYNOPSIS 2: gus_crypt( $ascii_key, $ciphertext, 'decrypt', 64); sub gus_crypt { my ($cipher, $thru, $how, $base) = @_; die "Oops! Scalar \$how !~ /(en|de)crypt/ in sub gus_crypt\n" unless $how =~ /(en|de)crypt/; if ($how eq 'decrypt') { $thru = decode_base64($thru) if $base == 64; } $cipher->start($how . 'ing'); $thru = $cipher->crypt($thru); $thru .= $cipher->finish(); if ($how eq 'encrypt') { $thru = encode_base64($thru) if $base == 64; } return $thru; } # Given an ascii name, derive an impossibly obfuscated variant. # Used for hash keys, etc., when transmitted in the clear. sub obfuscate { my ($s, $size) = @_; # Grow into Blowfish key. until ( length($s) > $size + 56) { $s .= crypt $s, substr($s, length($s) - 2); } $s = substr($s, $size, 56); # Encrypt the string. my $cipher = Crypt::CBC->new( # Version 2.17 tested only. { 'key' => pack("a*", $s), 'cipher' => 'Blowfish', 'header' => 'randomiv', 'iv' => substr($s, 0, 8), } ); $cipher->start('encrypting'); $s = $cipher->crypt($s); $s .= $cipher->finish(); # Keep only alphanums. $s = encode_base64($s); $s =~ s/![0-9|A-Z|a-z]//g; # Slice from center. if (length($s) > $size) { my $i; $i = int( (length($s) - $size ) / 2); $s = substr($s, $i, $size); } return $s; } # A cheap and dirty cypher for ascii text. Works # both ways with same key. Not very secure. Good # only for making stored passwords less guessable. sub xor_mask_ascii { my ( $key, $s ) = @_; my $msk = my $cfr = ''; # Make an xor-mask longer than the plaintext. while ( length $msk < length $s ) { $msk .= crypt $key, substr( $key, 0, 2 ); $msk = substr( $msk, 2, ((length $msk) - 1)); $key = $msk; } # Create the cypher by xor-ing with the mask. for ( my $i = 0; $i < length $s; ++$i ) { no warnings; $cfr .= chr( ord( substr( $msk, $i, $i + 1 ) ) ^ ord( substr( $s, $i, $i + 1 ) ) ); } return $cfr; } ########################## # End GUS::Crypt Package # ########################## # Begin GUS::Document # # Version 2005-09-08 # ####################### package GUS::Document; use Pod::Text; use Pod::Html; use File::Basename; use strict; use vars qw( $pod_path $text_path $html_path $pod_text ); BEGIN { $pod_path = $text_path = $html_path = dirname(__FILE__) . '/' . basename(__FILE__); $text_path =~ s/\.pl$/_pod.txt/; $html_path =~ s/\.pl$/.html/; } sub pod_as_text { my $parser = Pod::Text->new ( sentence => 0, width => 60, loose => 1, ); $pod_text = ''; # Perl 5.8 feature! # Opens filehandle to scalar. Needed because the # pod parser writes to STDOUT or to file. It does # not return any output. if ( open my $fh_1, '>', \$pod_text ) { if ( open my $fh_2, "<$pod_path" ) { my $select_save = select($fh_1); $parser->parse_from_filehandle($fh_2, $fh_1); select($select_save); close $fh_1; } else { $pod_text .= "Oops! Cannot open POD file: $!" } } else { $pod_text .= "Oops! Cannot open to scalar: $!" } return $pod_text; } sub make_html { system( 'pod2html', '--title', basename(__FILE__), '--backlink', 'Back to Top', '--outfile', $html_path, '--infile', $pod_path, ); my $rm_files = dirname(__FILE__) . '/pod2htm*'; if ($^O =~ /Win32/i) { $rm_files =~ s/\//\\/g; system("del $rm_files") } else { $rm_files =~ s/\\/\//g; system("rm $rm_files"); } print "New HTML: $html_path\n"; } ##################### # End GUS::Document # ########################### # Begin GUI Setup Package # ########################### package GUS::GUI_Setup; # Note 1: Useful only with the GUS XML-RPC Server. # Note 2: If no GUI desired, just delete this entire package. use Tk; use Tk::Balloon; use File::Basename; use strict; use warnings; # Declare items used by this package only. use vars qw( $mw $file_types $label_width $balloon_bg $balloon_fg $gui_script_list $gui_cipher_key $gui_plain_pw ); # Init values used by this package only. BEGIN { $label_width = 10; $balloon_bg = 'darkseagreen'; $balloon_fg = 'black'; $file_types = [ [ 'ASCII', '.txt', 'TEXT' ], [ 'Any', '*.*', 'TEXT' ] ]; } # Declare the main GUI frame and all her daughters. sub start_MainLoop { my $label_text = shift; $label_text =~ s/\n+$//; $gui_script_list = $main::script_list; $gui_cipher_key = $main::cipher_key; $gui_plain_pw = $main::plain_pw; $mw = MainWindow->new( -title => " XML-RPC Server" ); # Provide help info as balloon widgets. my $help_info = $mw->Label( -borderwidth => 2, -relief => 'groove', -background => $balloon_bg, -foreground => $balloon_fg, ); my $balloon = $mw->Balloon( -statusbar => $help_info, -balloonposition => 'mouse', -background => $balloon_bg, -foreground => $balloon_fg, ); $balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' ); my $label_1 = $mw->Label( -width => length("\n$label_text\n"), -text => "$label_text", )->pack( -side => 'top', -expand => 1, -fill => 'x'); $label_1->configure(-background => 'gold') if $label_text =~ /Oops/; $balloon->attach( $label_1, -balloonmsg => 'Info box.', -statusmsg => qq|Release date or startup error message appears at top.|); # Safe Scripts List Widgets my $frame_top = $mw->Frame( -relief => 'sunken', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x'); # Safe Scripts List Widgets my $frame_1 = $frame_top->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x'); $frame_1->Label( -width => $label_width, -text => " Safe List", )->pack( -side => 'left', -expand => 0); my $entry_1 = $frame_1->Entry( -textvariable => \$gui_script_list, -background => "white", -foreground => 'blue', -relief => 'sunken', -font => 'courier', )->pack( -side => 'left', -expand => 1, -fill => 'x'); $balloon->attach( $entry_1, -balloonmsg => 'Required *.txt file', -statusmsg => qq|List of scripts (in same directory) which clients may safely execute.|); $frame_1->Button( -text => 'Browse', -command => sub { $gui_script_list = $mw->getOpenFile( -filetypes => $file_types, -initialdir => dirname($gui_script_list), ); }, -background => 'gray', -activebackground => 'green', -relief => 'raised', )->pack( -side => 'left', -expand => 0); # Cipher Key Widgets my $frame_2 = $frame_top->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x'); $frame_2->Label( -width => $label_width, -text => "Cipher Key", )->pack( -side => 'left', -expand => 0); my $entry_2 = $frame_2->Entry( -textvariable => \$gui_cipher_key, -show => "*", -background => "white", -foreground => 'blue', -relief => 'sunken', -font => 'courier', )->pack( -side => 'left', -expand => 1, -fill => 'x'); $balloon->attach( $entry_2, -balloonmsg => 'ASCII pass phrase', -statusmsg => qq|For Blowfish encryption. Falls back to GUS::Crypt package default lf left blank.|); # Password Widgets my $frame_3 = $frame_top->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x'); $frame_3->Label( -width => $label_width, -text => " Password", )->pack( -side => 'left', -expand => 0); my $entry_3 = $frame_3->Entry( -textvariable => \$gui_plain_pw, -show => "*", -background => "white", -foreground => 'blue', -relief => 'sunken', -font => 'courier', )->pack( -side => 'left', -expand => 1, -fill => 'x'); $balloon->attach( $entry_3, -balloonmsg => 'Password', -statusmsg => qq|For client recognition. Falls back to 'XML-RPC' lf left blank.|); $help_info->pack( -side => 'top', -expand => 0, -fill => 'x' ); # Action Widgets my $frame_4 = $mw->Frame( -relief => 'flat', -borderwidth => 5)->pack( -side => 'top', -expand => 1, -fill => 'x'); $frame_4->Label( -width => $label_width, -text => " Action", )->pack( -side => 'left', -expand => 0); $frame_4->Button( -text => ' Start ', -command => \&gui_server_start, -background => 'gray', -activebackground => 'red', -relief => 'raised', )->pack( -side => 'left', -expand => 1, -fill => 'x'); $frame_4->Button( -text => ' Die ', -command => sub { $mw->destroy() if Tk::Exists($mw) }, -background => 'gray', -activebackground => 'green', -relief => 'raised', )->pack( -side => 'left', -expand => 1, -fill => 'x'); MainLoop; } sub gui_server_start { $main::script_list = $gui_script_list; $main::cipher_key = $gui_cipher_key; $main::plain_pw = $gui_plain_pw; $mw->destroy() if Tk::Exists($mw); main::server_start($main::local_port); } ######################### # End GUI Setup Package # ######################### __END__ =head1 NAME XML-RPC Server =head1 VERSION Release date = 2006-06-20 =head1 SYNOPSIS =head2 On Win32 running ActiveState Perl C =head2 On Unix, etc. C =head1 DESCRIPTION An XML-RPC server useful in allowing external Perl scripts to be triggered remotely (for backup, etc). =head1 CUSTOMIZATION At head of script is an area for user configuration. But in taking advantage of them, one therby documents the settings, some of which might best remain secret. Should you prefer to leave them as empty strings, a pop-up GUI will let you set them at startup. =head1 XML-RPC METHODS =head2 server_status A harmless way to test the server/client connection. Requests the server to inform of its status. =head2 server_log Copy the current log, if any, back to the client. =head2 change_password Allows a client to change the password of the server. =head2 change_cipher Allows a client to change the cipher pass pharase of the server. =head2 execute_command A means of executing a single command on each selected server. =over 4 =item How it works: Client opens a window for wherein the user types out, very carefully, the exact command to be executed. Each server will, in its own turn, open said script and attempt to execute it expecting pure text as the return. This return-text is then passed back to the client for display in a pop-up window. =back =head2 execute_script A means of executing external scripts line-by-line on each selected server. =over 4 =item How it works: Client browses for a Perl script and sends its file path to all selected servers. Each server will, in its own turn, open said script and attempt to execute it expecting pure text as the return. This return-text is then passed back to the client for display in a pop-up window. =item Example of use: Say a single backup script exists on a network directory. On each PC needing to run said backup script, this very XML-RPC server runs as a daemon. Then from any other PC you call up the companion XML-RPC GUI client. From the client you select one or more URLs from the list and click theB> button, browsing to the network path of the backup script. Each selected server will run said backup script in turn, not all at once, but one after another. =back =head2 kill_server Client remotely kills selected servers. As of this version the results are ungraceful. Although harmless, a killed server cannot reply to the client with an I packet. So the client, after a short timeout, thinks the procedure call has failed. A subsequent attempt with theB> method will verify that said server is indeed off-line. =head2 add_new_script Client browses for and transmits a new script to selected servers. Once transmitted, those servers store a copy locally. It is then immediately available to the>method. This, quite obviously, is a dangerous thing to do. Hence on the client, it is accessed via a warningly entitled titled pull-down menu:B> Any script thus sent is subjected to a certain degree of scrutiny by receiving servers. This scrutiny is only for known types of scripting languages, pure-ASCII content, etc. No test whatever is made for dangerous instructions embeded therein. Accordingly, use of this feature isI< AT YOUR OWN HAZARD! >The author of this server/client pair assumes no responsibility whatever for any use to which it is put. =head2 remove_scripts User enters exact script name or regular expression into client. Client then requests selected servers to delete matching files. Once transmitted, each selected server will completely delete its local copy along with info related to it. The client too forgets its existence so that you cannot ask for it again. =head2 add_doc_elsewhere Client browses for, filters and then transmits a pure ASCII text file to selected servers. Once transmitted, those servers store a copy locally, in a directory path generally outside that where executable scripts are stored. The exact path will vary, depending pupon the contents of the '%elsewhere' hash as defined by the user. =over 4 =item Where files are stored The keys of theB>hash are polled as filename-matching regexes. The values are directory paths. So when the server receives a filtered file sent to it from the client via theB>method, the server store it accordingly =item How files are filtered At the client there exists aB> hash with keys similar to those of theB>hash on the server, and likewise employed to match against filenames. But there each value will be an array of regular expressions for disallowed phrases. Any such lines as match a regex therein listed will be removed prior to transmission. =item Example usage The author employs theB>method as follows. Certain MTS servo-hydraulic testing machines which are left to run unattended on weekends had formerly required on-site visitation by operators working on overtime, and at their considerable inconvenience. Most frequently, however, such efforts were merely to determine that, no, the machines in question had not stopped and did not therefor require any service. Now, however, an XML-RPC client oversees these machines, forwarding filtered copies of their current status logs over the Internet to an XML-RPC server. There the server matches the received, filtered logs to a directory on a co-resident Apache web server. Thus operators have only to check that URL via web browser from their home PC to know if the machine requires service or not. The filtering so often mentioned above serves a two-fold purpose. Firstly it removes many lines from the status logs which are of no interest to the operator in determining if their machine needs tending. Secondly it removes any reference as to what sort of test the machine is running...customer proprietary information...that kind of thing (which, in a sense, is really just part of the first criterion). =item Browser annoyances Know that if your browser is set toI< accellerate >downloads, most likely it caches them instead. That means when you go to a certain website and click on a file you might not really get the most current version of that file. Instead you may see an out-of-date version which was cached during an earlier visitation to that same URL. This is no fault of XML-RPC; adjust your browser settings to correct the situation instead. =back =head2 remove_doc_elsewhere User enters exact script name or regular expression into client. Client then requests selected servers to delete matching files from their designated elsewhere-paths. =head2 reboot_server Hereby the client transmits a request for the server to transfer control temporarilly to companion scriptB>which kills and restarts the server. Works for both Unix and Win32 being tested on NetBSD, Win2K and WinXP. =head2 relay_sql_query Assuming you have a database server (PostgreSQL, MySQL, etc.) on the same PC. Then this method will function very like a CGI web page so that you may relay SQL queries to it. Each method call will do as follows: =over 4 =item Open a new connection to the DB. =item Pass a single SQL query. =item Close the connection to the DB. =item Transmit collected rows as an array back to the client. =back There is not much advantage in doing this way unless you need to bridge a firewall, in which case you will, of course, also require the companion Perl/CGI script for doing just that. Suitable as a stop-gap until such time as you can persuade your friendly, local, corporate IT SysAdmin to unblock the port where your DB normally listens. So if, like me, you have an fetal DB project gestating in your home PC, then this little feature will give you access to it from work until such time as it is ready for presentation to management. And then, being thus armed with a fait accompli, you stand a much better chance of weaning your IT department off their nasty commercial addition with a taste of open source. =head1 SECURITY =over 4 =item Encryption A full 56-byte Blowfish cipher is employed to secure data contained within the otherwise standard XML-RPC transactions. At startup, both client and server must employ identical plain text pass phrases (refer toB>near the head of each). Or if this has been left empty, a default pass phrase (refer toB>near the tail of each) will serve in its stead.. The client may later propagate new pass phrases to selected servers at any time. =item For all methods Method names are irreversibly obfuscated at startup (refer to subroutineB>for details) and again each time the cipher is changed. You may not rely upon the built-in default cipher key. The server will not allow it for any method except 'change_cipher'. Thus, in order to do anything useful, you will have to supply a cipher key of your own. Transactions also require a password. At startup, both client and server must employ identical plain text passwords (refer toB>near the head of each). The client may later propagate new passwords to selected servers at any time. The client and server each keep their own separate logs. Verbosity is according to user-elected startup options. =item For the execute_script method In making a script-execution request, all that the client does is pass a name to the server. The server makes its own determination whether to run said script. Firstly, the server enforces its own directory for executable scripts (same as forB>) stripping away any ascending path elements. Secondly, it checks against its own list of allowable scripts (refB>). Thirdly it makes sure the script is pure ASCII. Lastly it insures against any modification since upload or server startup. =item Vulnerabilities The server enforces whatever conditions it found on startup. That is to say, it cannot know whether a script to be employed by theB>method is free from any malicious tampering prior to startup. Nor does it filter the contents of pure ASCII scripts uploaded by the client. The user alone is wholly responsible for script content. =back =head1 DEPENDENCIES =head2 Perl Modules Install these into Perl via ActiveState PPM, else into NetBSD via pkgsrc or CPAN as appropriate for your OS:B>,B>,B>,B>,B>,B>. Further, if you expect to relay SQL queries to a database server, then you will also require the B>module and an associatedB>for whichever DB you are using. My ownB>package is already embeded in both the client and server scripts. It does not add anything truly novel but exists as a separate package for the sake of authorial convenience. =head3 For Unix Nothing here presentes itself as a difficulty. Required external dependencies are available from the expected sources: B> for NetBSD and/or CPAN for Perl. I cannot say for Linux, since I have yet to try it. If any report a problem for Linux, I would very like to help work it out and document the solution here =head3 For Win32 No especial problems here either, except that some things are not where most folks expect to find them. =over 4 =item Cryptography for ActiveState Perl 5.8 The Crypt::* family of modules is not fully maintained by ActiveState who fears a lowering brow the US alphabet agencies. Happily, folks in more freedom-loving countries have ammended this lack. Just perform these steps in the ActiveState PPM window. ppm> help repository ppm> repository add "Lincoln Stein" http://stein.cshl.org/ppm ppm> repository add "Randy Kobes" http://theoryx5.uwinnipeg.ca/ppms =back =head2 Companion XML-RPC Client Unless the companion Perl script B< C > running on some other network-attached PC, this server will lack any client to communicate with. Refer to documentation for the client at this URL: L. =head2 Auxilliary Perl Scripts These are for use with theB> method. See the complete list at this URL: L. =head1 AUTHOR Gan Uesli Starling > =head1 COPYRIGHT Copyright (c) 2005, Gan Uesli Starling. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SCRIPT CATEGORIES Networking =cut