1 package OpenILS::Application::Acq::EDI;
2 use base qw/OpenILS::Application/;
4 use strict; use warnings;
8 use OpenSRF::AppSession;
9 use OpenSRF::EX qw/:try/;
10 use OpenSRF::Utils::Logger qw(:logger);
11 use OpenSRF::Utils::JSON;
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;
20 use Business::EDI::Segment::BGM;
26 my($class, %args) = @_;
27 my $self = bless(\%args, $class);
35 return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
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',
48 ## Just for debugging stuff:
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);;
59 # __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg'); # debugging
61 __PACKAGE__->register_method(
63 api_name => 'open-ils.acq.edi.retrieve',
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.',
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'}
75 desc => 'List of new message IDs (empty if none)',
82 my ($self, $e, $set, $max) = @_; # $e is a working editor
85 $set ||= __PACKAGE__->retrieve_vendors($e);
89 foreach my $account (@$set) {
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);
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) {
102 $max and $count > $max and last;
104 my $io = IO::Scalar->new(\$content);
105 unless ($server->get({remote_file => $_, local_file => $io})) {
106 $logger->error("(S)FTP get($_) failed");
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);
115 $e->create_acq_edi_message($incoming);
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;
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
131 my ($class, $account, $message_ids, $e) = @_; # $e is a working editor
133 ($account and scalar @$message_ids) or return;
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)");
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)");
147 unless ($server = __PACKAGE__->remote_account($account, 1)) { # assignment, not comparison
148 $logger->error("Failed remote account connection for $log_str");
151 foreach (@messageset) {
152 $_ or next; # we already warned about bum ids
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, single_ext => 1})) {
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");
166 $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
167 $error = "put FAILED: " . ($server->error || 'UNKOWNN');
171 $_->error_time('NOW');
173 $logger->info("Calling update_acq_edi_message");
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');
180 # There's always an update, even if we failed.
182 __PACKAGE__->record_activity($account, $e); # There's always an update, even if we failed.
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);
204 $edi_message->status('translated');
205 $edi_message->translate_time('NOW');
207 $edi_message->edi($ret->value); # translator returns an object
209 $edi_message->jedi($ret->value); # translator returns an object
214 sub retrieve_vendors {
215 my ($self, $e, $vendor_id, $last_activity) = @_; # $e is a working editor
219 my $criteria = {'+acqpro' => {active => 't'}};
220 # $criteria->{vendor_id} = $vendor_id if $vendor_id;
221 return $e->search_acq_edi_account([
226 acqedi => ['provider']
230 # {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
233 # This is the SRF-exposed call, so it does checkauth
236 my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
238 my $e = new_editor(authtoken=>$auth);
239 unless ($e and $e->checkauth()) {
240 $logger->warn("checkauth failed for authtoken '$auth'");
243 # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency); # add permission here ?
245 my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
246 return __PACKAGE__->retrieve_core($e, $set, $max);
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.
256 my $vendor = shift or return;
257 my $no_override = @_ ? shift : 0;
259 $verbose and $logger->warn("vendor: " . Dumper($vendor));
260 foreach (keys %map) {
261 $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
263 unless ($no_override) {
264 $args{remote_path} = $vendor->in_dir; # override "path" with "in_dir"
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));
276 # The point of remote_account is to get the RemoteAccount object with args from the DB
279 my ($self, $vendor, $outbound, $e) = @_;
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
285 my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
286 $vendor = shift @$set_of_one;
289 return OpenILS::Utils::RemoteAccount->new(
290 $self->field_map($vendor, $outbound)
294 sub record_activity {
295 my ($class, $account, $e) = @_;
298 $logger->info("EDI record_activity calling update_acq_edi_account");
299 $account->last_activity('NOW') or return;
301 $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
308 my $string = shift or return '';
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);
318 # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
322 my ($class, $jedi) = @_;
324 my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi );
325 open (FOO, ">>/tmp/JSON2perl_dump.txt");
326 print FOO Dumper($msg), "\n\n";
328 $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt");
332 # ->process_jedi($message, $server, $e)
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.
339 $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi or jedi scalar)!");
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');
348 $e->udpate_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!");
352 if (! $perl->{body}) {
353 $logger->warn("EDI interchange body not found!");
356 if (! $perl->{body}->[0]) {
357 $logger->warn("EDI interchange body not a populated arrayref!");
361 # Crazy data structure. Most of the arrays will be 1 element... we think.
363 # {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ...
365 # So you might access it like:
366 # $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH'
368 $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " messages(s)");
371 foreach my $part (@{$perl->{body}}) {
373 unless (ref $part and scalar keys %$part) {
374 $logger->warn("EDI interchange message $i lacks structure. Skipping it.");
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.");
382 my @li_chunk = __PACKAGE__->parse_ordrsp($part->{$key}, $server, $e);
383 $logger->info("EDI $key parsing returned " . scalar(@li_chunk) . " line items");
387 return \@li, $perl; # TODO process perl
391 =head2 ->parse_ordrsp($segments, $server, $e)
393 Returns array of lineitems.
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'}
401 my ($class, $segments, $server, $e, $test) = @_; # test not implemented
404 $logger->info("EDI " . scalar(@$segments) . " segments in $type message");
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");
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");
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");
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;
425 $logger->error(sprintf "EDI $tag/1225 Message Function Code '%s' unrecognized. Aborting", ($segbody->{1225} || ''));
431 foreach my $segment (@$segments) { # The main pass
432 my ($tag, $segbody, @extra) = @$segment;
433 next unless ($tag and $segbody); # warnings above
435 my @chunks = @{$segbody->{SG26}};
436 my $count = scalar(@chunks);
437 $logger->debug("EDI LIN/SG26 has $count chunks");
448 # $label eq 'QTY' and push @qtys, $body;
449 $label eq 'RFF' or next;
451 unless ($obj = Business::EDI::Segment::RFF->new($body)) { # assignment, not comparison
452 $logger->error("EDI $tag/$label failed to convert to an object");
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);
457 push @lins, \@chunks;
458 } elsif ($tag ne 'UNH' and $tag ne 'BGM') {
462 @ignored and $logger->debug("EDI: ignoring " . scalar(@ignored) . " segment(s): " . join(', ', @ignored));
466 =head2 ->update_li($lineitem_id, $lineitem_object, [$server, $editor])
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)
477 my ($class, $id, $object, $server, $e) = @_;
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'");
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);
499 return; # TODO: actual updates
501 $e->update_acq_lineitem($li) or $logger->warn("EDI: in update_li, update_acq_lineitem FAILED");
503 # print STDERR "Lineitem to update: ", Dumper($li);