• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/env perl

=begin # method suitable for a .net service (doesn't use a wsdl)
see: How to Call a .NET-based Web Service Using the SOAP::Lite Perl Library
http://msdn.microsoft.com/en-gb/library/ms995764.aspx

* By default, SOAP::Lite creates a SOAPAction header that looks like [URI]#[method].
    However, .NET requires the SOAPAction header to look like [URI]/[method].
* The SOAP specification does not specify the format of the SOAPAction HTTP header
    beyond indicating that it is a URI, so it is not surprising that SOAP::lite
    and .NET have different default formats.
* SOAP::Lite uses the SOAP encoding (section 5 of the soap 1.1 spec), and the
    default for .NET Web Services is to use a literal encoding.
* We will override the default SOAP::Lite implementation of on_action() with code
    that creates a SOAPAction URI that matches what the .NET-based Web service expects.
* we create[d] a variable called $method that contains the name of the WebMethod
    we are calling. We also add[ed] an attribute to the method called xmlns.

due to frequency of $response->fault, logs to own logfile (logs/syncona-14mg.log)
=cut

use lib (
    '/home/raj/perl5/lib/perl5',
    '/home/raj/apps/HILIS4/lib',
);

use Data::Printer;
use Modern::Perl;
# SOAP::Lite requires Crypt::SSLeay, but cpan failed so installed libcrypt-ssleay-perl
use SOAP::Lite; # +trace => 'all';

use LIMS::Local::ScriptHelpers;

my $tools = LIMS::Local::ScriptHelpers->new();
my $dbix  = $tools->dbix();
$dbix->lc_columns = 0; # preserve col case (eg vialId)

my $xmlns = 'https://www.hmrn.org/soap/syncona'; # ie namespace
my $addr  = 'https://www.hmrn.org/soap/services/syncona.asmx';
my $pass  = '43Sd86796gh8PG867eDD8F98p9hPMGT85esvBDF98p9D9t97';
my $func  = 'UploadTable';

my $soap = SOAP::Lite->uri($xmlns) # doesn't seem to use uri val, but must not be undef
    ->on_action( sub { join '/', $xmlns, $_[1] } ) # appends $func, or just use $func direct
    ->proxy($addr); # p $soap;

my $method = SOAP::Data->name($func)->attr({ xmlns => $xmlns }); # p $method;

{ # storage_racks:
    my $tbl  = 'storage_racks';
    my $cols = get_headers($tbl); # p $cols; exit;
    my $data = $dbix->select( $tbl, $cols, {}, [ 'id' ] )->arrays; # p $data;

    send_data($tbl, $cols, $data);
}
{ # request_storage:
    my $tbl  = 'request_storage';
    my $cols = get_headers($tbl); # p $cols; exit;
    my $data = $dbix->select( $tbl, $cols )->arrays; # p $data; exit;

    send_data($tbl, $cols, $data);
}

sub send_data {
    my ($name, $headers, $data) = @_; # str, arrayref, AoA

    my @combined = do {
		no warnings 'uninitialized'; # eg vial_location, vol & conc can be null
		map { join ',', @$_ } ( $headers, @$data );
	};
    my $csvData = join "\n", @combined; # p $csvData; return;

    my @params = (
        SOAP::Data->name('pass')->value( $pass ),
        SOAP::Data->name('name')->value( $name ),
        SOAP::Data->name('csvData')->value( $csvData ),
    );

    my $response = $soap->call( $method => @params );
    warn sprintf '%s: %s',  # dumps msg in syncona-14mg.log
        $tools->time_now(), $response->faultstring if $response->fault;
    # print $response->result, "\n";
}

sub get_headers {
    my $tbl = shift;
	my @cols = map $_->{Field}, $dbix->query('show columns from '.$tbl)->hashes;
	return \@cols;
}