[open-ils-commits] r15358 - in trunk/Open-ILS/src/perlmods/OpenILS: Application/Acq Application/Acq/EDI Application/Trigger/Reactor Utils (erickson)
svn at svn.open-ils.org
svn at svn.open-ils.org
Thu Jan 21 12:58:48 EST 2010
Author: erickson
Date: 2010-01-21 12:58:44 -0500 (Thu, 21 Jan 2010)
New Revision: 15358
Added:
trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI.pm
trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI/
trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI/Translator.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/Cronscript.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/Lockfile.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/RemoteAccount.pm
Modified:
trunk/Open-ILS/src/perlmods/OpenILS/Application/Trigger/Reactor/SendFile.pm
Log:
Patch from Joe Atzberger that does several things:
1. Iniatial API calls for managing EDI documents at the server. EDI file fetching script to come soon.
2. Creates OpenILS::Utils::Cronscript and Lockfile modules to share and abstract the common setup tasks for Evergreen cron jobs
3. Creates a OpenILS::Utils::RemoteAccount module for managing access to remote services via ftp/scp. This is mostly taken from the SendFile reactor
4. Updates sendfile to use remoteaccount
Added: trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI/Translator.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI/Translator.pm (rev 0)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI/Translator.pm 2010-01-21 17:58:44 UTC (rev 15358)
@@ -0,0 +1,65 @@
+package OpenILS::Application::Acq::EDI::Translator;
+
+use warnings;
+use strict;
+
+use RPC::XML::Client;
+use Data::Dumper;
+
+# DEFAULTS
+my $proto = 'http://';
+my $host = $proto . 'localhost';
+my $path = '/EDI';
+my $port = 9191;
+my $verbose = 0;
+
+sub new {
+ my ($class, %args) = @_;
+ my $self = bless(\%args, $class);
+ $self->init;
+ return $self;
+}
+
+sub init {
+ my $self = shift;
+ $self->host_cleanup;
+}
+
+sub host_cleanup {
+ my $self = shift;
+ my $target = $self->{host} || $host;
+ $target =~ /^\S+:\/\// or $target = ($self->{proto} || $proto) . $target;
+ $target =~ /:\d+$/ or $target .= ':' . ($self->{port} || $port);
+ $target .= ($self->{path} || $path);
+ $self->{verbose} and print "Cleanup: $self->{host} ==> $target\n";
+ $self->{host} = $target;
+ return $target;
+}
+
+sub client {
+ my $self = shift;
+ return $self->{client} ||= RPC::XML::Client->new($self->{host}); # TODO: auth
+}
+
+sub json2edi {
+ my $self = shift;
+ my $text = shift;
+ my $client = $self->client();
+ $self->{verbose} and print "Trying json2edi on host: $self->{host}\n";
+ my $resp = $client->send_request('edi2json', $text);
+ $self->{verbose} and print Dumper($resp);
+ return $resp;
+}
+
+sub edi2json {
+ my $self = shift;
+ my $text = shift;
+ my $client = $self->client();
+ $self->{verbose} and print "Trying edi2json on host: $self->{host}\n";
+ my $resp = $client->send_request('json2edi', $text);
+ $self->{verbose} and print Dumper($resp);
+ return $resp;
+}
+
+1;
+
Added: trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI.pm (rev 0)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI.pm 2010-01-21 17:58:44 UTC (rev 15358)
@@ -0,0 +1,105 @@
+package OpenILS::Application::Acq::EDI;
+use base qw/OpenILS::Application/;
+
+use strict; use warnings;
+
+use OpenSRF::AppSession;
+use OpenSRF::EX qw/:try/;
+use OpenILS::Application::Acq::EDI::Translator;
+
+# use OpenILS::Event;
+use OpenSRF::Utils::Logger qw(:logger);
+# use OpenSRF::Utils::JSON;
+# use OpenILS::Utils::Fieldmapper;
+# use OpenILS::Utils::CStoreEditor q/:funcs/;
+# use OpenILS::Const qw/:const/;
+# use OpenILS::Application::AppUtils;
+
+sub new {
+ my($class, %args) = @_;
+ my $self = bless(\%args, $class);
+ # $self->{args} = {};
+ return $self;
+}
+
+our $translator;
+
+sub translator {
+ return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve',
+ api_name => 'open-ils.acq.edi.retrieve',
+ signature => {
+ desc => 'Fetch incoming message(s) from EDI accounts. ' .
+ 'Optional arguments to restrict to one vendor and/or a max number of messages. ' .
+ 'Note that messages are not parsed or processed here, just fetched and translated.',
+ param => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Vendor ID (undef for "all")', type => 'number'},
+ {desc => 'Max Messages Retrieved', type => 'number'}
+ ],
+ return => {
+ desc => 'List of new message IDs (empty if none)',
+ type => 'array'
+ }
+ }
+);
+
+sub retrieve {
+ my ($self, $conn, $auth, $vendor_id, $max) = @_;
+
+ my @return = ();
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ unless ($e->checkauth) {
+ $logger->warn("checkauth failed for authtoken '$auth'");
+ return @return;
+ }
+
+ my $criteria = {};
+ $criteria->{vendor_id} = $vendor_id if $vendor_id;
+ my $set = $e->search_acq_edi_account(
+ $criteria, {
+ flesh => 1,
+ flesh_fields => {
+ }
+ }
+ ) or return $e->die_event;
+
+ my $tran = translator();
+ foreach my $account (@$set) {
+ $logger->warn("EDI check for " . $account->host);
+# foreach message {
+# my $incoming = $e->create_acq_edi_message;
+# $incoming->edi($content);
+# $incoming->edi_account($account->id);
+# my $json = $tran->edi2json;
+# unless ($json) {
+# $logger->error("EDI Translator failed on $incoming->id");
+# next;
+# }
+# $incoming->json($json);
+# $e->commit;
+# delete remote copies of saved message (?)
+# push @return, $incoming->id;
+# }
+ }
+ # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);
+ # $e->commit;
+ return @return;
+}
+
+sub record_activity {
+ my $self = shift;
+ my $account = shift or return;
+}
+
+sub retrieve_one {
+ my $self = shift;
+ my $account = shift or return;
+
+}
+
+1;
+
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Application/Trigger/Reactor/SendFile.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Application/Trigger/Reactor/SendFile.pm 2010-01-21 17:03:00 UTC (rev 15357)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Application/Trigger/Reactor/SendFile.pm 2010-01-21 17:58:44 UTC (rev 15358)
@@ -3,25 +3,16 @@
use base 'OpenILS::Application::Trigger::Reactor';
# use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::RemoteAccount;
-use Data::Dumper;
-use Net::uFTP;
-use Net::SSH2; # because uFTP doesn't handle SSH keys (yet?)
-use File::Temp;
-
-$Data::Dumper::Indent = 0;
-
use strict;
use warnings;
-our %keyfiles = ();
-
sub ABOUT {
return <<ABOUT;
-The SendFile Reactor Module attempts to transfer a file to a remote server.
-Net::uFTP is used, encapsulating the available options of SCP, FTP and SFTP.
+The SendFile Reactor Module attempts to transfer a file to a remote server via
+SCP, FTP or SFTP.
No default template is assumed, and all information is expected to be gathered
by the Event Definition through event parameters:
@@ -29,204 +20,28 @@
~ remote_user
~ remote_password
~ remote_account
+ ~ remote_filename
~ ssh_privatekey
~ ssh_publickey
~ type (FTP, SFTP or SCP -- default FTP)
~ port
~ debug
-The latter three are optionally passed to the Net::uFTP constructor.
+The processed template is passed as "content" with the other params to
+OpenILS::Utils::RemoteAccount. See perldoc OpenILS::Utils::RemoteAccount for more.
-Note: none of the parameters are actually required, except remote_host.
-That is because remote_user, remote_password and remote_account can all be
-extrapolated from other sources, as the Net::FTP docs describe:
-
- If no arguments are given then Net::FTP uses the Net::Netrc package
- to lookup the login information for the connected host.
-
- If no information is found then a login of anonymous is used.
-
- If no password is given and the login is anonymous then anonymous@
- will be used for password.
-
-Note that specifying a password will require you to specify a user.
-Similarly, specifying an account requires both user and password.
-That is, there are no assumed defaults when the latter arguments are used.
-
-SSH KEYS:
-
-The use of ssh keys is preferred.
-
-The reactor attempts to use SSH keys where they are specified or otherwise found
-in the runtime environment. If only one key is specified, we attempt to derive
-the corresponding filename based on the ssh-keygen defaults. If either key is
-specified, but both are not found (and readable) then the result is failure. If
-no key is specified, but keys are found, the key-based connections will be attempted,
-but failure will be non-fatal.
-
+TODO: allow config.remote_account.id to specify options.
ABOUT
}
-sub plausible_dirs {
- # returns plausible locations of a .ssh subdir where SSH keys might be stashed
- # NOTE: these would need to be properly genericized w/ Makefule vars
- # in order to support Debian packaging and multiple EG's on one box.
- # Until that happens, we just rely on $HOME
-
- my @bases = (
- # '/openils/conf', # __EG_CONFIG_DIR__
- );
- ($ENV{HOME}) and unshift @bases, $ENV{HOME};
-
- return grep {-d $_} map {"$_/.ssh"} @bases;
-}
-
-sub get_keyfiles {
- # populates %keyfiles hash
- # %keyfiles maps SSH_PRIVATEKEY => SSH_PUBLICKEY
- my $force = (@_ ? shift : 0);
- return %keyfiles if (%keyfiles and not $force); # caching
- $logger->info("Checking for SSH keyfiles" . ($force ? ' (ignoring cache)' : ''));
- %keyfiles = (); # reset to empty
- my @dirs = plausible_dirs();
- $logger->debug(scalar(@dirs) . " plausible dirs: " . join(', ', @dirs));
- foreach my $dir (@dirs) {
- foreach my $key (qw/rsa dsa/) {
- my $private = "$dir/id_$key";
- my $public = "$dir/id_$key.pub";
- unless (-r $private) {
- $logger->debug("Key '$private' cannot be read: $!");
- next;
- }
- unless (-r $public) {
- $logger->debug("Key '$public' cannot be read: $!");
- next;
- }
- $keyfiles{$private} = $public;
- }
- }
- return %keyfiles;
-}
-
-sub param_keys {
- my $params = shift;
- my %keys = ();
- if ($params->{ssh_publickey } and not $params->{ssh_privatekey}) {
- $params->{ssh_privatekey} = $params->{ssh_publickey}; # try to guess missing private key name
- unless ($params->{ssh_privatekey} =~ s/\.pub$// and -r $params->{ssh_privatekey}) {
- $logger->error("No ssh_privatekey specified or found to pair with " . $params->{ssh_publickey});
- return;
- }
- }
- if ($params->{ssh_privatekey} and not $params->{ssh_publickey }) {
- $params->{ssh_publickey} = $params->{ssh_privatekey} . '.pub'; # guess missing public key name
- unless (-r $params->{ssh_publickey}) {
- $logger->error("No ssh_publickey specified or found to pair with " . $params->{ssh_privatekey});
- return;
- }
- }
-
- # so now, we have either both ssh_p*key params or neither
- foreach (qw/ssh_publickey ssh_privatekey/) {
- unless (-r $params->{$_}) {
- $logger->error("$_ '" . $params->{$_} . "' cannot be read: $!");
- return; # quit w/ error if we fail on any user-specified key
- }
- $keys{$params->{ssh_privatekey}} = $params->{ssh_publickey};
- }
- return %keys;
-}
-
sub handler {
my $self = shift;
my $env = shift;
my $params = $env->{params};
- my $host = $params->{remote_host};
- unless ($host) {
- $logger->error("No remote_host specified in env");
- return;
- }
-
- my $text = $self->run_TT($env) or return;
- my $tmp = File::Temp->new(); # magical self-destructing tempfile
- print $tmp $text;
- $logger->info("SendFile Reactor: using tempfile $tmp");
-
- my %keys = ();
- my $specific = 0;
- my @put_args = ($tmp->filename); # same for scp_put and uFTP put
- push @put_args, $params->{remote_file} if $params->{remote_file}; # user can specify remote_file name, optionally
-
- unless ($params->{type} and $params->{type} eq 'FTP') {
- if ($params->{ssh_publickey} || $params->{ssh_privatekey}) {
- $specific = 1;
- %keys = param_keys($params) or return; # we got one or both params, but they didn't pan out
- } else {
- %keys = get_keyfiles(); # optional "force" arg could be used here to empty cache
- }
- }
-
- if (%keys) {
- my $ssh2 = Net::SSH2->new();
- unless($ssh2->connect($host)) {
- $logger->warn("SSH2 connect FAILED: $!" . join(" ", $ssh2->error));
- $specific and return;
- %keys = (); # forget the keys, we cannot connect
- }
- foreach (keys %keys) {
- my %auth_args = (
- privatekey => $_,
- publickey => $keys{$_},
- rank => [qw/ publickey hostbased password /],
- );
- $params->{remote_user } and $auth_args{username} = $params->{remote_user };
- $params->{remote_password} and $auth_args{password} = $params->{remote_password};
- $params->{remote_host } and $auth_args{hostname} = $params->{remote_host };
-
- if ($ssh2->auth(%auth_args)) {
- if ($ssh2->scp_put(@put_args)) {
- $logger->info("SendFile Reactor: successfully sent ${host} " . join(' --> ', @put_args));
- return 1;
- } else {
- $logger->error("SendFile Reactor: put to $host failed with error: $!");
- return;
- }
- } elsif ($specific) {
- $logger->error("Abort reactor: ssh2->auth FAILED for $host using $_: $!");
- return;
- } else {
- $logger->notice("Unsuccessful keypair: ssh2->auth FAILED for $host using $_: $!");
- }
- }
- }
- # my $conf = OpenSRF::Utils::SettingsClient->new;
- # $$env{something_hardcoded} = $conf->config_value('category', 'whatever');
-
- # Try w/ non-key uFTP methods
- my %options = ();
- foreach (qw/debug type port/) {
- $options{$_} = $params->{$_} if $params->{$_};
- }
- my $ftp = Net::uFTP->new($host, %options);
-
- my @login_args = ();
- foreach (qw/remote_user remote_password remote_account/) {
- push @login_args, $params->{$_} if $params->{$_};
- }
- unless ($ftp->login(@login_args)) {
- $logger->error("SendFile Reactor: failed login to $host w/ args(" . join(',', @login_args) . ")");
- return;
- }
-
- my $filename = $ftp->put(@put_args);
- if ($filename) {
- $logger->info("SendFile Reactor: successfully sent ${host} $tmp --> $filename");
- return 1;
- } else {
- $logger->error("SendFile Reactor: put to $host failed with error: $!");
- return;
- }
+ $params->{content} = $self->run_TT($env) or return;
+ my $connection = OpenILS::Utils::RemoteAccount->new(%$params) or return;
+ return $connection->put;
}
1;
Added: trunk/Open-ILS/src/perlmods/OpenILS/Utils/Cronscript.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/Cronscript.pm (rev 0)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/Cronscript.pm 2010-01-21 17:58:44 UTC (rev 15358)
@@ -0,0 +1,224 @@
+package OpenILS::Utils::Cronscript;
+
+# ---------------------------------------------------------------
+# Copyright (C) 2010 Equinox Software, Inc
+# Author: Joe Atzberger <jatzberger at esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+# The purpose of this module is to consolidate the common aspects
+# of various cron tasks that all need the same things:
+# ~ non-duplicative processing, i.e. lockfiles and lockfile checking
+# ~ opensrf_core.xml file location
+# ~ common options like help and debug
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::JSON;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::Lockfile;
+
+use File::Basename qw/fileparse/;
+
+use Data::Dumper;
+
+our @extra_opts = ( # additional keys are stored here
+ # 'addlopt'
+);
+
+our $debug = 0;
+
+sub _default_self {
+ return {
+ # opts => {},
+ # opts_clean => {},
+ # default_opts_clean => {},
+ default_opts => {
+ 'lock-file=s' => OpenILS::Utils::Lockfile::default_filename,
+ 'osrf-config=s' => '/openils/conf/opensrf_core.xml', # TODO: packaging needs a make variable like @@EG_CONF_DIR@@
+ 'debug' => 0,
+ 'verbose+' => 0,
+ 'help' => 0,
+ 'internal_var' => 'XYZ',
+ },
+ # lockfile => undef,
+ }
+}
+
+sub is_clean {
+ my $key = shift or return 1;
+ $key =~ /[=:].*$/ and return 0;
+ $key =~ /[+!]$/ and return 0;
+ return 1;
+}
+
+sub clean {
+ my $key = shift or return;
+ $key =~ s/[=:].*$//;
+ $key =~ s/[+!]$//;
+ return $key;
+}
+
+sub fuzzykey { # when you know the hash you want from, but not the exact key
+ my $self = shift or return;
+ my $key = shift or return;
+ my $target = @_ ? shift : 'opts_clean';
+ foreach (map {clean($_)} keys %{$self->{default_opts}}) { # TODO: cache
+ $key eq $_ and return $self->{$target}->{$_};
+ }
+}
+
+# MyGetOptions
+# A wrapper around GetOptions
+# {opts} does two things for GetOptions (see Getopt::Long)
+# (1) maps command-line options to the *other* variables where values are stored (in opts_clean)
+# (2) provides hashspace for the rest of the arbitrary options from the command-line
+#
+# TODO: allow more options to be passed here, maybe mimic Getopt::Long::GetOptions style
+
+sub MyGetOptions {
+ my $self = shift;
+ my @keys = sort {is_clean($b) <=> is_clean($a)} keys %{$self->{default_opts}};
+ $debug and print "KEYS: ", join(", ", @keys), "\n";
+ foreach (@keys) {
+ my $clean = clean($_);
+ $self->{opts_clean}->{$clean} = $self->{default_opts_clean}->{$clean}; # prepopulate default
+ $self->{opts}->{$_} = \$self->{opts_clean}->{$clean}; # pointer for GetOptions
+ }
+ GetOptions($self->{opts}, @keys);
+ foreach (@keys) {
+ delete $self->{opts}->{$_}; # now remove the mappings from (1) so we just have (2)
+ }
+ $self->clean_mirror('opts'); # populate clean_opts w/ cleaned versions of (2), plus everything else
+
+ print $self->help() and exit if $self->{opts_clean}->{help};
+ $debug and $OpenILS::Utils::Lockfile::debug = $debug;
+
+ unless ($self->{opts_clean}->{nolockfile} || $self->{default_opts_clean}->{nolockfile}) {
+ $self->{lockfile_obj} = OpenILS::Utils::Lockfile->new($self->first_defined('lock-file'));
+ $self->{lockfile} = $self->{lockfile_obj}->filename;
+ }
+}
+
+sub first_defined {
+ my $self = shift;
+ my $key = shift or return;
+ foreach (qw(opts_clean opts default_opts_clean default_opts)) {
+ defined $self->{$_}->{$key} and return $self->{$_}->{$key};
+ }
+ return;
+}
+
+sub clean_mirror {
+ my $self = shift;
+ my $dirty = @_ ? shift : 'default_opts';
+ foreach (keys %{$self->{$dirty}}) {
+ defined $self->{$dirty}->{$_} or next;
+ $self->{$dirty . '_clean'}->{clean($_)} = $self->{$dirty}->{$_};
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $self = _default_self;
+ bless ($self, $class);
+ $self->init(@_);
+ $debug and print "new obj: ", Dumper($self);
+ return $self;
+}
+
+sub add_and_purge {
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+ my $clean = clean($key);
+ my @others = grep {/$clean/ and $_ ne $key} keys %{$self->{default_opts}};
+ foreach (@others) {
+ $debug and print "variant of $key => $_\n";
+ if ($key ne $clean) { # if it is a dirtier key, delete the clean one
+ delete $self->{default_opts}->{$_};
+ $self->{default_opts}->{$key} = $val;
+ } else { # else update the dirty one
+ $self->{default_opts}->{$_} = $val;
+ }
+ }
+}
+
+sub init { # not INIT
+ my $self = shift;
+ my $opts = @_ ? shift : {}; # user can specify more default options to constructor
+# TODO: check $opts is hashref; then check verbose/debug first. maybe check negations e.g. "no-verbose" ?
+ @extra_opts = keys %$opts;
+ foreach (@extra_opts) { # add any other keys w/ default values
+ $self->add_and_purge($_, $opts->{$_});
+ }
+ $self->clean_mirror;
+ return $self;
+}
+
+sub usage {
+ my $self = shift;
+ return "\nUSAGE: $0 [OPTIONS]";
+}
+
+sub options_help {
+ my $self = shift;
+ my $chunk = @_ ? shift : '';
+ return <<HELP
+
+OPTIONS:
+ --osrf-config </path/to/config_file> Default: $self->{default_opts_clean}->{'osrf-config'}
+ Specify OpenSRF core config file.
+
+ --lock-file </path/to/file_name> Default: $self->{default_opts_clean}->{'lock-file'}
+ Specify lock file.
+
+HELP
+ . $chunk . <<HELP;
+ --debug Print server responses to STDOUT for debugging
+ --verbose Set verbosity
+ --help Show this help message
+HELP
+}
+
+sub help {
+ my $self = shift;
+ return $self->usage() . "\n" . $self->options_help(@_) . $self->example();
+}
+
+sub example {
+ return "\n\nEXAMPLES:\n\n $0 --osrf-config /my/other/opensrf_core.xml\n";
+}
+
+sub session {
+ my $self = shift or return;
+ return ($self->{session} ||= OpenSRF::AppSession->create(@_));
+}
+
+sub bootstrap {
+ my $self = shift or return;
+ try {
+ $debug and print "bootstrap lock-file : ", $self->first_defined('lock-file'), "\n";
+ $debug and print "bootstrap osrf-config: ", $self->first_defined('osrf-config'), "\n";
+ OpenSRF::System->bootstrap_client(config_file => $self->first_defined('osrf-config'));
+ Fieldmapper->import(IDL => OpenSRF::Utils::SettingsClient->new->config_value("IDL"));
+ } otherwise {
+ warn shift;
+ };
+}
+
+1;
Added: trunk/Open-ILS/src/perlmods/OpenILS/Utils/Lockfile.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/Lockfile.pm (rev 0)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/Lockfile.pm 2010-01-21 17:58:44 UTC (rev 15358)
@@ -0,0 +1,83 @@
+package OpenILS::Utils::Lockfile;
+
+# ---------------------------------------------------------------
+# Copyright (C) 2010 Equinox Software, Inc
+# Author: Joe Atzberger <jatzberger at esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+# The purpose of this module is to consolidate
+# non-duplicative processing, i.e. lockfiles and lockfile checking
+
+use strict;
+use warnings;
+use Carp;
+
+use File::Basename qw/fileparse/;
+
+sub _tempdir {
+ return $ENV{TEMP} || $ENV{TMP} || '/tmp';
+}
+
+our $debug = 0;
+
+sub default_filename {
+ my $tempdir = _tempdir;
+ my $filename = fileparse($0, '.pl');
+ return "$tempdir/$filename-LOCK";
+}
+
+sub new {
+ my $class = shift;
+ my $lockfile = @_ ? shift : default_filename;
+
+ croak "Script already running with lockfile $lockfile" if -e $lockfile;
+ $debug and print "Writing lockfile $lockfile (PID: $$)\n";
+
+ open (F, ">$lockfile") or croak "Cannot write to lockfile '$lockfile': $!";
+ print F $$;
+ close F;
+
+ my $self = {
+ filename => $lockfile,
+ contents => $$,
+ };
+ return bless ($self, $class);
+}
+
+sub filename {
+ my $self = shift;
+ return $self->{filename};
+}
+sub contents {
+ my $self = shift;
+ return $self->{contents};
+}
+
+DESTROY {
+ my $self = shift;
+ # lockfile cleanup
+ if (-e $self->{filename}) {
+ open LF, $self->{filename};
+ my $contents = <LF>;
+ close LF;
+ $debug and print "deleting lockfile $self->{filename}\n";
+ if ($contents == $self->{contents}) {
+ unlink $self->{filename} or carp "Failed to remove lockfile '$self->{filename}'";
+ } else {
+ carp "Lockfile contents '$contents' no longer match '$self->{contents}'. Cannot remove $self->{filename}";
+ }
+
+ }
+}
+
+1;
Added: trunk/Open-ILS/src/perlmods/OpenILS/Utils/RemoteAccount.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/RemoteAccount.pm (rev 0)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/RemoteAccount.pm 2010-01-21 17:58:44 UTC (rev 15358)
@@ -0,0 +1,360 @@
+package OpenILS::Utils::RemoteAccount;
+
+# use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+use Data::Dumper;
+use Net::uFTP;
+use Net::SSH2; # because uFTP doesn't handle SSH keys (yet?)
+use File::Temp;
+
+$Data::Dumper::Indent = 0;
+
+use strict;
+use warnings;
+
+use Carp;
+
+our $AUTOLOAD;
+
+our %keyfiles = ();
+
+my %fields = (
+ remote_host => undef,
+ remote_user => undef,
+ remote_password => undef,
+ remote_account => undef,
+ remote_file => undef,
+ ssh_privatekey => undef,
+ ssh_publickey => undef,
+ type => undef,
+ port => undef,
+ content => undef,
+ localfile => undef,
+ tempfile => undef,
+ error => undef,
+ specific => 0,
+ debug => 0,
+);
+
+
+=pod
+
+The Remote Account module attempts to transfer a file to/from a remote server.
+Net::uFTP is used, encapsulating the available options of SCP, FTP and SFTP.
+
+All information is expected to be gathered by the Event Definition through event parameters:
+ ~ remote_host (required)
+ ~ remote_user
+ ~ remote_password
+ ~ remote_account
+ ~ ssh_privatekey
+ ~ ssh_publickey
+ ~ type (FTP, SFTP or SCP -- default FTP)
+ ~ port
+ ~ debug
+
+The latter three are optionally passed to the Net::uFTP constructor.
+
+Note: none of the parameters are actually required, except remote_host.
+That is because remote_user, remote_password and remote_account can all be
+extrapolated from other sources, as the Net::FTP docs describe:
+
+ If no arguments are given then Net::FTP uses the Net::Netrc package
+ to lookup the login information for the connected host.
+
+ If no information is found then a login of anonymous is used.
+
+ If no password is given and the login is anonymous then anonymous@
+ will be used for password.
+
+Note that specifying a password will require you to specify a user.
+Similarly, specifying an account requires both user and password.
+That is, there are no assumed defaults when the latter arguments are used.
+
+SSH KEYS:
+
+The use of ssh keys is preferred.
+
+We attempt to use SSH keys where they are specified or otherwise found
+in the runtime environment. If only one key is specified, we attempt to derive
+the corresponding filename based on the ssh-keygen defaults. If either key is
+specified, but both are not found (and readable) then the result is failure. If
+no key is specified, but keys are found, the key-based connections will be attempted,
+but failure will be non-fatal.
+
+=cut
+
+sub plausible_dirs {
+ # returns plausible locations of a .ssh subdir where SSH keys might be stashed
+ # NOTE: these would need to be properly genericized w/ Makefule vars
+ # in order to support Debian packaging and multiple EG's on one box.
+ # Until that happens, we just rely on $HOME
+
+ my @bases = (
+ # '/openils/conf', # __EG_CONFIG_DIR__
+ );
+ ($ENV{HOME}) and unshift @bases, $ENV{HOME};
+
+ return grep {-d $_} map {"$_/.ssh"} @bases;
+}
+
+sub get_keyfiles {
+ # populates %keyfiles hash
+ # %keyfiles maps SSH_PRIVATEKEY => SSH_PUBLICKEY
+ my $self = shift;
+ my $force = (@_ ? shift : 0);
+ return %keyfiles if (%keyfiles and not $force); # caching
+ $logger->info("Checking for SSH keyfiles" . ($force ? ' (ignoring cache)' : ''));
+ %keyfiles = (); # reset to empty
+ my @dirs = plausible_dirs();
+ $logger->debug(scalar(@dirs) . " plausible dirs: " . join(', ', @dirs));
+ foreach my $dir (@dirs) {
+ foreach my $key (qw/rsa dsa/) {
+ my $private = "$dir/id_$key";
+ my $public = "$dir/id_$key.pub";
+ unless (-r $private) {
+ $logger->debug("Key '$private' cannot be read: $!");
+ next;
+ }
+ unless (-r $public) {
+ $logger->debug("Key '$public' cannot be read: $!");
+ next;
+ }
+ $keyfiles{$private} = $public;
+ }
+ }
+ return %keyfiles;
+}
+
+sub param_keys {
+ my $self = shift;
+ my %keys = ();
+ if ($self->ssh_publickey and not $self->ssh_privatekey) {
+ my $private = $self->ssh_publickey;
+ unless ($private and $private =~ s/\.pub$// and -r $self->ssh_privatekey) { # try to guess missing private key name
+ $logger->error("No ssh_privatekey specified or found to pair with " . $self->ssh_publickey);
+ return;
+ }
+ $self->ssh_privatekey($private);
+ }
+ if ($self->ssh_privatekey and not $self->ssh_publickey) {
+ my $pub = $self->ssh_privatekey . '.pub'; # guess missing public key name
+ unless (-r $pub) {
+ $logger->error("No ssh_publickey specified or found to pair with " . $self->ssh_privatekey);
+ return;
+ }
+ $self->ssh_publickey($pub);
+ }
+
+ # so now, we have either both ssh_p*keys params or neither
+ foreach (qw/ssh_publickey ssh_privatekey/) {
+ unless (-r $self->{$_}) {
+ $logger->error("$_ '" . $self->{$_} . "' cannot be read: $!");
+ return; # quit w/ error if we fail on any user-specified key
+ }
+ }
+ $keys{$self->ssh_privatekey} = $self->ssh_publickey;
+ return %keys;
+}
+
+sub new_tempfile {
+ my $self = shift;
+ my $text = shift || $self->content || '';
+ my $tmp = File::Temp->new(); # magical self-destructing tempfile
+ # print $tmp "THIS IS TEXT\n";
+ print $tmp $text or $logger->error(__PACKAGE__ . " : could not write to tempfile '$tmp'");
+ close $tmp;
+ $self->tempfile($tmp); # save the object
+ $self->localfile($tmp->filename); # save the filename
+ $logger->info(__PACKAGE__ . " : using tempfile $tmp");
+ return $self->localfile; # return the filename
+}
+
+sub get {
+ my $self = shift;
+ my $params = shift;
+
+ $self->init($params); # secondary init
+}
+
+sub outbound_file {
+ my $self = shift;
+ my $params = shift;
+
+ unless (defined $self->content or $self->localfile) { # content can be emptystring
+ $logger->error($self->error("No content or localfile specified -- nothing to send"));
+ return;
+ }
+
+ # tricky subtlety: we want to use the most recently specified options
+ # with priority order: filename, content, old filename, old content.
+ #
+ # The $params->{x} will already match $self->x after the init above,
+ # so the checks using $params below are for whether the value was specified NOW (via put()) or not.
+ #
+ # if we got a new localfile value, we use it
+ # else if the content is new to this call, build a new tempfile w/ it,
+ # else use existing localfile,
+ # else build new tempfile w/ content already specified via new()
+
+ return $params->{localfile} || (
+ (defined $params->{content}) ?
+ $self->new_tempfile($self->content) : # $self->content is same value as $params->{content}
+ ($self->localfile || $self->new_tempfile($self->content))
+ );
+}
+
+sub put {
+ my $self = shift;
+ my $params = shift;
+
+ $self->init($params); # secondary init
+
+ my $localfile = $self->outbound_file($params) or return;
+
+ my %keys = ();
+ $self->{put_args} = [$localfile]; # same for scp_put and uFTP put
+
+ push @{$self->{put_args}}, $self->remote_file if $self->remote_file; # user can specify remote_file name, optionally
+
+ unless ($self->type and $self->type eq 'FTP') {
+ if ($self->ssh_publickey || $self->ssh_privatekey) {
+ $self->specific(1);
+ %keys = $self->param_keys() or return; # we got one or both params, but they didn't pan out
+ } else {
+ %keys = get_keyfiles(); # optional "force" arg could be used here to empty cache
+ }
+ }
+
+ my $try;
+ $try = $self->put_ssh2(%keys) if (%keys);
+ return $try if $try; # if we had keys and they worked, we're done
+
+ # Otherwise, try w/ non-key uFTP methods
+ return $self->put_uftp;
+}
+
+sub put_ssh2 {
+ my $self = shift;
+ my %keys = (@_);
+
+ $logger->info("*** attempting put with ssh keys");
+ my $ssh2 = Net::SSH2->new();
+ unless($ssh2->connect($self->remote_host)) {
+ $logger->warn($self->error("SSH2 connect FAILED: $!" . join(" ", $ssh2->error)));
+ $self->specific and return; # user told us what key(s) she wanted, and it failed.
+ %keys = (); # forget the keys, we cannot connect
+ }
+ foreach (keys %keys) {
+ my %auth_args = (
+ privatekey => $_,
+ publickey => $keys{$_},
+ rank => [qw/ publickey hostbased password /],
+ );
+ $self->remote_user and $auth_args{username} = $self->remote_user ;
+ $self->remote_password and $auth_args{password} = $self->remote_password;
+ $self->remote_host and $auth_args{hostname} = $self->remote_host ;
+
+ if ($ssh2->auth(%auth_args)) {
+ if ($ssh2->scp_put( @{$self->{put_args}} )) {
+ $logger->info(sprintf __PACKAGE__ . " : successfully sent %s %s", $self->remote_host, join(' --> ', @{$self->{put_args}} ));
+ return 1;
+ } else {
+ $logger->error($self->error(sprintf __PACKAGE__ . " : put to %s failed with error: $!", $self->remote_host));
+ return;
+ }
+ } elsif ($self->specific) {
+ $logger->error($self->error(sprintf "Abort: ssh2->auth FAILED for %s using %s: $!", $self->remote_host, $_));
+ return;
+ } else {
+ $logger->notice($self->error(sprintf "Unsuccessful keypair: ssh2->auth FAILED for %s using %s: $!", $self->remote_host, $_));
+ }
+ }
+}
+
+sub uftp {
+ my $self = shift;
+ my %options = ();
+ foreach (qw/debug type port/) {
+ $options{$_} = $self->{$_} if $self->{$_};
+ }
+ # TODO: eval wrapper, set $self->error($!) on failure
+ my $ftp = Net::uFTP->new($self->remote_host, %options) or return;
+
+ my @login_args = ();
+ foreach (qw/remote_user remote_password remote_account/) {
+ push @login_args, $self->{$_} if $self->{$_};
+ }
+ unless ($ftp->login(@login_args)) {
+ $logger->error(__PACKAGE__ . ' : ' . $self->error("failed login to " . $self->remote_host . " w/ args(" . join(',', @login_args) . ')'));
+ return;
+ }
+ return $ftp;
+}
+
+sub put_uftp {
+ my $self = shift;
+ my $ftp = $self->uftp or return;
+ my $filename = $ftp->put(@{$self->{put_args}});
+ if ($filename) {
+ $logger->info(__PACKAGE__ . " : successfully sent $self->remote_host $self->localfile --> $filename");
+ return $filename;
+ } else {
+ $logger->error(__PACKAGE__ . ' : ' . $self->error("put to " . $self->remote_host . " failed with error: $!"));
+ return;
+ }
+}
+
+sub init {
+ my $self = shift;
+ my $params = shift;
+ my @required = @_; # qw(remote_host) ; # nothing required now
+
+ foreach (keys %{$self->{_permitted}}) {
+ $self->{$_} = $params->{$_} if defined $params->{$_};
+ }
+
+ foreach (@required) {
+ unless ($self->{$_}) {
+ $logger->error("Required parameter $_ not specified");
+ return;
+ }
+ }
+ return $self;
+}
+
+
+sub new {
+ my( $class, %args ) = @_;
+ my $self = { _permitted => \%fields, %fields };
+
+ bless $self, $class;
+
+ $self->init(\%args); # or croak "Initialization error caused by bad args";
+ return $self;
+}
+
+sub DESTROY {
+ # in order to create, we must first ...
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $class = ref($self) or croak "$self is not an object";
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*://; # strip leading package stuff
+
+ unless (exists $self->{_permitted}->{$name}) {
+ croak "Cannot access '$name' field of class '$class'";
+ }
+
+ if (@_) {
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+}
+
+1;
More information about the open-ils-commits
mailing list