X-Git-Url: http://git.indexdata.com/?p=irspy-moved-to-github.git;a=blobdiff_plain;f=lib%2FZOOM%2FIRSpy.pm;h=0dc97c29d1b265f116a8cc14c25680b05b90d480;hp=870f4dc411a254e6c7de0d5dfba4281274b8d2c1;hb=HEAD;hpb=7d52fe9a4976790128ab41bf3d6d3c855290ebee diff --git a/lib/ZOOM/IRSpy.pm b/lib/ZOOM/IRSpy.pm index 870f4dc..0dc97c2 100644 --- a/lib/ZOOM/IRSpy.pm +++ b/lib/ZOOM/IRSpy.pm @@ -1,5 +1,3 @@ -# $Id: IRSpy.pm,v 1.74 2007-03-05 19:45:54 mike Exp $ - package ZOOM::IRSpy; use 5.008; @@ -16,11 +14,17 @@ use Net::Z3950::ZOOM 1.13; # For the ZOOM version-check only use ZOOM::IRSpy::Node; use ZOOM::IRSpy::Connection; use ZOOM::IRSpy::Stats; -use ZOOM::IRSpy::Utils qw(cql_target render_record); +use ZOOM::IRSpy::Utils qw(cql_target render_record + irspy_xpath_context irspy_make_identifier + irspy_record2identifier calc_reliability_stats + modify_xml_document); our @ISA = qw(); -our $VERSION = '0.02'; +our $VERSION = '1.02'; our $irspy_to_zeerex_xsl = dirname(__FILE__) . '/../../xsl/irspy2zeerex.xsl'; +our $debug = 0; +our $xslt_max_depth = 250; +our $max_timeout_errors = 3; # Enumeration for callback functions to return @@ -42,8 +46,8 @@ ZOOM::IRSpy - Perl extension for discovering and analysing IR services use ZOOM::IRSpy; $spy = new ZOOM::IRSpy("target/string/for/irspy/database"); $spy->targets(@targets); - $spy->initialise(); - $res = $spy->check("Main"); + $spy->initialise("Main"); + $res = $spy->check(); =head1 DESCRIPTION @@ -60,31 +64,40 @@ BEGIN { ZOOM::Log::mask_str("irspy_unhandled"); ZOOM::Log::mask_str("irspy_test"); ZOOM::Log::mask_str("irspy_task"); + ZOOM::Log::mask_str("irspy_data"); } sub new { my $class = shift(); my($dbname, $user, $password, $activeSetSize) = @_; + my @options; push @options, (user => $user, password => $password) if defined $user; my $conn = new ZOOM::Connection($dbname, 0, @options) - or die "$0: can't connection to IRSpy database 'dbname'"; + or die "$0: can't connect to IRSpy database 'dbname'"; my $xslt = new XML::LibXSLT; + # raise the maximum number of nested template calls and variables/params (default 250) + warn "raise the maximum number of nested template calls: $xslt_max_depth\n" if $debug; + $xslt->max_depth($xslt_max_depth); + $xslt->register_function($ZOOM::IRSpy::Utils::IRSPY_NS, 'strcmp', \&ZOOM::IRSpy::Utils::xslt_strcmp); my $libxml = new XML::LibXML; + warn "use irspy_to_zeerex_xsl xslt sheet: $irspy_to_zeerex_xsl\n" if $debug; my $xsl_doc = $libxml->parse_file($irspy_to_zeerex_xsl); my $irspy_to_zeerex_style = $xslt->parse_stylesheet($xsl_doc); my $this = bless { conn => $conn, query => "cql.allRecords=1", # unless overridden + modn => undef, # Filled in by restrict_modulo() + modi => undef, # Filled in by restrict_modulo() targets => undef, # Filled in later if targets() is # called; used only to keep state from # targets() until initialise() is @@ -93,14 +106,47 @@ sub new { queue => undef, # Filled in by initialise() libxml => $libxml, irspy_to_zeerex_style => $irspy_to_zeerex_style, + test => undef, # Filled in by initialise() + timeout => undef, # Filled in by initialise() tests => undef, # Tree of tests to be executed activeSetSize => defined $activeSetSize ? $activeSetSize : 10, + rules => [], # Can be filled by apply_rules() + vars => {}, # Will contain name, id, version, etc. + # May be written into by tests (mostly + # Ping, which gets the Init response) + # and read by tests for rules. }, $class; $this->log("irspy", "starting up with database '$dbname'"); return $this; } +# Read from and write to the set of vars +sub var { + my $this = shift(); + my($key, $newval) = @_; + + if (defined $newval) { + $this->{vars}->{$key} = $newval; + #warn "$this: set '$key'='$newval'"; + } else { + my $oldval = $this->{vars}->{$key}; + $oldval = "" if !defined $oldval; + #warn "$this: got '$key'='$oldval'"; + return $oldval; + } +} + +# wrapper to read the IRSpy database name from environment variable / apache config +sub connect_to_registry { + my %args = @_; + + # XXX: we could also handle here: user, password, elementSetName + + my $database = $ENV{IRSpyDbName} || "localhost:8018/IR-Explain---1"; + + return $database; +} sub log { my $this = shift(); @@ -129,12 +175,13 @@ sub targets { join(", ", map { "'$_'" } @targets)); my @qlist; foreach my $target (@targets) { - my($host, $port, $db, $newtarget) = _parse_target_string($target); + my($protocol, $host, $port, $db, $newtarget) = + _parse_target_string($target); if ($newtarget ne $target) { $this->log("irspy_debug", "rewriting '$target' to '$newtarget'"); $target = $newtarget; # This is written through the ref } - push @qlist, cql_target($host, $port, $db); + push @qlist, cql_target($protocol, $host, $port, $db); } $this->{targets} = \@targets; @@ -146,19 +193,48 @@ sub targets { sub _parse_target_string { my($target) = @_; - my($host, $port, $db) = ($target =~ /(.*?):(.*?)\/(.*)/); + my($protocol, $host, $port, $db) = ($target =~ /(.*?):(.*?):(.*?)\/(.*)/); if (!defined $host) { $port = 210; - ($host, $db) = ($target =~ /(.*?)\/(.*)/); - $target = "$host:$port/$db"; + ($protocol, $host, $db) = ($target =~ /(.*?):(.*?)\/(.*)/); + $target = irspy_make_identifier($protocol, $host, $port, $db); } die "$0: invalid target string '$target'" if !defined $host; - return ($host, $port, $db, $target); + return ($protocol, $host, $port, $db, $target); } +sub restrict_modulo { + my $this = shift(); + my($n, $i) = @_; + + $this->{modn} = $n; + $this->{modi} = $i; +} + + +sub apply_rules { + my $this = shift(); + my($fileName) = @_; + + my $f = new IO::File("<$fileName") + or die "$0: can't open rules file '$fileName': $!"; + + while (my $line = <$f>) { + chomp $line; + $line =~ s/#.*//; + $line =~ s/\s+$//; + next if !$line; + my(@fields) = split /\s+/, $line; + my($name, $op, $val, $rule, @params) = @fields; + #warn "parsed name='$name', op='$op', val='$val', rule='$rule', params='@params'\n"; + push @{ $this->{rules} }, [ @fields ]; + } + $f->close(); +} + # Records must be fetched for all records satisfying $this->{query} If # $this->{targets} is already set (i.e. a specific list of targets to # check was specified by a call to targets()), then new, empty records @@ -166,6 +242,16 @@ sub _parse_target_string { # sub initialise { my $this = shift(); + my($tname) = @_; + + $tname = "Main" if !defined $tname; + $this->{test} = $tname; + $this->{tree} = $this->_gather_tests($tname) + or die "No tests defined for '$tname'"; + $this->{tree}->resolve(); + #$this->{tree}->print(0); + + $this->{timeout} = "ZOOM::IRSpy::Test::$tname"->timeout(); my @targets; my $targets = $this->{targets}; @@ -186,21 +272,59 @@ sub initialise { my $n = $this->{activeSetSize}; $n = @targets if $n == 0 || $n > @targets; - my @connections; - foreach my $i (1..$n) { - push @connections, create ZOOM::IRSpy::Connection($this, - shift @targets, - async => 1); + $this->{queue} = \@targets; + $this->{connections} = []; + while (@{ $this->{connections} } < $n) { + my $conn = $this->_next_connection(); + last if !defined $conn; + push @{ $this->{connections} }, $conn; } +} - $this->{connections} = \@connections; - $this->{queue} = \@targets; + +sub _next_connection { + my $this = shift(); + + my $target; + my $n = $this->{modn}; + my $i = $this->{modi}; + if (!defined $n) { + $target = shift @{ $this->{queue} }; + return undef if !defined $target; + } else { + while (1) { + $target = shift @{ $this->{queue} }; + return undef if !defined $target; + my $h = _hash($target); + my $hmodn = $h % $n; + last if $hmodn == $i; + #$this->log("irspy", "'$target' hash $h % $n = $hmodn != $i"); + } + } + + die "oops -- target is undefined" if !defined $target; + return create ZOOM::IRSpy::Connection($this, $target, async => 1, + timeout => $this->{timeout}); +} + + +sub _hash { + my($target) = @_; + + my $n = 0; + foreach my $s (split //, $target) { + $n += ord($s); + } + + return $n; } sub _irspy_to_zeerex { my $this = shift(); - my($conn, $save_xml) = @_; + my($conn) = @_; + + my $save_xml = $ENV{IRSPY_SAVE_XML}; my $irspy_doc = $conn->record()->{zeerex}->ownerDocument; if ($save_xml) { @@ -224,25 +348,46 @@ sub _irspy_to_zeerex { } -sub _rewrite_record { +sub _rewrite_irspy_record { my $this = shift(); my($conn) = @_; $conn->log("irspy", "rewriting XML record"); - my $rec = $this->_irspy_to_zeerex($conn, $ENV{IRSPY_SAVE_XML}); + my $rec = $this->_irspy_to_zeerex($conn); # Since IRSpy can run for a long time between writes back to the # database, it's quite possible for the server to have closed the # connection as idle. So re-establish it if necessary. - $conn->connect($conn->option("host")); + $this->{conn}->connect($conn->option("host")); - _really_rewrite_record($this->{conn}, $rec); + _rewrite_zeerex_record($this->{conn}, $rec); $conn->log("irspy", "rewrote XML record"); } -sub _really_rewrite_record { - my($conn, $rec) = @_; +my $_specialFields = { + reliability => [ reliability => 0, + "Calculated reliability of server", + "e:serverInfo/e:reliability" ], + udb => [ udb => 0, + "Access Name (Unique DB)", + "e:databaseInfo/i:udb" ], +}; + +sub _rewrite_zeerex_record { + my($conn, $rec, $oldid) = @_; + + # Add reliability score + my $xc = irspy_xpath_context($rec); + my($nok, $nall, $percent) = calc_reliability_stats($xc); + modify_xml_document($xc, $_specialFields, { reliability => $percent }); + + my $xpath = $_specialFields->{udb}->[3]; + my $value = $xc->findvalue($xpath); + if (!defined $oldid && (!defined $value || $value eq '')) { + # New record with no explicit UDB: generate a UDB for it. + modify_xml_document($xc, $_specialFields, { udb => _next_udb() }); + } my $p = $conn->package(); $p->option(action => "specialUpdate"); @@ -251,6 +396,14 @@ sub _really_rewrite_record { $p->send("update"); $p->destroy(); + # This is the expression in the ID-making stylesheet + # ../../zebra/zeerex2id.xsl + my $id = irspy_record2identifier($xc); + if (defined $oldid && $id ne $oldid) { + warn "IDs differ (old='$oldid' new='$id')"; + _delete_record($conn, $oldid); + } + $p = $conn->package(); $p->send("commit"); $p->destroy(); @@ -263,6 +416,54 @@ sub _really_rewrite_record { } +sub _next_udb { + use IndexData::Utils::PersistentCounter; + + my $file = $ENV{IRSPY_COUNTER_FILE} + or die "no IRSPY_COUNTER_FILE in environment"; + my $counter = new IndexData::Utils::PersistentCounter($file) + or die "can't open counter file '$file': $!"; + my $val = $counter->next() + or die "can't get counter value from '$file': $!"; + return "irspy-$val"; +} + + +sub _delete_record { + my($conn, $id) = @_; + + # We can't delete records using recordIdOpaque, since character + # sets are handled differently here in extended services from how + # they are used in the Alvis filter's record-parsing, and so + # non-ASCII characters come out differently in the two contexts. + # Instead, we must send a record whose contents indicate the ID of + # that which we wish to delete. There are two ways, both + # unsatisfactory: we could either fetch the actual record them + # resubmit it in the deletion request (which wastes a search and a + # fetch) or we could build a record by hand from the parsed-out + # components (which is error-prone and which I am not 100% certain + # will work since the other contents of the record will be + # different). The former evil seems to be the lesser. + + warn "$conn deleting record '$id'"; + + my $rs = $conn->search(new ZOOM::Query::CQL(cql_target($id))); + die "no such ID '$id'" if $rs->size() == 0; + my $rec = $rs->record(0); + my $xml = $rec->render(); + + my $p = $conn->package(); + $p->option(action => "recordDelete"); + $p->option(record => $xml); + $p->send("update"); + $p->destroy(); + + $p = $conn->package(); + $p->send("commit"); + $p->destroy(); +} + + # The approach: gather declarative information about test hierarchy, # then go into a loop. In the loop, we ensure that each connection is # running a test, and within that test a task, until its list of tests @@ -293,15 +494,12 @@ sub _really_rewrite_record { # sub check { my $this = shift(); - my($tname) = @_; - $tname = "Main" if !defined $tname; - $this->{tree} = $this->_gather_tests($tname) - or die "No tests defined for '$tname'"; - $this->{tree}->resolve(); - #$this->{tree}->print(0); - my $nskipped = 0; + my $topname = $this->{tree}->name(); + my $timeout = $this->{timeout}; + $this->log("irspy", "beginnning with test '$topname' (timeout $timeout)"); + my $nskipped = 0; my @conn = @{ $this->{connections} }; my $nruns = 0; @@ -309,10 +507,12 @@ sub check { while (1) { my @copy_conn = @conn; # avoid alias problems after splice() my $nconn = scalar(@copy_conn); + foreach my $i0 (0 .. $#copy_conn) { my $conn = $copy_conn[$i0]; #print "connection $i0 of $nconn/", scalar(@conn), " is $conn\n"; next if !defined $conn; + if (!$conn->current_task()) { if (!$conn->next_task()) { # Out of tasks: we need a new test @@ -326,16 +526,23 @@ sub check { "checking for next test after '$address'"); $nextaddr = $this->_next_test($address); } + + if (ZOOM::IRSpy::Test::zoom_error_timeout_check($conn)) { + $conn->log("irspy", "Got to many timeouts, stop testing"); + undef $nextaddr; + } + if (!defined $nextaddr) { $conn->log("irspy", "has no more tests: removing"); - $this->_rewrite_record($conn); + $this->_rewrite_irspy_record($conn); $conn->option(rewrote_record => 1); - if (@{ $this->{queue} } == 0) { + my $newconn = $this->_next_connection(); + if (!defined $newconn) { + # Do not destroy: needed for later sanity checks splice @conn, $i0, 1; } else { - $conn[$i0] = create - ZOOM::IRSpy::Connection($this, - shift @{ $this->{queue} }, async => 1); + $conn->destroy(); + $conn[$i0] = $newconn; $conn[$i0]->option(current_test_address => ""); $conn[$i0]->log("irspy", "entering active pool - ", scalar(@{ $this->{queue} }), @@ -348,6 +555,13 @@ sub check { or die "invalid nextaddr '$nextaddr'"; $conn->option(current_test_address => $nextaddr); my $tname = $node->name(); + if ($this->should_skip_test($tname)) { + $conn->log("irspy_test", + "skipping test '$nextaddr' = $tname due to rule"); + $nskipped += 1; + goto NEXT_TEST; + } + $conn->log("irspy_test", "starting test '$nextaddr' = $tname"); my $tasks = $conn->tasks(); @@ -366,6 +580,13 @@ sub check { my $task = $conn->next_task(); die "no next task queued for $conn" if !defined $task; + + # do not run the next task if we got too many timeouts + if (ZOOM::IRSpy::Test::zoom_error_timeout_check($conn)) { + $conn->log("irspy_task", "Got too many timeouts for this target, do not start a new task"); + next; + } + $conn->log("irspy_task", "preparing task $task"); $conn->next_task(0); $conn->current_task($task); @@ -443,9 +664,9 @@ sub check { my $skipcount = 0; while (defined $node->next() && length($node->next()->address()) >= length($address)) { - $conn->log("irspy_debug", "skipping from '", + $conn->log("irspy_test", "skipping from '", $node->address(), "' to '", - $node->next()->address(), "'"); + $node->next()->address(), "' (", $node->next()->name(), ")"); $node = $node->next(); $skipcount++; } @@ -467,9 +688,10 @@ sub check { } $this->log("irspy", "exiting main loop"); + # Sanity checks: none of the following should ever happen my $finished = 1; - @conn = @{ $this->{connections} }; + $this->log("irspy", "performing end-of-run sanity-checks"); foreach my $conn (@conn) { my $test = $conn->option("current_test_address"); my $next = $this->_next_test($test); @@ -529,6 +751,30 @@ sub check { } +### This could of course call a much more general looping evaluator +sub should_skip_test { + my $this = shift(); + my($tname) = @_; + + foreach my $rule (@{ $this->{rules} }) { + my($name, $op, $val, $rule, @params) = @$rule; + #warn "using name='$name', op='$op', val='$val', rule='$rule', params='@params'\n"; + if ($op eq "~" && + $rule eq "skip" && + $params[0] eq $tname) { + my $re = $val; + $re =~ s/^\/(.*)\/$/$1/; + if ($this->var($name) =~ $re) { + #warn "$name '", $this->var($name), "' matches /$re/ -- skipping '$tname'"; + return 1; + } + } + } + + return 0; +} + + # Exactly equivalent to ZOOM::event() except that it is tolerant to # undefined values in the array being passed in. # @@ -566,7 +812,6 @@ sub _gather_tests { eval { require $fullName; - $this->log("irspy", "successfully required '$fullName'"); }; if ($@) { $this->log("irspy", "couldn't require '$fullName': $@"); $this->log("warn", "can't load test '$tname': skipping", @@ -600,7 +845,10 @@ sub _next_test { return undef if $address eq ""; # Try next sibling child - my @components = split /:/, $address; + # The use of a regexp in split() is to avoid confusing Emacs's + # Perl mode; the third colon is to avoid looking like a POSIX + # named character class ... *sigh* + my @components = split /[:::]/, $address; my $last = pop @components; my $maybe = join(":", @components, $last+1); return $maybe if $this->{tree}->select($maybe); @@ -611,6 +859,7 @@ sub _next_test { sub _last_sibling_test { + die "_last_sibling_test() called -- I thought that never happened?"; my $this = shift(); my($address) = @_; @@ -631,10 +880,11 @@ sub _last_sibling_test { sub _next_sibling_test { + die "_next_sibling_test() called -- I thought that never happened?"; my $this = shift(); my($address) = @_; - my @components = split /:/, $address; + my @components = split /[:::]/, $address; my $last = pop @components; my $maybe = join(":", @components, $last+1); return $maybe if $this->{tree}->select($maybe);