From: tla Date: Wed, 15 Jan 2014 18:45:54 +0000 (+0100) Subject: Provide way to pass solver_url in options and fall back to default. Fixes #17 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=98c5430f83dd04b8f1d3ed2c54a420b53082af49;p=scpubgit%2Fstemmatology.git Provide way to pass solver_url in options and fall back to default. Fixes #17 --- diff --git a/analysis/lib/Text/Tradition/Analysis.pm b/analysis/lib/Text/Tradition/Analysis.pm index 3017506..942f42a 100644 --- a/analysis/lib/Text/Tradition/Analysis.pm +++ b/analysis/lib/Text/Tradition/Analysis.pm @@ -15,10 +15,10 @@ use TryCatch; use vars qw/ @EXPORT_OK $VERSION /; @EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /; -$VERSION = "1.2"; +$VERSION = "1.3"; -my $SOLVER_URL = 'http://byzantini.st/cgi-bin/graphcalc.cgi'; +my $DEFAULT_SOLVER_URL = 'http://perf.byzantini.st/cgi-bin/graphcalc.cgi'; my $unsolved_problems = {}; =head1 NAME @@ -170,18 +170,18 @@ sub run_analysis { $collapse->insert( $opts{'merge_types'} ); } - # Make sure we have a lookup DB for graph calculation results; this will die - # if calcdir or calcdsn isn't passed. + # If we have specified a local lookup DB for graph calculation results, + # make sure it exists and connect to it. my $dir; - if( exists $opts{'calcdir'} ) { - $dir = delete $opts{'calcdir'} - } elsif ( exists $opts{'calcdsn'} ) { + if ( exists $opts{'calcdsn'} ) { eval { require Text::Tradition::Directory }; if( $@ ) { throw( "Could not instantiate a directory for " . $opts{'calcdsn'} . ": $@" ); } - $dir = Text::Tradition::Directory->new( dsn => $opts{'calcdsn'} ); + $opts{'dir'} = Text::Tradition::Directory->new( dsn => $opts{'calcdsn'} ); + } elsif( !exists $opts{'solver_url'} ) { + $opts{'solver_url'} = $DEFAULT_SOLVER_URL; } # Get the stemma @@ -229,7 +229,7 @@ sub run_analysis { # Run the solver my $answer; try { - $answer = solve_variants( $dir, @groups ); + $answer = solve_variants( \%opts, @groups ); } catch ( Text::Tradition::Error $e ) { if( $e->message =~ /IDP/ ) { # Something is wrong with the solver; make the variants table anyway @@ -591,14 +591,10 @@ The answer has the form =cut sub solve_variants { - my( @groups ) = @_; + my( $opts, @groups ) = @_; - # Are we using a local result directory, or did we pass an empty value - # for the directory? - my $dir; - unless( ref( $groups[0] ) eq 'HASH' ) { - $dir = shift @groups; - } + # Are we using a local result directory? + my $dir = $opts->{dir}; ## For each graph/group combo, make a Text::Tradition::Analysis::Result ## object so that we can send it off for IDP lookup. @@ -624,12 +620,13 @@ sub solve_variants { my $scope = $dir->new_scope; map { $results{$_} = $dir->lookup( $_ ) || $problems{$_} } keys %problems; } else { + # print STDERR "Using solver at " . $opts->{solver_url} . "\n"; my $json = JSON->new->allow_blessed->convert_blessed->utf8->encode( [ values %problems ] ); # Send it off and get the result # print STDERR "Sending request: " . decode_utf8( $json ) . "\n"; my $ua = LWP::UserAgent->new(); - my $resp = $ua->post( $SOLVER_URL, 'Content-Type' => 'application/json', + my $resp = $ua->post( $opts->{solver_url}, 'Content-Type' => 'application/json', 'Content' => $json ); my $answer; if( $resp->is_success ) { diff --git a/analysis/lib/Text/Tradition/Analysis/IDPUtil.pm b/analysis/lib/Text/Tradition/Analysis/IDPUtil.pm new file mode 100644 index 0000000..693b211 --- /dev/null +++ b/analysis/lib/Text/Tradition/Analysis/IDPUtil.pm @@ -0,0 +1,142 @@ +package Text::Tradition::Analysis::IDPUtil; + +use strict; +use warnings; +use feature 'say'; +use Exporter 'import'; +use vars qw/ @EXPORT_OK /; +use Data::Validate::IP qw/ is_ipv4 is_ipv6 /; +use IPC::Run qw/ run /; + +@EXPORT_OK = qw/ read_config connect_db connect_db_create reset_db /; + +=head1 NAME + +Text::Tradition::IDPUtil - common utilities for talking to the IDP solver +and results database + +=head1 DESCRIPTION + +This package contains a set of utilities for handling IDP calculations on +the stemma graph properties, and their storage in a database. + +=head1 SUBROUTINES + +=head2 read_config + +Read the machine configuration file to find out how to talk to our database +and our Gearman instance. Returns a hash of untainted variables. + +=cut + +sub read_config { + ### Configurable variables + my %opts = ( + DBTYPE => 'mysql', + DBHOST => '127.0.0.1', + DBPORT => '3306', + DBNAME => 'idpresult', + DSN => undef, + DBUSER => undef, + DBPASS => undef, + GEARMAN_SERVER => '127.0.0.1:4730', + ); + + if( -f "/etc/graphcalc.conf" ) { + # Read the variables in from here. + open( GCCONF, "/etc/graphcalc.conf" ) + or die "Could not open configuration file /etc/graphcalc.conf"; + while() { + chomp; + s/^\s+//; + my( $name, $val ) = split( /\s*\=\s*/, $_ ); + if( $name eq 'GEARMAN_SERVER' ) { + # Minimally validate and untaint the value. + my( $gsip, $gsport ) = split( /:/, $val ); + my $ipv = Data::Validate::IP->new(); + my $ugsip = $ipv->is_ipv4( $gsip ); + unless( $ugsip ) { + $ugsip = $ipv->is_ipv6( $gsip ); + } + if( $ugsip && $gsport =~ /^(\d+)$/ ) { + $opts{$name} = "$ugsip:$1"; + } + } elsif( exists $opts{$name} ) { + $opts{$name} = $val; + } + } + close GCCONF; + } + unless( $opts{DSN} ) { + $opts{DSN} = sprintf( "dbi:%s:dbname=%s;host=%s;port=%s", + $opts{DBTYPE}, $opts{DBNAME}, $opts{DBHOST}, $opts{DBPORT} ); + } + + return %opts; +} + +=head2 connect_db( %config ) +=head2 connect_db_create( %config ) + +Given a configuration has as obtained from read_config, return a connection to +the appropriate KiokuDB store. If the _create variant is called, the DB tables +are created if they don't yet exist. + +=cut + +sub connect_db { + my $db = Text::Tradition::Directory->new( _get_db_connect_opts( @_ ) ); + return $db; +} + +sub connect_db_create { + my %connopts = _get_db_connect_opts( @_ ); + $connopts{extra_args}->{create} = 1; + my $db = Text::Tradition::Directory->new( %connopts ); + return $db; +} + +sub _get_db_connect_opts { + my %opts = @_; + my %dbconnopts = ( dsn => $opts{DSN} ); + if( exists $opts{DBUSER} ) { + $dbconnopts{extra_args}->{user} = $opts{DBUSER}; + } + if( exists $opts{DBPASS} ) { + $dbconnopts{extra_args}->{password} = $opts{DBPASS}; + } + return %dbconnopts; +} + +=head2 $status = reset_db( %config ) { + +Attempts to wipe the relevant database. Currently this can be done for SQLite +and MySQL. If the returned $status is not "OK", something went wrong. + +=cut + +sub reset_db { + my %opts = @_; + my $status = "OK"; + if( $opts{DBTYPE} eq 'mysql' ) { + say 'Dropping tables in ' . $opts{DBNAME}; + my @connectargs = ( '-h', $opts{DBHOST}, '-P', $opts{DBPORT}, '-u'.$opts{DBUSER}, + '-p'.$opts{DBPASS}, $opts{DBNAME} ); + my( $ret, $err ); + my @dump = ( 'mysqldump', '--add-drop-table', '--no-data', @connectargs ); + my @grep = ( 'grep', '^DROP' ); + my @sort = ( 'sort', '-r' ); + my @drop = ( 'mysql', @connectargs ); + run( \@dump, '|', \@grep, '|', \@sort, '|', \@drop, '>' ,\$ret, '2>', \$err ) + or $status = "Drop command returned $?:\n$err"; + } elsif( $opts{DBTYPE} eq 'SQLite' ) { + say "Dropping SQLite database " . $opts{DBNAME}; + unlink( $opts{DBNAME} ) or $status = "Could not unlink SQLite file!"; + } else { + $status = "Cannot currently reset DBs of type " . $opts{DBTYPE}; + } + return $status; +} + + +1; \ No newline at end of file