Open-ILS/src/support-scripts/settings-tester.pl

   1 #!/usr/bin/perl
   2 # vim:et:ts=4:
   3 use strict;
   4 use warnings;
   5 use Test::More tests => 7;
   6 use Error qw(:try);
   7
   8 BEGIN {
   9     use_ok( 'OpenSRF::Utils::Config' );
  10     use_ok( 'UNIVERSAL::require' );
  11     use_ok( 'Getopt::Long' );
  12     use_ok( 'MARC::Record', '2.0.1' );
  13     use_ok( 'Net::Domain' );
  14     use_ok( 'Locale::Maketext::Lexicon' );
  15     use_ok( 'Template::Plugin::POSIX' );
  16 }
  17
  18 my $output = '';
  19 my $perloutput = '';
  20 my $result;
  21
  22 my ($gather, $hostname, $core_config, $tmpdir) =
  23     (0, Net::Domain::hostfqdn(), '/openils/conf/opensrf_core.xml', '/tmp/');
  24
  25 GetOptions(
  26     'gather' => \$gather,
  27     'hostname=s' => \$hostname,
  28     'config_file=s' => \$core_config,
  29     'tempdir=s' => \$tmpdir,
  30 );
  31
  32 while (my $mod = <DATA>) {
  33     chomp $mod;
  34     my @list = split / /, $mod;
  35
  36     my $ok = 0;
  37     for my $m (@list) {
  38         if ($m->use) {
  39             $ok++;
  40             my $version = $m->VERSION;
  41             print "$m version $version\n" if ($version);
  42         }
  43     }
  44
  45     unless ($ok) {
  46         if (@list == 1) {
  47             warn "Please install $mod\n";
  48             $perloutput .= "Please install the $mod Perl module.\n";
  49         } else {
  50             warn "Please install one of the following modules: $mod\n";
  51             $perloutput .= "Please install one of the following modules: $mod\n";
  52         }
  53     }
  54
  55 }
  56
  57 use OpenSRF::Transport::SlimJabber::Client;
  58 use OpenSRF::Utils::SettingsParser;
  59 use OpenSRF::Utils::SettingsClient;
  60 use Data::Dumper;
  61 use DBI;
  62
  63 (my $conf_dir = $core_config) =~ s#(.*)/.*#$1#;
  64 OpenSRF::Utils::Config->load(config_file => $core_config);
  65 my $conf = OpenSRF::Utils::Config->current;
  66 my $settings_config = $conf->bootstrap->settings_config;
  67 my $logfile    = $conf->bootstrap->logfile;
  68 (my $log_dir = $logfile) =~ s#(.*)/.*#$1#;
  69
  70 my $xmlparser = XML::LibXML->new();
  71 my $confxml = $xmlparser->parse_file($core_config);
  72 my $confxpc = XML::LibXML::XPathContext->new($confxml);
  73 my $osrfxml = $xmlparser->parse_file($settings_config);
  74
  75 check_opensrf_core();
  76 check_all_jabber();
  77 check_all_database_connections();
  78 check_database_drivers();
  79
  80 print "\nChecking postgresql version\n";
  81 system ("psql", "--version");
  82
  83 print "\nChecking libdbi and libdbi-drivers\n";
  84 $output .= check_libdbd();
  85
  86 check_hostname();
  87
  88 if ($gather) {
  89     get_debug_info( $tmpdir, $log_dir, $conf_dir, $perloutput, $output );
  90 }
  91
  92 sub check_all_database_connections {
  93     print "\nChecking database connections\n";
  94     # Check database connections
  95     my @databases = $osrfxml->findnodes('//database');
  96
  97     # If we have no database connections, this is probably the OpenSRF version
  98     # of opensrf.xml
  99     if (!@databases) {
 100         my $de = "* WARNING: There are no database connections defined in " .
 101             "opensrf.xml. These are defined in services such as " .
 102             "open-ils.cstore and open-ils.reporter. Please ensure that " .
 103             "your opensrf_core.xml and opensrf.xml configuration files " .
 104             "are based on the examples shipped with Evergreen instead of " .
 105             "OpenSRF.\n";
 106         $output .= $de;
 107         warn $de;
 108     }
 109
 110     foreach my $database (@databases) {
 111         if ($database->parentNode->parentNode->localname eq 'open-ils.qstore') {
 112             next;
 113         }
 114         my $db_name = $database->findvalue("./db");
 115         if (!$db_name) {
 116             $db_name = $database->findvalue("./name");
 117         }
 118         my $db_host = $database->findvalue("./host");
 119         my $db_port = $database->findvalue("./port");
 120         my $db_user = $database->findvalue("./user");
 121         my $db_pw = $database->findvalue("./pw");
 122         if (!$db_pw && $database->parentNode->parentNode->nodeName eq 'reporter') {
 123             $db_pw = $database->findvalue("./password");
 124             if ($db_pw) {
 125                 my $de = "* WARNING: Deprecated <password> element used for the " .
 126                     "<reporter> entry. Please use <pw> instead.\n";
 127                 $output .= $de;
 128                 warn $de;
 129             }
 130         }
 131
 132         my $osrf_xpath;
 133         foreach my $node ($database->findnodes("ancestor::node()")) {
 134             next unless $node->nodeType == XML::LibXML::XML_ELEMENT_NODE;
 135             $osrf_xpath .= "/" . $node->nodeName;
 136         }
 137         $output .= test_db_connect($db_name, $db_host, $db_port, $db_user, $db_pw, $osrf_xpath);
 138     }
 139 }
 140
 141
 142 sub test_db_connect {
 143     my ($db_name, $db_host, $db_port, $db_user, $db_pw, $osrf_xpath) = @_;
 144
 145     my $dsn = "dbi:Pg:dbname=$db_name;host=$db_host;port=$db_port";
 146     my $de = undef;
 147     my ($dbh, $encoding, $langs);
 148     $dbh = DBI->connect($dsn, $db_user, $db_pw);
 149
 150     # Short-circuit if we didn't connect successfully
 151     unless($dbh) {
 152         $de = "* $osrf_xpath :: Unable to connect to database $dsn, user=$db_user, password=$db_pw\n";
 153         warn "* $osrf_xpath :: Unable to connect to database $dsn, user=$db_user, password=$db_pw\n";
 154         return $de;
 155     }
 156
 157     # Get server encoding
 158     my $sth = $dbh->prepare("SHOW server_encoding");
 159     $sth->execute;
 160     $sth->bind_col(1, \$encoding);
 161     $sth->fetch;
 162     $sth->finish;
 163
 164     # Get list of server languages
 165     $sth = $dbh->prepare("SELECT lanname FROM pg_catalog.pg_language");
 166     $sth->execute;
 167     $langs = $sth->fetchall_arrayref([0]);
 168     $sth->finish;
 169
 170     $dbh->disconnect;
 171     print "* $osrf_xpath :: Successfully connected to database $dsn\n" unless ($de);
 172
 173     # Check encoding
 174     if ($encoding !~ m/(utf-?8|unicode)/i) {
 175         $de .= "* ERROR: $osrf_xpath :: Database $dsn has encoding $encoding instead of UTF8 or UNICODE.\n";
 176         warn "* ERROR: $osrf_xpath :: Database $dsn has encoding $encoding instead of UTF8 or UNICODE.\n";
 177     } else {
 178         print "  * Database has the expected server encoding $encoding.\n";
 179     }
 180
 181     my $result = check_db_langs($langs);
 182     if ($result) {
 183         $de .= $result;
 184         warn $result;
 185     }
 186
 187     return ($de) ? $de : "* $osrf_xpath :: Successfully connected to database $dsn with encoding $encoding\n";
 188
 189 }
 190
 191 sub check_database_drivers {
 192     print "\nChecking database drivers to ensure <driver> matches <language>\n";
 193     # Check database drivers
 194     # if language eq 'C', driver eq 'pgsql'
 195     # if language eq 'perl', driver eq 'Pg'
 196     my @drivers = $osrfxml->findnodes('//driver');
 197     foreach my $driver_node (@drivers) {
 198         my $language;
 199         my $driver_xpath;
 200         my @driver_xpath_nodes;
 201         foreach my $node ($driver_node->findnodes("ancestor::node()")) {
 202             next unless $node->nodeType == XML::LibXML::XML_ELEMENT_NODE;
 203             $driver_xpath .= "/" . $node->nodeName;
 204             push @driver_xpath_nodes, $node->nodeName;
 205         }
 206         my $lang_xpath;
 207         my $driver = $driver_node->findvalue("child::text()");
 208         while (pop(@driver_xpath_nodes) && scalar(@driver_xpath_nodes) > 0 && !$language) {
 209             $lang_xpath = "/" . join('/', @driver_xpath_nodes) . "/language";
 210             my @lang_nodes = $osrfxml->findnodes($lang_xpath);
 211             next unless scalar(@lang_nodes > 0);
 212             $language = $lang_nodes[0]->findvalue("child::text()");
 213         }
 214         if ($driver eq "pgsql") {
 215             if ($driver_xpath =~ m#/reporter/#) {
 216                 $result = "* ERROR: reporter application must use driver 'Pg', but '$driver' is defined\n";
 217                 warn $result;
 218             } elsif ($language eq "C") {
 219                 $result = "* OK: $driver language is $language in $lang_xpath\n";
 220             } else {
 221                 $result = "* ERROR: $driver language is $language in $lang_xpath\n";
 222                 warn $result;
 223             }
 224         } elsif ($driver eq "Pg") {
 225             if ($driver_xpath =~ m#/reporter/#) {
 226                 $result = "* OK: $driver language is undefined for reporter base configuration\n";
 227             } elsif ($language eq "perl") {
 228                 $result = "* OK: $driver language is $language in $lang_xpath\n";
 229             } else {
 230                 $result = "* ERROR: $driver language is $language in $lang_xpath\n";
 231                 warn $result;
 232             }
 233
 234         } elsif ($driver eq "SIP") {
 235                 $result = "* OK SIP from telephony section. \n";
 236                 warn $result;
 237         } else {
 238             $result = "* ERROR: Unknown driver $driver in $driver_xpath\n";
 239             warn $result;
 240         }
 241         print $result;
 242         $output .= $result;
 243     }
 244 }
 245
 246 sub check_opensrf_core {
 247     print "\nChecking $core_config for Evergreen services:\n";
 248     my @public_services = $confxpc->findnodes("//services/service");
 249     my $found_eg_service = 0;
 250     foreach my $service (@public_services) {
 251         if ($service->firstChild->nodeValue eq 'open-ils.auth') {
 252             $found_eg_service = 1;
 253         }
 254     }
 255     if ($found_eg_service) {
 256         my $found .= "* OK: Found a public Evergreen service in $core_config\n";
 257         print $found;
 258         $output .= $found;
 259     } else {
 260         my $err = "* WARNING: No public Evergreen services were found in " .
 261             "$core_config; this means that you are probably still using " .
 262             "the version that ships with OpenSRF. Please use the " .
 263             "opensrf.xml.example file that ships with Evergreen.\n";
 264         $output .= $err;
 265         warn $err;
 266     }
 267 }
 268
 269 sub check_db_langs {
 270     my $langs = shift;
 271
 272     my $errors;
 273
 274     # Ensure the following PostgreSQL languages have been enabled
 275     my %languages = (
 276         'plperl' => 0,
 277         'plperlu' => 0,
 278         'plpgsql' => 0,
 279     );
 280
 281     foreach my $lang (@$langs) {
 282         my $lower = lc($$lang[0]);
 283         $languages{$lower} = 1;
 284     }
 285
 286     foreach my $lang (keys %languages) {
 287         if (!$languages{$lang}) {
 288             $errors .= "  * ERROR: Language '$lang' is not enabled in the target database\n";
 289         }
 290     }
 291
 292     return $errors;
 293 }
 294
 295 sub check_all_jabber {
 296     foreach my $section (qw/opensrf gateway/) {
 297         my $j_username = $confxpc->find("/config/$section/username");
 298         my $j_password = $confxpc->find("/config/$section/passwd");
 299         my $j_port = $confxpc->find("/config/$section/port");
 300         # We should check for a domains element to catch likely upgrade errors
 301         my $j_domain = $confxpc->find("/config/$section/domain");
 302         check_jabber($j_username, $j_password, $j_domain, $j_port);
 303     }
 304
 305     my @routers = $confxpc->findnodes("/config/routers/router");
 306     foreach my $router (@routers) {
 307         my $j_username = $router->findvalue("./transport/username");
 308         my $j_password = $router->findvalue("./transport/password");
 309         my $j_port = $router->findvalue("./transport/port");
 310         # We should check for a domains element to catch likely upgrade errors
 311         my $j_domain = $router->findvalue("./transport/server");
 312         check_jabber($j_username, $j_password, $j_domain, $j_port);
 313     }
 314 }
 315
 316 sub check_jabber {
 317     my ($j_username, $j_password, $j_domain, $j_port) = @_;
 318     print "\nChecking Jabber connection for user $j_username, domain $j_domain\n";
 319
 320     # connect to jabber
 321     my $client = OpenSRF::Transport::SlimJabber::Client->new(
 322         port => $j_port,
 323         username => $j_username,
 324         password => $j_password,
 325         host => $j_domain,
 326         resource => 'test123'
 327     );
 328
 329
 330     my $je = undef;
 331     try {
 332         unless($client->initialize()) {
 333             $je = "* Unable to connect to jabber server $j_domain\n";
 334             warn "* Unable to connect to jabber server $j_domain\n";
 335         }
 336     } catch Error with {
 337         $je = "* Error connecting to jabber:\n" . shift() . "\n";
 338         warn "* Error connecting to jabber:\n" . shift() . "\n";
 339     };
 340
 341     print "* Jabber successfully connected\n" unless ($je);
 342     $output .= ($je) ? $je : "* Jabber successfully connected\n";
 343 }
 344
 345 sub check_hostname {
 346     print "\nChecking hostname\n";
 347     my @hosts = $osrfxml->findnodes('/opensrf/hosts/*');
 348     foreach my $host (@hosts) {
 349         next unless $host->nodeType == XML::LibXML::XML_ELEMENT_NODE;
 350         my $osrfhost = $host->nodeName;
 351         my $he;
 352         if ($osrfhost ne $hostname && $osrfhost ne "localhost") {
 353             $result = " * ERROR: expected hostname '$hostname', found '$osrfhost' in <hosts> section of opensrf.xml\n";
 354             warn $result;
 355             $he = 1;
 356         } elsif ($osrfhost eq "localhost") {
 357             $result = " * OK: found hostname 'localhost' in <hosts> section of opensrf.xml\n";
 358         } else {
 359             $result = " * OK: found hostname '$hostname' in <hosts> section of opensrf.xml\n";
 360         }
 361         print $result unless $he;
 362         $output .= $result;
 363     }
 364 }
 365
 366 sub check_libdbd {
 367     my $results = '';
 368     my @location = `/sbin/ldconfig --print | grep libdbdpgsql`; # simple(ton) attempt to filter out build versions
 369     unless(@location) {
 370         # This is pretty distro-specific, but let's worry about other distros and operating systems when we get there
 371         my $res = "libdbi PostgreSQL driver not found in shared library path;
 372   you may need to edit /etc/ld.so.conf or add an entry to /etc/ld.so.conf.d/
 373   and run 'ldconfig' as root\n";
 374         print $res;
 375         return $res;
 376     }
 377     if ($location[0] !~ m#/usr/local/lib/dbd/#) {
 378         my $res = "libdbdpgsql.so was not found in /usr/local/libdbi/dbd/
 379   We have found that system packages don't link against libdbi.so;
 380   therefore, we strongly recommend compiling libdbi and libdbi-drivers from source.\n";
 381         $results .= $res;
 382         print $res;
 383     }
 384     if ($results eq '') {
 385         $results = "  * OK - found locally installed libdbi.so and libdbdpgsql.so in shared library path\n";
 386         print $results;
 387     }
 388     return $results;
 389 }
 390
 391 sub get_debug_info {
 392     my $temp_dir = shift; # place we can write files
 393     my $log = shift; # location of the log directory
 394     my $config = shift; # location of the config files
 395     my $perl_test = shift; # output from the Perl prereq testing
 396     my $config_test = shift; # output from the config file testing
 397
 398     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
 399     my $oils_time = sprintf("%04d-%02d-%02d_%02dh-%02d-%02d", $year+1900, $mon, $mday, $hour, $min, $sec);
 400
 401     # evil approach that requires no other Perl dependencies
 402     chdir($temp_dir);
 403     my $oils_debug_dir = "$temp_dir/oils_$oils_time";
 404
 405     # Replace with something Perlish
 406     mkdir($oils_debug_dir) or die $!;
 407
 408     # Replace with File::Copy
 409     system("cp $log/*log $oils_debug_dir");
 410
 411     # Passwords will go through in the clear for now
 412     system("cp $config/*xml $oils_debug_dir");
 413
 414     # Get Perl output
 415     open(FH, ">", "$oils_debug_dir/perl_test.out") or die $!;
 416     print FH $perl_test;
 417     close(FH);
 418
 419     # Get XML output
 420     open(FH, ">", "$oils_debug_dir/xml_test.out") or die $!;
 421     print FH $config_test;
 422     close(FH);
 423
 424     # Tar this up - does any system not have tar?
 425     system("tar czf oils_$oils_time.tar.gz oils_$oils_time");
 426
 427     # Clean up after ourselves, somewhat dangerously
 428     system("rm -fr $oils_debug_dir");
 429
 430     print "Wrote your debug information to $temp_dir/oils_$oils_time.tar.gz.\n";
 431 }
 432
 433 __DATA__
 434 LWP::UserAgent
 435 XML::LibXML
 436 XML::LibXML::XPathContext
 437 XML::LibXSLT
 438 Net::Server::PreFork
 439 Cache::Memcached
 440 Class::DBI
 441 Class::DBI::AbstractSearch
 442 Template
 443 DBD::Pg
 444 Net::Z3950 Net::Z3950::ZOOM
 445 MARC::Record
 446 MARC::Charset
 447 MARC::File::XML
 448 Text::Aspell
 449 CGI
 450 DateTime::TimeZone
 451 DateTime
 452 DateTime::Format::ISO8601
 453 DateTime::Format::Mail
 454 Unix::Syslog
 455 GD::Graph3d
 456 JavaScript::SpiderMonkey
 457 Log::Log4perl
 458 Email::Send
 459 Text::CSV
 460 Text::CSV_XS
 461 Spreadsheet::WriteExcel::Big
 462 Tie::IxHash
 463 Parse::RecDescent
 464 SRU
 465 JSON::XS
 466 UUID::Tiny
 467 Business::CreditCard::Object
 468 Net::Z3950::Simple2ZOOM