LP#1425967: look for Business::CreditCard in settings-tester.pl
[working/Evergreen.git] / 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         'plperlu' => 0,
277         'plpgsql' => 0,
278     );
279
280     foreach my $lang (@$langs) {
281         my $lower = lc($$lang[0]);
282         $languages{$lower} = 1;
283     }
284     
285     foreach my $lang (keys %languages) {
286         if (!$languages{$lang}) {
287             $errors .= "  * ERROR: Language '$lang' is not enabled in the target database\n";
288         }
289     }
290
291     return $errors;
292 }
293
294 sub check_all_jabber {
295     foreach my $section (qw/opensrf gateway/) {
296         my $j_username = $confxpc->find("/config/$section/username");
297         my $j_password = $confxpc->find("/config/$section/passwd");
298         my $j_port = $confxpc->find("/config/$section/port");
299         # We should check for a domains element to catch likely upgrade errors
300         my $j_domain = $confxpc->find("/config/$section/domain");
301         check_jabber($j_username, $j_password, $j_domain, $j_port);
302     }
303
304     my @routers = $confxpc->findnodes("/config/routers/router");
305     foreach my $router (@routers) {
306         my $j_username = $router->findvalue("./transport/username");
307         my $j_password = $router->findvalue("./transport/password");
308         my $j_port = $router->findvalue("./transport/port");
309         # We should check for a domains element to catch likely upgrade errors
310         my $j_domain = $router->findvalue("./transport/server");
311         check_jabber($j_username, $j_password, $j_domain, $j_port);
312     }
313 }
314
315 sub check_jabber {
316     my ($j_username, $j_password, $j_domain, $j_port) = @_;
317     print "\nChecking Jabber connection for user $j_username, domain $j_domain\n";
318
319     # connect to jabber 
320     my $client = OpenSRF::Transport::SlimJabber::Client->new(
321         port => $j_port, 
322         username => $j_username, 
323         password => $j_password,
324         host => $j_domain,
325         resource => 'test123'
326     );
327
328
329     my $je = undef;
330     try {
331         unless($client->initialize()) {
332             $je = "* Unable to connect to jabber server $j_domain\n";
333             warn "* Unable to connect to jabber server $j_domain\n";
334         }
335     } catch Error with {
336         $je = "* Error connecting to jabber:\n" . shift() . "\n";
337         warn "* Error connecting to jabber:\n" . shift() . "\n";
338     };
339
340     print "* Jabber successfully connected\n" unless ($je);
341     $output .= ($je) ? $je : "* Jabber successfully connected\n";
342 }
343
344 sub check_hostname {
345     print "\nChecking hostname\n";
346     my @hosts = $osrfxml->findnodes('/opensrf/hosts/*');
347     foreach my $host (@hosts) {
348         next unless $host->nodeType == XML::LibXML::XML_ELEMENT_NODE;
349         my $osrfhost = $host->nodeName;
350         my $he;
351         if ($osrfhost ne $hostname && $osrfhost ne "localhost") {
352             $result = " * ERROR: expected hostname '$hostname', found '$osrfhost' in <hosts> section of opensrf.xml\n";
353             warn $result;
354             $he = 1;
355         } elsif ($osrfhost eq "localhost") {
356             $result = " * OK: found hostname 'localhost' in <hosts> section of opensrf.xml\n";
357         } else {
358             $result = " * OK: found hostname '$hostname' in <hosts> section of opensrf.xml\n";
359         }
360         print $result unless $he;
361         $output .= $result;
362     }
363 }
364
365 sub check_libdbd {
366     my $results = '';
367     my @location = `/sbin/ldconfig --print | grep libdbdpgsql`; # simple(ton) attempt to filter out build versions
368     unless(@location) {
369         # This is pretty distro-specific, but let's worry about other distros and operating systems when we get there
370         my $res = "libdbi PostgreSQL driver not found in shared library path;
371   you may need to edit /etc/ld.so.conf or add an entry to /etc/ld.so.conf.d/
372   and run 'ldconfig' as root\n";
373         print $res;
374         return $res;
375     }
376     if ($location[0] !~ m#/usr/local/lib/dbd/#) {
377         my $res = "libdbdpgsql.so was not found in /usr/local/libdbi/dbd/
378   We have found that system packages don't link against libdbi.so;
379   therefore, we strongly recommend compiling libdbi and libdbi-drivers from source.\n";
380         $results .= $res;
381         print $res;
382     }
383     if ($results eq '') {
384         $results = "  * OK - found locally installed libdbi.so and libdbdpgsql.so in shared library path\n";
385         print $results;
386     }
387     return $results;
388 }
389
390 sub get_debug_info {
391     my $temp_dir = shift; # place we can write files
392     my $log = shift; # location of the log directory
393     my $config = shift; # location of the config files
394     my $perl_test = shift; # output from the Perl prereq testing
395     my $config_test = shift; # output from the config file testing
396
397     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
398     my $oils_time = sprintf("%04d-%02d-%02d_%02dh-%02d-%02d", $year+1900, $mon, $mday, $hour, $min, $sec);
399
400     # evil approach that requires no other Perl dependencies
401     chdir($temp_dir);
402     my $oils_debug_dir = "$temp_dir/oils_$oils_time";
403
404     # Replace with something Perlish
405     mkdir($oils_debug_dir) or die $!;
406
407     # Replace with File::Copy
408     system("cp $log/*log $oils_debug_dir");
409
410     # Passwords will go through in the clear for now
411     system("cp $config/*xml $oils_debug_dir");
412
413     # Get Perl output
414     open(FH, ">", "$oils_debug_dir/perl_test.out") or die $!;
415     print FH $perl_test;
416     close(FH);
417
418     # Get XML output
419     open(FH, ">", "$oils_debug_dir/xml_test.out") or die $!;
420     print FH $config_test;
421     close(FH);
422
423     # Tar this up - does any system not have tar?
424     system("tar czf oils_$oils_time.tar.gz oils_$oils_time");
425
426     # Clean up after ourselves, somewhat dangerously
427     system("rm -fr $oils_debug_dir");
428
429     print "Wrote your debug information to $temp_dir/oils_$oils_time.tar.gz.\n";
430 }
431
432 __DATA__
433 LWP::UserAgent
434 XML::LibXML
435 XML::LibXML::XPathContext
436 XML::LibXSLT
437 Net::Server::PreFork
438 Cache::Memcached
439 Class::DBI
440 Class::DBI::AbstractSearch
441 Template
442 DBD::Pg
443 Net::Z3950 Net::Z3950::ZOOM
444 MARC::Record
445 MARC::Charset
446 MARC::File::XML
447 Text::Aspell
448 CGI
449 DateTime::TimeZone
450 DateTime
451 DateTime::Format::ISO8601
452 DateTime::Format::Mail
453 Unix::Syslog
454 GD::Graph3d
455 JavaScript::SpiderMonkey
456 Log::Log4perl
457 Email::Send
458 Text::CSV
459 Text::CSV_XS
460 Excel::Writer::XLSX
461 Tie::IxHash
462 Parse::RecDescent
463 SRU
464 JSON::XS
465 UUID::Tiny
466 Business::CreditCard
467 Net::Z3950::Simple2ZOOM