Open-ILS/src/perlmods/OpenILS/Application/Acq/EDI.pm

   1 package OpenILS::Application::Acq::EDI;
   2 use base qw/OpenILS::Application/;
   3
   4 use strict; use warnings;
   5
   6 use IO::Scalar;
   7
   8 use OpenSRF::AppSession;
   9 use OpenSRF::EX qw/:try/;
  10 use OpenSRF::Utils::Logger qw(:logger);
  11 use OpenSRF::Utils::JSON;
  12
  13 use OpenILS::Application::Acq::Lineitem;
  14 use OpenILS::Utils::RemoteAccount;
  15 use OpenILS::Utils::CStoreEditor q/new_editor/;
  16 use OpenILS::Utils::Fieldmapper;
  17 use OpenILS::Application::Acq::EDI::Translator;
  18
  19 use Business::EDI;
  20 use Business::EDI::Segment::BGM;
  21
  22 use Data::Dumper;
  23 our $verbose = 0;
  24
  25 sub new {
  26     my($class, %args) = @_;
  27     my $self = bless(\%args, $class);
  28     # $self->{args} = {};
  29     return $self;
  30 }
  31
  32 our $translator;
  33
  34 sub translator {
  35     return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
  36 }
  37
  38 my %map = (
  39     host     => 'remote_host',
  40     username => 'remote_user',
  41     password => 'remote_password',
  42     account  => 'remote_account',
  43     # in_dir   => 'remote_path',   # field_map overrides path with in_dir
  44     path     => 'remote_path',
  45 );
  46
  47
  48 ## Just for debugging stuff:
  49 sub add_a_msg {
  50     my ($self, $conn) = @_;
  51     my $e = new_editor(xact=>1);
  52     my $incoming = Fieldmapper::acq::edi_message->new;
  53     $incoming->edi("This is content");
  54     $incoming->account(1);
  55     $incoming->remote_file('in/some_file.edi');
  56     $e->create_acq_edi_message($incoming);;
  57     $e->commit;
  58 }
  59 # __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg');  # debugging
  60
  61 __PACKAGE__->register_method(
  62         method    => 'retrieve',
  63         api_name  => 'open-ils.acq.edi.retrieve',
  64         signature => {
  65         desc   => 'Fetch incoming message(s) from EDI accounts.  ' .
  66                   'Optional arguments to restrict to one vendor and/or a max number of messages.  ' .
  67                   'Note that messages are not parsed or processed here, just fetched and translated.',
  68         params => [
  69             {desc => 'Authentication token',        type => 'string'},
  70             {desc => 'Vendor ID (undef for "all")', type => 'number'},
  71             {desc => 'Date Inactive Since',         type => 'string'},
  72             {desc => 'Max Messages Retrieved',      type => 'number'}
  73         ],
  74         return => {
  75             desc => 'List of new message IDs (empty if none)',
  76             type => 'array'
  77         }
  78     }
  79 );
  80
  81 sub retrieve_core {
  82     my ($self, $e, $set, $max) = @_;    # $e is a working editor
  83
  84     $e   ||= new_editor();
  85     $set ||= __PACKAGE__->retrieve_vendors($e);
  86
  87     my @return = ();
  88     my $vcount = 0;
  89     foreach my $account (@$set) {
  90         my $count = 0;
  91         my $server;
  92         $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host);
  93         unless ($server = __PACKAGE__->remote_account($account)) {   # assignment, not comparison
  94             $logger->err(sprintf "Failed remote account connection for %s (%s)", $account->host, $account->id);
  95             next;
  96         };
  97         my @files    = $server->ls({remote_file => ($account->in_dir || '.')});
  98         my @ok_files = grep {$_ !~ /\/\.?\.$/ } @files;
  99         $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, ($account->in_dir || ''));
 100         foreach (@ok_files) {
 101             ++$count;
 102             $max and $count > $max and last;
 103             my $content;
 104             my $io = IO::Scalar->new(\$content);
 105             unless ($server->get({remote_file => $_, local_file => $io})) {
 106                 $logger->error("(S)FTP get($_) failed");
 107                 next;
 108             }
 109             my $incoming = Fieldmapper::acq::edi_message->new;
 110             $incoming->remote_file($_);
 111             $incoming->edi($content);
 112             $incoming->account($account->id);
 113              __PACKAGE__->attempt_translation($incoming);
 114             $e->xact_begin;
 115             $e->create_acq_edi_message($incoming);
 116             $e->xact_commit;
 117             __PACKAGE__->record_activity($account, $e);
 118             __PACKAGE__->process_jedi($incoming, $server, $e);
 119 #           $server->delete(remote_file => $_);   # delete remote copies of saved message
 120             push @return, $incoming->id;
 121         }
 122     }
 123     return \@return;
 124 }
 125
 126 # ->send_core
 127 # $account     is a Fieldmapper object for acq.edi_account row
 128 # $messageset  is an arrayref with acq.edi_message.id values
 129 # $e           is optional editor object
 130 sub send_core {
 131     my ($class, $account, $message_ids, $e) = @_;    # $e is a working editor
 132
 133     ($account and scalar @$message_ids) or return;
 134     $e ||= new_editor();
 135
 136     my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids;
 137     my $m_count = scalar(@messageset);
 138     (scalar(@$message_ids) == $m_count) or
 139         $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)");
 140
 141     my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host;
 142     $logger->info("$log_str: $m_count message(s)");
 143     $m_count or return;
 144
 145     my $server;
 146     my $server_error;
 147     unless ($server = __PACKAGE__->remote_account($account, 1)) {   # assignment, not comparison
 148         $logger->error("Failed remote account connection for $log_str");
 149         $server_error = 1;
 150     };
 151     foreach (@messageset) {
 152         $_ or next;     # we already warned about bum ids
 153         my ($res, $error);
 154         if ($server_error) {
 155             $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below
 156         } elsif (! $_->edi) {
 157             $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content");
 158             $error = "EDI empty!";
 159         } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi})) {
 160             #  This is the successful case!
 161             $_->remote_file($res);
 162             $_->status('complete');
 163             $_->process_time('NOW');    # For outbound files, sending is the end of processing on the EG side.
 164             $logger->info("Sent message (id " . $_->id. ") via $log_str");
 165         } else {
 166             $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
 167             $error = "put FAILED: " . ($server->error || 'UNKOWNN');
 168         }
 169         if ($error) {
 170             $_->error($error);
 171             $_->error_time('NOW');
 172         }
 173         $logger->info("Calling update_acq_edi_message");
 174         $e->xact_begin;
 175         unless ($e->update_acq_edi_message($_)) {
 176              $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_));
 177              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_              ), '/tmp/update_acq_edi_message.FAIL');
 178              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash');
 179         }
 180         # There's always an update, even if we failed.
 181         $e->xact_commit;
 182         __PACKAGE__->record_activity($account, $e);  # There's always an update, even if we failed.
 183     }
 184     return \@messageset;
 185 }
 186
 187 #  attempt_translation does not touch the DB, just the object.
 188 sub attempt_translation {
 189     my ($class, $edi_message, $to_edi) = @_;
 190     my $tran  = translator();
 191     my $ret   = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi);
 192 #   $logger->error("json: " . Dumper($json)); # debugging
 193     if (not $ret or (! ref($ret)) or $ret->is_fault) {      # RPC::XML::fault on failure
 194         $edi_message->status('trans_error');
 195         $edi_message->error_time('NOW');
 196         my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed";
 197         my $message = ref($ret) ?
 198                       ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) :
 199                       ("$pre: "                           . __PACKAGE__->nice_string($ret)        ) ;
 200         $edi_message->error($message);
 201         $logger->error(  $message);
 202         return;
 203     }
 204     $edi_message->status('translated');
 205     $edi_message->translate_time('NOW');
 206     if ($to_edi) {
 207         $edi_message->edi($ret->value);    # translator returns an object
 208     } else {
 209         $edi_message->jedi($ret->value);   # translator returns an object
 210     }
 211     return $edi_message;
 212 }
 213
 214 sub retrieve_vendors {
 215     my ($self, $e, $vendor_id, $last_activity) = @_;    # $e is a working editor
 216
 217     $e ||= new_editor();
 218
 219     my $criteria = {'+acqpro' => {active => 't'}};
 220     # $criteria->{vendor_id} = $vendor_id if $vendor_id;
 221     return $e->search_acq_edi_account([
 222         $criteria, {
 223             'join' => 'acqpro',
 224             flesh => 1,
 225             flesh_fields => {
 226                 acqedi => ['provider']
 227             }
 228         }
 229     ]);
 230 #   {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
 231 }
 232
 233 # This is the SRF-exposed call, so it does checkauth
 234
 235 sub retrieve {
 236     my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
 237
 238     my $e = new_editor(authtoken=>$auth);
 239     unless ($e and $e->checkauth()) {
 240         $logger->warn("checkauth failed for authtoken '$auth'");
 241         return ();
 242     }
 243     # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);  # add permission here ?
 244
 245     my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
 246     return __PACKAGE__->retrieve_core($e, $set, $max);
 247 }
 248
 249
 250 # field_map takes the hashref of vendor data with fields from acq.edi_account and
 251 # maps them to the argument style needed for RemoteAccount.  It also extrapolates
 252 # data from the remote_host string for type and port, when available.
 253
 254 sub field_map {
 255     my $self   = shift;
 256     my $vendor = shift or return;
 257     my $no_override = @_ ? shift : 0;
 258     my %args = ();
 259     $verbose and $logger->warn("vendor: " . Dumper($vendor));
 260     foreach (keys %map) {
 261         $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
 262     }
 263     unless ($no_override) {
 264         $args{remote_path} = $vendor->in_dir;    # override "path" with "in_dir"
 265     }
 266     my $host = $args{remote_host} || '';
 267     ($host =~ s/^(S?FTP)://i    and $args{type} = uc($1)) or
 268     ($host =~ s/^(SSH|SCP)://i  and $args{type} = 'SCP' ) ;
 269      $host =~ s/:(\d+)$//       and $args{port} = $1;
 270      ($args{remote_host} = $host) =~ s#/+##;
 271     $verbose and $logger->warn("field_map: " . Dumper(\%args));
 272     return %args;
 273 }
 274
 275
 276 # The point of remote_account is to get the RemoteAccount object with args from the DB
 277
 278 sub remote_account {
 279     my ($self, $vendor, $outbound, $e) = @_;
 280
 281     unless (ref($vendor)) {     # It's not a hashref/object.
 282         $vendor or return;      # If in fact it's nothing: abort!
 283                                 # else it's a vendor_id string, so get the full vendor data
 284         $e ||= new_editor();
 285         my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
 286         $vendor = shift @$set_of_one;
 287     }
 288
 289     return OpenILS::Utils::RemoteAccount->new(
 290         $self->field_map($vendor, $outbound)
 291     );
 292 }
 293
 294 sub record_activity {
 295     my ($class, $account, $e) = @_;
 296     $account or return;
 297     $e ||= new_editor();
 298     $logger->info("EDI record_activity calling update_acq_edi_account");
 299     $account->last_activity('NOW') or return;
 300     $e->xact_begin;
 301     $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
 302     $e->xact_commit;
 303     return $account;
 304 }
 305
 306 sub nice_string {
 307     my $class = shift;
 308     my $string = shift or return '';
 309     chomp($string);
 310     my $head   = @_ ? shift : 100;
 311     my $tail   = @_ ? shift :  25;
 312     (length($string) < $head + $tail) and return $string;
 313     my $h = substr($string,0,$head);
 314     my $t = substr($string, -1*$tail);
 315     $h =~s/\s*$//o;
 316     $t =~s/\s*$//o;
 317     return "$h ... $t";
 318     # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
 319 }
 320
 321 sub jedi2perl {
 322     my ($class, $jedi) = @_;
 323     $jedi or return;
 324     my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi );
 325     open (FOO, ">>/tmp/JSON2perl_dump.txt");
 326     print FOO Dumper($msg), "\n\n";
 327     close FOO;
 328     $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt");
 329     return $msg;
 330 }
 331
 332 # ->process_jedi($message, $server, $e)
 333 sub process_jedi {
 334     my $class    = shift;
 335     my $message  = shift or return;
 336     my $server   = shift || {};  # context
 337     my $jedi     = ref($message) ? $message->jedi : $message;  # If we got an object, it's an edi_message.  A string is the jedi content itself.
 338     unless ($jedi) {
 339         $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi or jedi scalar)!");
 340         return;
 341     }
 342     my $e = @_ ? shift : new_editor();
 343     my $perl = __PACKAGE__->jedi2perl($jedi);
 344     if (ref($message) and not $perl) {
 345         $message->error(($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi");
 346         $message->error_time('NOW');
 347         $e->xact_begin;
 348         $e->udpate_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!");
 349         $e->xact_commit;
 350         return;
 351     }
 352     if (! $perl->{body}) {
 353         $logger->warn("EDI interchange body not found!");
 354         return;
 355     }
 356     if (! $perl->{body}->[0]) {
 357         $logger->warn("EDI interchange body not a populated arrayref!");
 358         return;
 359     }
 360
 361 # Crazy data structure.  Most of the arrays will be 1 element... we think.
 362 # JEDI looks like:
 363 # {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ...
 364 #
 365 # So you might access it like:
 366 #   $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH'
 367
 368     $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " messages(s)");
 369     my @li;
 370     my $i = 0;
 371     foreach my $part (@{$perl->{body}}) {
 372         $i++;
 373         unless (ref $part and scalar keys %$part) {
 374             $logger->warn("EDI interchange message $i lacks structure.  Skipping it.");
 375             next;
 376         }
 377         foreach my $key (keys %$part) {
 378             unless ($key eq 'ORDRSP') {     # We only do one type for now.  TODO: other types here
 379                 $logger->warn("EDI interchange message $i contains unhandled type '$key'.  Ignoring.");
 380                 next;
 381             }
 382             my @li_chunk = __PACKAGE__->parse_ordrsp($part->{$key}, $server, $e);
 383             $logger->info("EDI $key parsing returned " . scalar(@li_chunk) . " line items");
 384             push @li, @li_chunk;
 385         }
 386     }
 387     return \@li, $perl;   # TODO process perl
 388 }
 389
 390
 391 =head2 ->parse_ordrsp($segments, $server, $e)
 392
 393 Returns array of lineitems.
 394
 395 =cut
 396
 397 # TODO: Build Business::EDI::Message::ORDRSP object instead
 398 # TODO: Convert access to methods, not reaching inside the data/object like $segbody->{S009}->{'0065'}
 399
 400 sub parse_ordrsp {
 401     my ($class, $segments, $server, $e, $test) = @_;    # test not implemented
 402     $e ||= new_editor();
 403     my $type = 'ORDRSP';
 404     $logger->info("EDI " . scalar(@$segments) . " segments in $type message");
 405     my (@lins, $bgm);
 406     foreach my $segment (@$segments) {  # Prepass: catch the conditions that might cause us to bail
 407         my ($tag, $segbody, @extra) = @$segment;
 408         unless ($tag    ) {$logger->warn("EDI empty segment received"     ); next;}
 409         unless ($segbody) {$logger->warn("EDI segment '$tag' missing body"); next;}
 410         @extra and $logger->warn("EDI extra data (" . scalar(@extra) . " elements) found after pseudohash pair for $tag");
 411         if ($tag eq 'UNH') {
 412             unless ($segbody->{S009}->{'0065'} and $segbody->{S009}->{'0065'} eq $type) {
 413                 $logger->error("EDI $tag/S009/0065 ('" . ($segbody->{S009}->{'0065'} || '') . "') conflict w/ message type $type\.  Aborting");
 414                 return;
 415             }
 416             unless ($segbody->{S009}->{'0051'} and $segbody->{S009}->{'0051'} eq 'UN') {
 417                 $logger->warn("EDI $tag/S009/0051 does not designate 'UN' as controlling agency.  Will attempt to process anyway");
 418             }
 419         } elsif ($tag eq 'BGM') {
 420             $bgm = Business::EDI::Segment::BGM->new($segbody);
 421             $bgm->seg4343 or $logger->warn(sprintf "EDI $tag/4343 Response Type Code '%s' unrecognized", ($segbody->{4343} || ''));
 422             $logger->info(sprintf "EDI $tag/4343 response type: %s - %s (%s)", $bgm->seg4343->value, $bgm->seg4343->label, $bgm->seg4343->desc);
 423             my $fcn = $bgm->seg1225;
 424             unless ($fcn) {
 425                 $logger->error(sprintf "EDI $tag/1225 Message Function Code '%s' unrecognized.  Aborting", ($segbody->{1225} || ''));
 426                 return;
 427             }
 428         }
 429     }
 430     my @ignored;
 431     foreach my $segment (@$segments) {  # The main pass
 432         my ($tag, $segbody, @extra) = @$segment;
 433         next unless ($tag and $segbody);    # warnings above
 434         if ($tag eq 'LIN') {
 435             my @chunks = @{$segbody->{SG26}};
 436             my $count = scalar(@chunks);
 437             $logger->debug("EDI LIN/SG26 has $count chunks");
 438 # CHUNK:
 439 # ["RFF", {
 440 #   "C506": {
 441 #      "1153": "LI",
 442 #      "1154": "4639/1"
 443 #   }
 444 # }]
 445             foreach (@chunks) {
 446                 my $label = $_->[0];
 447                 my $body  = $_->[1];
 448                 # $label eq 'QTY' and push @qtys, $body;
 449                 $label eq 'RFF' or next;
 450                 my $obj;
 451                 unless ($obj = Business::EDI::Segment::RFF->new($body)) {   # assignment, not comparison
 452                     $logger->error("EDI $tag/$label failed to convert to an object");
 453                 }
 454                 $obj->seg1153 and $obj->seg1153->value eq 'LI' or $logger->warn("EDI $tag/$label object unexpected 1153 value (not 'LI')");
 455                 __PACKAGE__->update_li($obj->seg1154->value, $segbody, $server, $e);
 456             }
 457             push @lins, \@chunks;
 458         } elsif ($tag ne 'UNH' and $tag ne 'BGM') {
 459             push @ignored, $tag;
 460         }
 461     }
 462     @ignored and $logger->debug("EDI: ignoring " . scalar(@ignored) . " segment(s): " . join(', ', @ignored));
 463     return @lins;
 464 }
 465
 466 =head2 ->update_li($lineitem_id, $lineitem_object, [$server, $editor])
 467
 468 Updates:
 469  acq.lineitem.estimated_unit_price,
 470  acq.lineitem.state (dependent on mapping codes),
 471  acq.lineitem.expected_recv_time,
 472  acq.lineitem.edit_time (consequently)
 473
 474 =cut
 475
 476 sub update_li {
 477     my ($class, $id, $object, $server, $e) = @_;
 478     $e ||= new_editor();
 479     $id =~ s#^.*\/##;   # Temporary fix for mbklein's testdata
 480     print STDERR "Here we would retrieve/update lineitem $id\n";
 481     my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id); # Could send {options}
 482     if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') {
 483         $logger->error("EDI failed to retrieve lineitem by id '$id'");
 484         return;
 485     }
 486     unless ((! $server) or (! $server->provider)) {
 487         if ($server->provider != $li->provider) {
 488             # links go both ways: acq.provider.edi_default and acq.edi_account.provider
 489             $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider("
 490                             . $li->provider . ").  Checking acq.provider.edi_default...");
 491             my $provider = $e->retrieve_acq_provider($li->provider);
 492             if ($provider->edi_default != $server->id) {
 493                 $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s",
 494                                 $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default);
 495                 return;
 496             }
 497         }
 498     }
 499     return; # TODO: actual updates
 500     $e->xact_begin;
 501     $e->update_acq_lineitem($li) or $logger->warn("EDI: in update_li, update_acq_lineitem FAILED");
 502     $e->xact_commit;
 503     # print STDERR "Lineitem to update: ", Dumper($li);
 504 }
 505
 506 1;
 507