package OpenILS::Application::Acq::EDI; use base qw/OpenILS::Application/; use strict; use warnings; use IO::Scalar; use OpenSRF::AppSession; use OpenSRF::EX qw/:try/; use OpenSRF::Utils::Logger qw(:logger); use OpenSRF::Utils::JSON; use OpenILS::Application::Acq::Lineitem; use OpenILS::Utils::RemoteAccount; use OpenILS::Utils::CStoreEditor q/new_editor/; use OpenILS::Utils::Fieldmapper; use OpenILS::Application::Acq::EDI::Translator; use Business::EDI; use Business::EDI::Segment::BGM; use Data::Dumper; our $verbose = 0; sub new { my($class, %args) = @_; my $self = bless(\%args, $class); # $self->{args} = {}; return $self; } # our $reasons = {}; # cache for acq.cancel_reason rows ? our $translator; sub translator { return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_); } my %map = ( host => 'remote_host', username => 'remote_user', password => 'remote_password', account => 'remote_account', # in_dir => 'remote_path', # field_map overrides path with in_dir path => 'remote_path', ); ## Just for debugging stuff: sub add_a_msg { my ($self, $conn) = @_; my $e = new_editor(xact=>1); my $incoming = Fieldmapper::acq::edi_message->new; $incoming->edi("This is content"); $incoming->account(1); $incoming->remote_file('in/some_file.edi'); $e->create_acq_edi_message($incoming);; $e->commit; } # __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg'); # debugging __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.', params => [ {desc => 'Authentication token', type => 'string'}, {desc => 'Vendor ID (undef for "all")', type => 'number'}, {desc => 'Date Inactive Since', type => 'string'}, {desc => 'Max Messages Retrieved', type => 'number'} ], return => { desc => 'List of new message IDs (empty if none)', type => 'array' } } ); sub retrieve_core { my ($self, $e, $set, $max) = @_; # $e is a working editor $e ||= new_editor(); $set ||= __PACKAGE__->retrieve_vendors($e); my @return = (); my $vcount = 0; foreach my $account (@$set) { my $count = 0; my $server; $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host); unless ($server = __PACKAGE__->remote_account($account)) { # assignment, not comparison $logger->err(sprintf "Failed remote account connection for %s (%s)", $account->host, $account->id); next; }; my @files = $server->ls({remote_file => ($account->in_dir || '.')}); my @ok_files = grep {$_ !~ /\/\.?\.$/ } @files; $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, ($account->in_dir || '')); foreach (@ok_files) { ++$count; $max and $count > $max and last; my $content; my $io = IO::Scalar->new(\$content); unless ( $server->get({remote_file => ($account->in_dir ? ($account->in_dir . "/$_") : $_), local_file => $io}) ) { $logger->error("(S)FTP get($_) failed"); next; } my $z; # must predeclare $z = ( $content =~ s/('UNH\+\d+\+ORDRSP:)0(:96A:UN')/$1D$2/g ) and $logger->warn("Patching bogus spec reference ORDRSP:0:96A:UN => ORDRSP:D:96A:UN ($z times)"); # Hack/fix some faulty "0" in (B&T) data my $incoming = Fieldmapper::acq::edi_message->new; $incoming->remote_file($_); $incoming->message_type('ORDRSP'); # FIXME: we don't actually know w/o sniffing, but DB constraint makes us say something $incoming->edi($content); $incoming->account($account->id); __PACKAGE__->attempt_translation($incoming); $e->xact_begin; $e->create_acq_edi_message($incoming); $e->xact_commit; __PACKAGE__->record_activity($account, $e); __PACKAGE__->process_jedi($incoming, $server, $e); # $server->delete(remote_file => $_); # delete remote copies of saved message push @return, $incoming->id; } } return \@return; } # ->send_core # $account is a Fieldmapper object for acq.edi_account row # $messageset is an arrayref with acq.edi_message.id values # $e is optional editor object sub send_core { my ($class, $account, $message_ids, $e) = @_; # $e is a working editor ($account and scalar @$message_ids) or return; $e ||= new_editor(); my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids; my $m_count = scalar(@messageset); (scalar(@$message_ids) == $m_count) or $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)"); my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host; $logger->info("$log_str: $m_count message(s)"); $m_count or return; my $server; my $server_error; unless ($server = __PACKAGE__->remote_account($account, 1)) { # assignment, not comparison $logger->error("Failed remote account connection for $log_str"); $server_error = 1; }; foreach (@messageset) { $_ or next; # we already warned about bum ids my ($res, $error); if ($server_error) { $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below } elsif (! $_->edi) { $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content"); $error = "EDI empty!"; } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi, single_ext => 1})) { # This is the successful case! $_->remote_file($res); $_->status('complete'); $_->process_time('NOW'); # For outbound files, sending is the end of processing on the EG side. $logger->info("Sent message (id " . $_->id. ") via $log_str"); } else { $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN')); $error = "put FAILED: " . ($server->error || 'UNKOWNN'); } if ($error) { $_->error($error); $_->error_time('NOW'); } $logger->info("Calling update_acq_edi_message"); $e->xact_begin; unless ($e->update_acq_edi_message($_)) { $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_)); OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_ ), '/tmp/update_acq_edi_message.FAIL'); OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash'); } # There's always an update, even if we failed. $e->xact_commit; __PACKAGE__->record_activity($account, $e); # There's always an update, even if we failed. } return \@messageset; } # attempt_translation does not touch the DB, just the object. sub attempt_translation { my ($class, $edi_message, $to_edi) = @_; my $tran = translator(); my $ret = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi); # $logger->error("json: " . Dumper($json)); # debugging if (not $ret or (! ref($ret)) or $ret->is_fault) { # RPC::XML::fault on failure $edi_message->status('trans_error'); $edi_message->error_time('NOW'); my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed"; my $message = ref($ret) ? ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) : ("$pre: " . __PACKAGE__->nice_string($ret) ) ; $edi_message->error($message); $logger->error( $message); return; } $edi_message->status('translated'); $edi_message->translate_time('NOW'); if ($to_edi) { $edi_message->edi($ret->value); # translator returns an object } else { $edi_message->jedi($ret->value); # translator returns an object } return $edi_message; } sub retrieve_vendors { my ($self, $e, $vendor_id, $last_activity) = @_; # $e is a working editor $e ||= new_editor(); my $criteria = {'+acqpro' => {active => 't'}}; # $criteria->{vendor_id} = $vendor_id if $vendor_id; return $e->search_acq_edi_account([ $criteria, { 'join' => 'acqpro', flesh => 1, flesh_fields => { acqedi => ['provider'] } } ]); # {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1} } # This is the SRF-exposed call, so it does checkauth sub retrieve { my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_; my $e = new_editor(authtoken=>$auth); unless ($e and $e->checkauth()) { $logger->warn("checkauth failed for authtoken '$auth'"); return (); } # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency); # add permission here ? my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event; return __PACKAGE__->retrieve_core($e, $set, $max); } # field_map takes the hashref of vendor data with fields from acq.edi_account and # maps them to the argument style needed for RemoteAccount. It also extrapolates # data from the remote_host string for type and port, when available. sub field_map { my $self = shift; my $vendor = shift or return; my $no_override = @_ ? shift : 0; my %args = (); $verbose and $logger->warn("vendor: " . Dumper($vendor)); foreach (keys %map) { $args{$map{$_}} = $vendor->$_ if defined $vendor->$_; } unless ($no_override) { $args{remote_path} = $vendor->in_dir; # override "path" with "in_dir" } my $host = $args{remote_host} || ''; ($host =~ s/^(S?FTP)://i and $args{type} = uc($1)) or ($host =~ s/^(SSH|SCP)://i and $args{type} = 'SCP' ) ; $host =~ s/:(\d+)$// and $args{port} = $1; ($args{remote_host} = $host) =~ s#/+##; $verbose and $logger->warn("field_map: " . Dumper(\%args)); return %args; } # The point of remote_account is to get the RemoteAccount object with args from the DB sub remote_account { my ($self, $vendor, $outbound, $e) = @_; unless (ref($vendor)) { # It's not a hashref/object. $vendor or return; # If in fact it's nothing: abort! # else it's a vendor_id string, so get the full vendor data $e ||= new_editor(); my $set_of_one = $self->retrieve_vendors($e, $vendor) or return; $vendor = shift @$set_of_one; } return OpenILS::Utils::RemoteAccount->new( $self->field_map($vendor, $outbound) ); } sub record_activity { my ($class, $account, $e) = @_; $account or return; $e ||= new_editor(); $logger->info("EDI record_activity calling update_acq_edi_account"); $account->last_activity('NOW') or return; $e->xact_begin; $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED"); $e->xact_commit; return $account; } sub nice_string { my $class = shift; my $string = shift or return ''; chomp($string); my $head = @_ ? shift : 100; my $tail = @_ ? shift : 25; (length($string) < $head + $tail) and return $string; my $h = substr($string,0,$head); my $t = substr($string, -1*$tail); $h =~s/\s*$//o; $t =~s/\s*$//o; return "$h ... $t"; # return substr($string,0,$head) . "... " . substr($string, -1*$tail); } sub jedi2perl { my ($class, $jedi) = @_; $jedi or return; my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi ); open (FOO, ">>/tmp/JSON2perl_dump.txt"); print FOO Dumper($msg), "\n\n"; close FOO; $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt"); return $msg; } our @datecodes = (35, 359, 17, 191, 69, 76, 75, 79, 85, 74, 84, 223); # ->process_jedi($message, $server, $e) sub process_jedi { my $class = shift; my $message = shift or return; my $server = shift || {}; # context my $jedi = ref($message) ? $message->jedi : $message; # If we got an object, it's an edi_message. A string is the jedi content itself. unless ($jedi) { $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi or jedi scalar)!"); return; } my $e = @_ ? shift : new_editor(); my $perl = __PACKAGE__->jedi2perl($jedi); if (ref($message) and not $perl) { $message->error(($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi"); $message->error_time('NOW'); $e->xact_begin; $e->udpate_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!"); $e->xact_commit; return; } if (! $perl->{body}) { $logger->warn("EDI interchange body not found!"); return; } if (! $perl->{body}->[0]) { $logger->warn("EDI interchange body not a populated arrayref!"); return; } # Crazy data structure. Most of the arrays will be 1 element... we think. # JEDI looks like: # {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ... # # So you might access it like: # $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH' $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " messages(s)"); my @messages; my $i = 0; foreach my $part (@{$perl->{body}}) { $i++; unless (ref $part and scalar keys %$part) { $logger->warn("EDI interchange message $i lacks structure. Skipping it."); next; } foreach my $key (keys %$part) { if ($key ne 'ORDRSP') { # We only do one type for now. TODO: other types here $logger->warn("EDI interchange $i contains unhandled '$key' message. Ignoring it."); next; } my $msg = __PACKAGE__->message_object($key, $part->{$key}) or next; push @messages, $msg; my $tag4343 = $msg->xpath('BGM/4343'); my $tag1225 = $msg->xpath('BGM/1225'); if (ref $tag4343) { $logger->info(sprintf "EDI $key BGM/4343 Response Type: %s - %s", $tag4343->value, $tag4343->label) } else { $logger->warn("EDI $key BGM/4343 Response Type Code unrecognized"); # next; #? } if (ref $tag1225) { $logger->info(sprintf "EDI $key BGM/1225 Message Function: %s - %s", $tag1225->value, $tag1225->label); } else { $logger->warn("EDI $key BGM/1225 Message Function Code unrecognized"); # next; #? } # TODO: currency check, just to be paranoid # *should* be unnecessary (vendor should reply in currency we send in ORDERS) # That begs a policy question: how to handle mismatch? convert (bad accuracy), reject, or ignore? I say ignore. # ALL those codes below are basically some form of (lastest) delivery date/time # see, e.g.: http://www.stylusstudio.com/edifact/D04B/2005.htm # The order is the order of definitiveness (first match wins) # Note: if/when we do serials via EDI, dates (and ranges/periods) will need massive special handling my @dates; my $ddate; foreach my $date ($msg->xpath('delivery_schedule')) { my $val_2005 = $date->xpath_value('DTM/2005') or next; (grep {$val_2005 eq $_} @datecodes) or next; # no match means some other kind of date we don't care about push @dates, $date; } if (@dates) { DATECODE: foreach my $dcode (@datecodes) { # now cycle back through hits in order of dcode definitiveness foreach my $date (@dates) { $date->xpath_value('DTM/2005') == $dcode or next; $ddate = $date->xpath_value('DTM/2380') and last DATECODE; # TODO: conversion based on format specified in DTM/2379 (best encapsulated in Business::EDI) } } } foreach my $lid ($msg->part('line_detail')) { my $eg_line = __PACKAGE__->eg_li($lid, $server, $e) or next; my $li_date = $lid->xpath_value('DTM') || $ddate; my $price = $lid->xpath_value('line_price/PRI/5118') || ''; $lid->expected_recv_time($li_date) if $li_date; $lid->estimated_unit_price($price) if $price; # foreach ($lid->part('all_QTY')) { } $e->xact_begin; $e->update_acq_lineitem($eg_line) or $logger->warn("EDI: update_acq_lineitem FAILED"); $e->xact_commit; # print STDERR "Lineitem to update: ", Dumper($eg_line); } } } return \@messages; } # returns message object if processing should continue # returns false/undef value if processing should abort sub message_object { my $class = shift; my $key = shift or return; my $body = shift or return; my $msg = Business::EDI->detect_version($body); unless ($msg) { $logger->error("EDI interchange message: $key body failed Business::EDI constructor. Skipping it."); return; } my $val_0065 = $msg->xpath_value('UNH/S009/0065') || ''; unless ($val_0065 eq $key) { $logger->error("EDI $key UNH/S009/0065 ('$val_0065') conflicts w/ message type $key. Aborting"); return; } my $val_0051 = $msg->xpath_value('UNH/S009/0051') || ''; unless ($val_0051 eq 'UN') { $logger->warn("EDI $key UNH/S009/0051 designates '$val_0051', not 'UN' as controlling agency. Attempting to process anyway"); } my $val_0054 = $msg->xpath_value('UNH/S009/0054') || ''; if ($val_0054) { $logger->info("EDI $key UNH/S009/0054 uses Spec revision version '$val_0054'"); # Possible Spec Version limitation # my $yy = $tag_0054 ? substr($val_0054,0,2) : ''; # unless ($yy eq '00' or $yy > 94 and $yy < # $logger->warn("EDI $key UNH/S009/0051 Spec revision version '$val_0054' not supported"); # } } else { $logger->warn("EDI $key UNH/S009/0054 does not reference a known Spec revision version"); } return $msg; } =head2 ->eg_li($lineitem_object, [$server, $editor]) my $line_item = OpenILS::Application::Acq::EDI->eg_li($edi_line); Updates: acq.lineitem.estimated_unit_price, acq.lineitem.state (dependent on mapping codes), acq.lineitem.expected_recv_time, acq.lineitem.edit_time (consequently) =cut sub eg_li { my ($class, $line, $server, $e) = @_; $line or return; $e ||= new_editor(); my $id; # my $rff = $line->part('line_reference/RFF') or $logger->warn("EDI ORDRSP line_detail/RFF missing!"); my $val_1153 = $line->xpath_value('line_reference/RFF/1153') || ''; my $val_1154 = $line->xpath_value('line_reference/RFF/1154') || ''; my $val_1082 = $line->xpath_value('LIN/1082') || ''; $val_1154 =~ s#^.*\/##; # Many sources send the ID as 'order_ID/LI_ID' $val_1082 =~ s#^.*\/##; # Many sources send the ID as 'order_ID/LI_ID' # now do a lot of checking if ($val_1153 eq 'LI') { $id = $val_1154 or $logger->warn("EDI ORDRSP RFF/1154 reference to LI empty. Attempting failover to LIN/1082"); } else { $logger->warn("EDI ORDRSP RFF/1153 unexpected value ('$val_1153', not 'LI'). Attempting failover to LIN/1082"); } if ($id and $val_1082 and $val_1082 ne $id) { $logger->warn("EDI ORDRSP LIN/1082 Line Item ID mismatch ($id vs. $val_1082): cannot target update"); return; } $id ||= $val_1082 || ''; print STDERR "EDI retrieve/update lineitem $id\n"; my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id); # Could send {options} if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') { $logger->error("EDI failed to retrieve lineitem by id '$id' for server " . $server->remote_host); return; } unless ((! $server) or (! $server->provider)) { if ($server->provider != $li->provider) { # links go both ways: acq.provider.edi_default and acq.edi_account.provider $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider(" . $li->provider . "). Checking acq.provider.edi_default..."); my $provider = $e->retrieve_acq_provider($li->provider); if ($provider->edi_default != $server->id) { $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s", $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default); return; } } } my $key = $line->xpath('LIN/1229') or $logger->warn("EDI LIN/1229 Action Code missing!"); $key or return; my $eg_reason = $e->retrieve_acq_cancel_reason(1000 + $key->value); # DB populated w/ spec keys in 1000's $eg_reason or $logger->warn(sprintf "EDI LIN/1229 Action Code '%s' (%s) not recognized in acq.cancel_reason", $key->value, $key->label); $eg_reason or return; $li->cancel_reason($eg_reason->id); unless ($eg_reason->keep_debits) { $logger->warn("EDI LIN/1229 Action Code '%s' (%s) has keep_debits=0", $key->value, $key->label); } my $new_price = $line->xpath_value("PRI/5118"); $li->estimated_unit_price($new_price) if $new_price; return $li; } # caching not needed for now (edi_fetcher is asynchronous) # sub get_reason { # my ($class, $key, $e) = @_; # $reasons->{$key} and return $reasons->{$key}; # $e ||= new_editor(); # $reasons->{$key} = $e->retrieve_acq_cancel_reason($key); # return $reasons->{$key}; # } 1; __END__ Example JSON data. Note the pseudo-hash 2-element arrays. [ 'SG26', [ [ 'LIN', { '1229' => '5', '1082' => 1, 'C212' => { '7140' => '9780446360272', '7143' => 'EN' } } ], [ 'IMD', { '7081' => 'BST', '7077' => 'F', 'C273' => { '7008' => [ 'NOT APPLIC WEBSTERS NEW WORLD THESA' ] } } ], [ 'QTY', { 'C186' => { '6063' => '21', '6060' => 10 } } ], [ 'QTY', { 'C186' => { '6063' => '12', '6060' => 10 } } ], [ 'QTY', { 'C186' => { '6063' => '85', '6060' => 0 } } ], [ 'FTX', { '4451' => 'LIN', 'C107' => { '4441' => '01', '3055' => '28', '1131' => '8B' } } ], [ 'SG30', [ [ 'PRI', { 'C509' => { '5118' => '4.5', '5387' => 'SRP', '5125' => 'AAB' } } ] ] ], [ 'SG31', [ [ 'RFF', { 'C506' => { '1154' => '8/1', '1153' => 'LI' } } ] ] ] ] ],