## -*- Mode: CPerl -*-
##
## File: DTA::CAB::Server::XmlRpc.pm
## Author: Bryan Jurish <moocow@cpan.org>
## Description: DTA::CAB XML-RPC server using RPC::XML

package DTA::CAB::Server::XmlRpc;
use DTA::CAB::Server;
use RPC::XML;
use RPC::XML::Server;
use Encode qw(encode decode);
use Socket qw(SOMAXCONN);
use Carp;
use strict;

##==============================================================================
## Globals
##==============================================================================

our @ISA = qw(DTA::CAB::Server);

BEGIN {
  ##-- RPC::XML::Server v1.48 (kaskade / debian squeeze) DOES have     add_proc() but does NOT have add_procedure()
  ##-- RPC::XML::Server v1.68 (kaskade2 / debian wheezy) does NOT have add_proc() but DOES     have add_procedure()
  if (!RPC::XML::Server->can('add_procedure') && RPC::XML::Server->can('add_proc')) {
    *RPC::XML::Server::add_procedure = \&RPC::XML::Server::add_proc;
  }
}

##==============================================================================
## Constructors etc.
##==============================================================================

## $obj = CLASS_OR_OBJ->new(%args)
##  + object structure: HASH ref
##    {
##     ##-- Underlying server
##     xsrv => $xsrv,      ##-- low-level server, an RPC::XML::Server object
##     xopt => \%opts,     ##-- options for RPC::XML::Server->new()
##     xrun => \%opts,     ##-- options for RPC::XML::Server->server_loop()
##     ##
##     ##-- XML-RPC procedure naming
##     procNamePrefix => $prefix, ##-- default: 'dta.cab.'
##     ##
##     ##-- hacks
##     encoding => $enc,          ##-- sets $RPC::XML::ENCODING on prepare(), used by underlying server
##     ##
##     ##-- security
##     allowUserOptions => $bool, ##-- allow user options? (default: true)
##     ##
##     ##-- logging
##     logRegisterProc => $level, ##-- log xml-rpc procedure registration at $level (default='trace')
##     logCall => $level,         ##-- log client IP and procedure at $level (default='debug')
##     logCallData => $bool,      ##-- log client data queries at $level (default=undef: none)
##     ##
##     ##-- (inherited from DTA::CAB::Server)
##     as  => \%analyzers,    ##-- ($name=>$cab_analyzer_obj, ...)
##     aos => \%anlOptions,   ##-- ($name=>\%analyzeOptions, ...) : %opts passed to $anl->analyzeXYZ($xyz,%opts)
##    }
sub new {
  my $that = shift;
  return $that->SUPER::new(
			   ##-- underlying server
			   xsrv => undef,
			   xopt => {
				    #path => '/',         ##-- URI path for underlying server (HTTP::Daemon)
				    #host => '0.0.0.0',   ##-- host for underlying server (HTTP::Daemon)
				    port => 8088,         ##-- port for underlying server (HTTP::Daemon)
				    queue => SOMAXCONN,   ##-- queue size for underlying server (HTTP::Daemon)
				    #timeout => 10,       ##-- connection timeout (HTTP::Daemon)
				    ##
				    #no_default => 1,     ##-- disable default methods (default=enabled)
				    #auto_methods => 1,   ##-- enable auto-method seek (default=0)
				   },
			   xrun => {
				    #signal => [qw(INT HUP TERM)],
				    signal => 0, ##-- don't catch any signals by default
				   },
			   ##
			   ##-- XML-RPC procedure naming
			   procNamePrefix => 'dta.cab.',
			   ##
			   ##-- hacks
			   encoding => 'UTF-8',
			   ##
			   ##-- security
			   allowUserOptions => 1,
			   ##
			   ##-- logging
			   logRegisterProc => 'trace',
			   logCall => 'debug',
			   logCallData => undef,
			   ##
			   ##-- user args
			   @_
			  );
}

## undef = $obj->initialize()
##  + called to initialize new objects after new()

##==============================================================================
## Methods: Encoding Hacks
##==============================================================================

## \%rpcProcHash = $srv->wrapMethodEncoding(\%rpcProcHash)
##  + wraps an RPC::XML::procedure spec into $srv->{encoding}-safe code,
##    only if $rpcProcHash{wrapEncoding} is set to a true value
sub wrapMethodEncoding {
  my $srv = shift;
  if (defined($srv->{encoding}) && $_[0]{wrapEncoding}) {
    my $code_orig = $_[0]{code_orig} = $_[0]{code};
    $_[0]{code} = sub {
      my $rv  = $code_orig->(@_);
      my $rve = DTA::CAB::Utils::deep_encode($srv->{encoding}, $rv);
     return $rve;
    };
  }
  return $_[0];
}


##==============================================================================
## Methods: Generic Server API
##==============================================================================

## $rc = $srv->prepareLocal()
##  + subclass-local initialization
sub prepareLocal {
  my $srv = shift;

  ##-- get RPC::XML object
  my $xsrv = $srv->{xsrv} = RPC::XML::Server->new(%{$srv->{xopt}});
  if (!ref($xsrv)) {
    $srv->logcroak("could not create underlying RPC::XML::Server object: $xsrv\n");
  }

  ##-- hack: set server encoding
  if (defined($srv->{encoding})) {
    $srv->info("(hack) setting RPC::XML::ENCODING = $srv->{encoding}");
    $RPC::XML::ENCODING = $srv->{encoding};
  }
  ##-- hack: set $RPC::XML::FORCE_STRING_ENCODINTG
  $srv->info("(hack) setting RPC::XML::FORCE_STRING_ENCODING = 1");
  $RPC::XML::FORCE_STRING_ENCODING = 1;

  ##-- register analysis methods
  my ($aname,$a,$aopts, $xp, $proc);
  while (($aname,$a)=each(%{$srv->{as}})) {
    $aopts = $srv->{aos}{$aname};
    $aopts = RPC::XML::struct->new($aopts) if ($aopts);
    foreach ($a->xmlRpcMethods) {
      if (UNIVERSAL::isa($_,'HASH')) {
	##-- hack method 'name'
	$_->{name} = 'analyze' if (!defined($_->{name}));
	$_->{name} = $aname.'.'.$_->{name} if ($aname);
	$_->{name} = $srv->{procNamePrefix}.$_->{name} if ($srv->{procNamePrefix});
	$_->{opts} = $aopts;
	$srv->wrapMethodEncoding($_); ##-- hack encoding?
      }
      $xp = DTA::CAB::Server::XmlRpc::Procedure->new($_);
      $xp = $xsrv->add_method($xp);
      if (!ref($xp)) {
	$srv->error("could not register XML-RPC procedure ".(ref($_) ? "$_->{name}()" : "'$_'")." for analyzer '$aname'\n",
		    " + RPC::XML::Server error: $xp\n",
		   );
      } else {
	$srv->vlog($srv->{logRegisterProc},"registered XML-RPC procedure $_->{name}() for analyzer '$aname'\n");
      }
    }
  }

  ##-- register 'listAnalyzers' method
  my $listproc = $srv->listAnalyzersProc;
  $xsrv->add_procedure( DTA::CAB::Server::XmlRpc::Procedure->new($listproc) );
  $srv->vlog($srv->{logRegisterProc},"registered XML-RPC listing procedure $listproc->{name}()\n");

  ##-- propagate security and logging options to underlying server
  $xsrv->{$_} = $srv->{$_} foreach (qw(allowUserOptions logCall logCallData));

  return 1;
}

## $rc = $srv->run()
##  + run the server
sub run {
  my $srv = shift;
  $srv->prepare() if (!$srv->{xsrv}); ##-- sanity check
  $srv->logcroak("run(): no underlying RPC::XML object!") if (!$srv->{xsrv});
  $srv->info("server starting on host ", $srv->{xsrv}->host, ", port ", $srv->{xsrv}->port, "\n");
  $srv->{xsrv}->server_loop(%{$srv->{runopt}});
  $srv->info("server exiting\n");
  return $srv->finish();
}

##==============================================================================
## Methods: Additional
##==============================================================================

## \%procSpec = $srv->listAnalyzersProc()
sub listAnalyzersProc {
  my $srv = shift;
  my $anames = DTA::CAB::Utils::deep_encode($srv->{encoding},
					    [ map {($srv->{procNamePrefix}||'').$_ } keys(%{$srv->{as}}) ]
					   );
  return {
	  name => ($srv->{procNamePrefix}||'').'listAnalyzers',
	  code => sub { return $anames; },
	  help => 'list registered analyzer names',
	  signature => [ 'array' ],
	 };
}

##========================================================================
## PACKAGE: DTA::CAB::Server::XmlRpc::Procedure
##  + subclass of RPC::XML::Procedure
package DTA::CAB::Server::XmlRpc::Procedure;
use RPC::XML::Procedure;
use strict;
use Data::Dumper;
our @ISA = ('RPC::XML::Procedure','DTA::CAB::Logger');

## $proc = CLASS->new(\%methodHash)

## $rv = $proc->call($XML_RPC_SERVER, @PARAMLIST)
sub call {
  if (defined($_[1]{logCall})) {
    $_[0]->vlog($_[1]{logCall}, "$_[0]{name}(): client=".($_[1]{peerhost}||'(unavailable)')); #:$_[1]{peerport}
  }
  if (defined($_[1]{logCallData})) {
    local $Data::Dumper::Purity = 1;
    local $Data::Dumper::Pad = "\t";
    local $Data::Dumper::Terse = 0;
    local $Data::Dumper::Indent = 1;
    $_[0]->vlog($_[1]{logCallData}, "call:\n", Data::Dumper->Dump([ $_[1]{peerhost}, $_[0]{name}, [@_[2..$#_]]], [qw(CLIENT PROC PARAMS)]));
  }
  if (@_ > 3) {
    return $_[0]->SUPER::call(@_[1..($#_-1)],
			      bless({
				     ($_[0]{opts}                        ? (%{$_[0]{opts}}) : qw()),
				     ($_[1]{allowUserOptions} && $_[$#_] ? (%{$_[$#_]})     : qw()),
				    },'RPC::XML::struct'),
			     );
  }
  elsif ($_[0]{opts}) {
    return $_[0]->SUPER::call(@_[1..$#_],
			      bless( { %{$_[0]{opts}} },'RPC::XML::struct'),
			     );
  }
  else {
    return $_[0]->SUPER::call(@_[1..$#_]);
  }
}



1; ##-- be happy

__END__

##========================================================================
## POD DOCUMENTATION, auto-generated by podextract.perl, edited

##========================================================================
## NAME
=pod

=head1 NAME

DTA::CAB::Server::XmlRpc - DTA::CAB XML-RPC server using RPC::XML

=cut

##========================================================================
## SYNOPSIS
=pod

=head1 SYNOPSIS

 use DTA::CAB::Server::XmlRpc;
 
 ##========================================================================
 ## Constructors etc.
 
 $srv = DTA::CAB::Server::XmlRpc->new(%args);
 
 ##========================================================================
 ## Methods: Encoding Hacks
 
 \%rpcProcHash = $srv->wrapMethodEncoding(\%rpcProcHash);
 
 ##========================================================================
 ## Methods: Generic Server API
 
 $rc = $srv->prepareLocal();
 $rc = $srv->run();
 
 ##========================================================================
 ## Methods: Additional
 
 \%procSpec = $srv->listAnalyzersProc();

=cut

##========================================================================
## DESCRIPTION
=pod

=head1 DESCRIPTION

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::XmlRpc: Globals
=pod

=head2 Globals

=over 4

=item Variable: @ISA

DTA::CAB::Server::XmlRpc
inherits from
L<DTA::CAB::Server|DTA::CAB::Server>.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::XmlRpc: Constructors etc.
=pod

=head2 Constructors etc.

=over 4

=item new

 $srv = $CLASS_OR_OBJ->new(%args);

Constructor.

%args, %$srv:

 ##-- Underlying server
 xsrv => $xsrv,             ##-- low-level server, an RPC::XML::Server object
 xopt => \%opts,            ##-- options for RPC::XML::Server->new()
 xrun => \%opts,            ##-- options for RPC::XML::Server->server_loop()
 ##
 ##-- XML-RPC procedure naming
 procNamePrefix => $prefix, ##-- default: 'dta.cab.'
 ##
 ##-- hacks
 encoding => $enc,          ##-- sets $RPC::XML::ENCODING on prepare(), used by underlying server
 ##
 ##-- (inherited from DTA::CAB::Server)
 as => \%analyzers,         ##-- ($name => $cab_analyzer_obj, ...)
 aos => \%name2options,     ##-- ($name => \%analyzerOptions, ...)

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::XmlRpc: Methods: Encoding Hacks
=pod

=head2 Methods: Encoding Hacks

=over 4

=item wrapMethodEncoding

 \%rpcProcHash = $srv->wrapMethodEncoding(\%rpcProcHash);

Wraps an RPC::XML::procedure spec into $srv-E<gt>{encoding}-safe code,
only if $rpcProcHash{wrapEncoding} is set to a true value.
This is a hack to which we resort because RPC::XML is so stupid.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::XmlRpc: Methods: Generic Server API
=pod

=head2 Methods: Generic Server API

=over 4

=item prepareLocal

 $rc = $srv->prepareLocal();

Subclass-local post-constructor initialization.
Registers analysis methods, generates wrapper closures, etc.
Returns true on success, false otherwise.

=item run

 $rc = $srv->run();

Runs the server.
Doesn't return until the server dies (or is killed).

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::XmlRpc: Methods: Additional
=pod

=head2 Methods: Additional

=over 4

=item listAnalyzersProc

 \%procSpec = $srv->listAnalyzersProc();

Returns an RPC::XML specification for the 'listAnalyzers' method,
which just returns an array containing the names of all known analyzers.
Used by L</prepareLocal>().

=back

=cut

##========================================================================
## END POD DOCUMENTATION, auto-generated by podextract.perl

##======================================================================
## Footer
##======================================================================
=pod

=head1 AUTHOR

Bryan Jurish E<lt>moocow@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009-2019 by Bryan Jurish

This package is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.1 or,
at your option, any later version of Perl 5 you may have available.




=cut