GRNOC-WebService-Client/lib/GRNOC/WebService/Client.pm
#--------------------------------------------------------------------
#----- GRNOC Web Service Client
#-----
#----- Copyright(C) 2015 The Trustees of Indiana University
#--------------------------------------------------------------------
#----- module for interacting with cosign protected grnoc web services
#---------------------------------------------------------------------
package GRNOC::WebService::Client;
use strict;
use warnings;
use GRNOC::WebService::Client::Paginator;
use HTTP::Cookies;
use HTML::Form;
use LWP::UserAgent::Determined;
use Carp qw(longmess shortmess);
use CGI;
use JSON::XS;
use Data::Dumper;
use GRNOC::Config;
use Time::HiRes qw(gettimeofday tv_interval);
use File::MMagic;
use HTTP::Request::Common;
use Fcntl qw(:flock);
use List::Util;
use Storable 'dclone';
use XML::LibXML;
$HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
our $VERSION = '1.5.1';
use constant DEFAULT_LIMIT => 1000;
use constant CONTENT_PAOS => 'application/vnd.paos+xml';
use constant PAOS_HEADER => 'ver="urn:liberty:paos:2003-08";"urn:oasis:names:tc:SAML:2.0:profiles:SSO:ecp"';
=head1 NAME
GRNOC::WebService::Client - GlobalNOC Web Service Client
=head1 SYNOPSIS
Module to implement clients that interact with cosign protected GRNOC CDS web services.
Default Method is GET but POST can be used as well.
Quick summary of what the module does.
Perhaps a little code snippet.
use GRNOC::WebService::Client;
my $svc = GRNOC::WebService::Client->new(
url => "https://sherpa.grnoc.iu.edu/web-service/foobar/example.cgi",
uid => "test_uid",
passwd => $password,
realm => 'Authentication Required', # needed for HTTP basic auth
usePost => 0,
debug => 0
);
#--- get list of available methods
my $res= $svc->help();
if(!defined $res){
print Dumper($svc->get_error());
}
else{
print Dumper($res);
}
#-- get help for specific method
my $res= $svc->help(method_name => 'echo');
if(!defined $res){
print Dumper($svc->get_error());
}
else{
print Dumper($res);
}
#--- call a web service method
my $res= $svc->echo(data => 'This is a test');
if(!defined $res){
print Dumper($svc->get_error());
}
else{
print Dumper($res);
}
...
=cut
#--- used do service name lookups, this is the place to support multiple / redundange service name services
sub _service_lookup {
my $self = shift;
my $service_name = shift;
return $self->{'service_urls'}{$service_name};
}
#--- return one of the urls assocated with a service, this is the place to let us randomly pick from multiple and to in
#--- recover from service instance outage
sub _setup_urls {
my $self = shift;
my $service_name = shift;
my $res = $self->_service_lookup($service_name);
my $count = 0;
if (defined $res) {
my @sorted_by_weight = sort {$a->{'weight'} <=> $b->{'weight'}} @$res;
foreach my $location (@sorted_by_weight) {
my $url = $location->{'url'};
my $weight = $location->{'weight'};
push(@{$self->{'urls'}{$weight}},$url);
$count++;
}
}
if ($self->{'debug'}) {
warn "_setup_urls: found $count urls for service $service_name\n";
}
return $count;
}
#--- loads the default realm from the config file
sub _load_default_realm {
my $self = shift;
my $config_file = $self->{'config_file'};
my $username = $self->{'uid'};
#--- get the config
my $config = GRNOC::Config->new(config_file => $config_file,
force_array => 1);
if (!defined $config) {
$self->_set_error("unable to open $config_file: $!\n");
return;
}
my $user_realm_mappings = $config->get('/config/match');
foreach my $user_realm_mapping ( @$user_realm_mappings ) {
if( $username =~ $user_realm_mapping->{'regex'} ){
$self->{'default_realm'} = $user_realm_mapping->{'realm'};
last;
}
}
return 1;
}
#-- this loads config which contains the nameserver urls, basically bootstrapping.
sub _load_config {
my $self = shift;
#----- get the config
my $config_file = $self->{'service_cache_file'};
my $cfg = GRNOC::Config->new(config_file => $config_file);
if (!defined $cfg) {
$self->_set_error("unable to open $config_file: $!\n");
return undef;
}
#--- clean out any previous urls
$self->{'service_urls'} = undef;
my $clouds = $cfg->get("/config/cloud");
foreach my $cloud (@$clouds) {
my $cloud_id = $cloud->{'id'};
my @classes = keys %{$cloud->{'class'}};
foreach my $class_id (@classes) {
my $versions = $cloud->{'class'}->{$class_id}->{'version'};
foreach my $version (@$versions) {
my $version_number = $version->{'value'};
my @services = keys %{$version->{'service'}};
foreach my $service_name (@services) {
my @locations = @{$version->{'service'}->{$service_name}->{'location'}};
foreach my $location (@locations) {
my $weight = $location->{'weight'};
my $url = $location->{'url'};
my $full_name = "urn:publicid:IDN+grnoc.iu.edu:" . $cloud_id . ":" . $class_id . ":" . $version_number . ":" . $service_name;
push(@{$self->{'service_urls'}{$full_name}}, {'weight' => $weight,
'url' => $url});
}
}
}
}
}
return 1;
}
sub _ns_service_lookup {
my $self = shift;
my $service_name = $self->{'service_name'};
for my $url (@{$self->{'name_services'}}) {
if ($self->{'debug'}) {
warn "trying to lookup $service_name using: $url\n";
}
my $ns = GRNOC::WebService::Client->new(
url => $url,
uid => $self->{'uid'},
passwd => $self->{'passwd'},
debug => $self->{'debug'},
);
my $res = $ns->get_locations_by_urn(urn => $service_name);
$self->{'service_urls'}{$self->{'service_name'}} = $res->{'results'};
}
}
#--protected method which sets a new error and prints it to stderr
sub _set_error {
my $self = shift;
my $error = shift;
if ($self->{'debug'}) {
#--- printing out full stack trace might reveal passwords to the constructor
#--- so we should only drop the stack trace in debug
$self->{'error'} = Carp::longmess("$0 $error");
}
else {
$self->{'error'} = Carp::shortmess("$0 $error");
}
if ($self->{'debug'}){
warn $self->{'error'};
}
}
sub _redirect_timing {
my $self = shift;
return sub {
my ($response, $ua, $h) = @_;
if ($self->{'timing'} && $response->header("location")){
$self->_do_timing("Redirect to " . $response->header("location"));
}
return;
}
}
sub _do_timing {
my $self = shift;
my $message = shift;
my $timestamp = [gettimeofday];
my $elapsed = tv_interval($self->{'start_time'}, $timestamp);
my $diff;
if ($self->{'last_timestamp'}){
$diff = tv_interval($self->{'last_timestamp'}, $timestamp);
}
$self->{'last_timestamp'} = $timestamp;
my $str = "$message ... elapsed time = $elapsed seconds";
if ($diff){
$str .= " (+ $diff)";
}
print $str . "\n";
}
#--- protected method used to get content. Can traverse cosign, basic auth, and unprotected
#--- resources transparently.
sub _fetch_url {
my $self = shift;
my $request = shift; #--- reference to HTTP::Request object
my $username = $self->{'uid'};
my $passwd = $self->{'passwd'};
my $realm = $self->{'realm'};
my $cookieJar = $self->{'cookieJar'};
my $ua = $self->{'ua'};
#--- if we did not pass realm explicitly
#--- use realm from the config file
if( !defined( $self->{'realm'} )) {
$self->{'realm'} = $self->{'default_realm'};
}
#--- set credentials for basic auth if given
#--- this does not use LWP::UserAgent->credentials because that appears to do two requests
#--- because it won't send credentials until it gets challenged, so we set the creds
#--- directly on the request
if (defined $self->{'uid'} && defined $self->{'passwd'} && defined $self->{'realm'}){
# --- Is this a Shibboleth ECP realm?
if ($self->{'realm'} =~ m|^https://|){
# Then set PAOS accept/header to tell SP we want to ECP
$request->header('Accept' => "*/*; @{[CONTENT_PAOS]}");
$request->header('PAOS' => PAOS_HEADER);
}
else {
# Otherwise do basic auth
$request->authorization_basic($self->{'uid'}, $self->{'passwd'});
}
}
if ($self->{"timing"}) {
$self->{'start_time'} = [gettimeofday];
$self->{'last_timestamp'} = undef;
print "Request is initiated...\n";
}
my $timed_out = 0; #timeout check for $request
local $SIG{ALRM} = sub {
#request has timed out
$timed_out = 1;
};
if(defined $self->{'timeout'}){
#if timeout is defined
alarm $self->{'timeout'};
}
else{
# don't alarm
alarm 0;
}
#--- get the initial URL
my $result = $ua->request($request);
alarm 0;
if($timed_out){
#Request timed out--->alarm
$self->_set_error("Request timeout.." . $request->uri());
return undef;
}
if ($result->is_success && !defined($result->header('x-died'))){
my $content = $result->content;
#--- We're at cosign
if ($content =~ /<form action=\".*cosign-bin\/cosign\.cgi/mi){
return $self->_do_cosign_login($request, $content, $result);
}
#--- We're at Shib ECP
elsif (defined($result->header('content-type')) && $result->header('content-type') eq CONTENT_PAOS) {
return $self->_do_ecp_login($request, $content);
}
#--- We're not at cosign or doing ECP login, this must be the final result.
else {
if ($self->{"timing"}) {
$self->_do_timing("Success");
}
$self->{'content_type'} = $result->header('content-type');
$self->{'headers'} = $self->_parse_headers($result);
return $content;
}
}
#--- Failure
else {
if ($self->{"timing"}) {
$self->_do_timing("Failed");
}
my $error = $result->header('x-died') || $result->message;
$self->_set_error("HTTP Error: $error : " . $request->uri());
return undef;
}
}
sub _do_cosign_login {
my $self = shift;
my $request = shift;
my $content = shift;
my $result = shift;
my $username = $self->{'uid'};
my $passwd = $self->{'passwd'};
my $ua = $self->{'ua'};
my $timed_out = 0;
if ($self->{timing}) {
$self->_do_timing("Request is redirected to Cosign");
}
my $form = HTML::Form->parse($content, $result->base());
if (!defined $form) {
$self->_set_error("Redirected to something I can't parse:\n" . $content . "\n");
return undef;
}
#--- fill out login parameters
$form->value("login",$username);
$form->value("password",$passwd);
my $request2 = $form->click;
local $SIG{ALRM} = sub {
#request2 timed out
$timed_out = 1;
};
if(defined $self->{'timeout'}){
alarm $self->{'timeout'};
}
else{
alarm 0;
}
#--- submit form
my $result2 = $ua->request($request2);
alarm 0;
if($timed_out){
#request2 timed out----> alarm
$self->_set_error("Request timeout while authing to cosign.." . $request2->uri());
return undef;
}
if ($self->{"timing"}) {
$self->_do_timing("Sent credentials to Cosign");
}
#--- Got another 200 back
if ($result2->is_success && !defined($result2->header('x-died'))){
my $content2 = $result2->content;
#--- Are we back at Cosign? If so, we're unauthorized.
if ($content2 =~ /<form action=\".*cosign-bin\/cosign\.cgi\"/mi){
$self->_set_error( "Error: Authorization failed for: " . $request->uri());
return undef;
}
#--- Otherwise we're good, return content
$self->{'content_type'} = $result2->header('content-type');
$self->{'headers'} = $self->_parse_headers($result2);
return $content2;
}
else {
#--- Something went wrong in getting the final url after cosign auth succeeded
my $error = $result2->header('x-died') || $result2->message;
$self->_set_error("HTTP Error after logging into Cosign: $error");
return undef;
}
}
#-- helper for handling Shib ECP login
sub _do_ecp_login {
my $self = shift;
my $request = shift;
my $content = shift;
my $ua = $self->{'ua'};
my $timed_out = 0;
if ($self->{timing}) {
$self->_do_timing("Request is wanting ECP login");
}
my $doc;
# Convert ECP response to what we send to IdP
eval{$doc = $self->{'xmlparser'}->parse_string($content);};
if ($@) {
$self->_set_error("Unable to parse ECP XML: " . $@);
return undef;
}
my @tmp = $self->{'xpath'}->findnodes('//S:Envelope/S:Header/ecp:RelayState', $doc);
if (!(scalar @tmp == 1)) {
$self->_set_error("Unable to find RelayState");
return undef;
}
my $relaystate = $tmp[0];
my $responseconsumer = $self->{'xpath'}->findvalue('//S:Envelope/S:Header/paos:Request/@responseConsumerURL', $doc);
@tmp = $self->{'xpath'}->findnodes('//S:Envelope', $doc);
if (!(scalar @tmp == 1)) {
$self->_set_error("Unable to find Envelope");
return undef;
}
my $envelope = $tmp[0];
@tmp = $self->{'xpath'}->findnodes('//S:Envelope/S:Header', $doc);
if (!(scalar @tmp == 1)) {
$self->_set_error("Unable to find Header");
return undef;
}
my $header = $tmp[0];
$envelope->removeChild($header);
my $idpreq = HTTP::Request::Common::POST($self->{'realm'},
Content_Type => 'text/xml',
Content => $doc->toStringC14N);
# Add basic auth to request
$idpreq->authorization_basic($self->{'uid'}, $self->{'passwd'});
# Launch request
local $SIG{ALRM} = sub {
#request2 timed out
$timed_out = 1;
};
if(defined $self->{'timeout'}){
alarm $self->{'timeout'};
}
else{
alarm 0;
}
my $idpres = $ua->request($idpreq);
alarm 0;
if($timed_out){
#request2 timed out----> alarm
$self->_set_error("Request timeout while authing to IdP.." . $idpreq->uri());
return undef;
}
$content = $idpres->content;
my $doc2;
eval{$doc2 = $self->{'xmlparser'}->parse_string($content);};
if ($@) {
$self->_set_error("Unable to parse IdP XML: " . $@);
return undef;
}
my $loginstatus = $self->{'xpath'}->findvalue('//S:Envelope/S:Body/saml2p:Response/saml2p:Status/saml2p:StatusCode/@Value', $doc2);
if (!defined($loginstatus) || $loginstatus ne 'urn:oasis:names:tc:SAML:2.0:status:Success') {
$self->_set_error("Authentication failed.");
return undef;
}
# Check for Error
my $idpresponseconsumer = $self->{'xpath'}->findvalue('//S:Envelope/S:Header/ecp:Response/@AssertionConsumerServiceURL', $doc2);
if ($idpresponseconsumer ne $responseconsumer) {
$self->_set_error("ACS from SP ($responseconsumer) does not match ACS from IdP ($idpresponseconsumer). Something bad happened.");
return undef;
}
@tmp = $self->{'xpath'}->findnodes('//S:Envelope/S:Header', $doc2);
if (!(scalar @tmp == 1)) {
$self->_set_error("Unable to find Header");
return undef;
}
my $SOAPHeader = $tmp[0];
$SOAPHeader->removeChildNodes();
$SOAPHeader->appendChild($relaystate);
# Send back to SP
my $spreq = HTTP::Request::Common::POST($responseconsumer,
Content_Type => CONTENT_PAOS,
Content => $doc2->toStringC14N);
local $SIG{ALRM} = sub {
#request2 timed out
$timed_out = 1;
};
if(defined $self->{'timeout'}){
alarm $self->{'timeout'};
}
else{
alarm 0;
}
my $spres = $ua->request($spreq);
alarm 0;
if($timed_out){
#request2 timed out----> alarm
$self->_set_error("Request timeout while returning to SP.." . $idpreq->uri());
return undef;
}
if ($self->{timing}) {
$self->_do_timing("Returned to SP");
}
#--- Got another 200 back
if ($spres->is_success && !defined($spres->header('x-died'))){
my $spcontent = $spres->content;
$self->{'content_type'} = $spres->header('content-type');
$self->{'headers'} = $self->_parse_headers($spres);
return $spcontent;
}
else {
if ($self->{"timing"}) {
$self->_do_timing("Failed");
}
my $error = $spres->header('x-died') || $spres->message;
$self->_set_error("HTTP Error: $error : " . $request->uri());
return undef;
}
}
#--- utility to extract all the header name/values from the response
sub _parse_headers {
my $self = shift;
my $response = shift;
my @header_names = $response->header_field_names;
my @headers;
foreach my $name (@header_names){
my $value = $response->header($name);
push(@headers, {name => $name, value => $value});
}
return \@headers;
}
#--- Used to bind remote web services methods to local object.
sub AUTOLOAD {
my $self = shift;
#--- figure out the callled method
my $name = our $AUTOLOAD;
my @stuff = split('::',$name);
$name = pop(@stuff);
# clear error from last call
$self->{'error'} = undef;
#---- figure out retries and retry interval
my $retries = $self->{'retries'};
my $retry_interval= $self->{'retry_interval'};
my $retry_string;
#---- ("3,3,3") : retry 3 times with 3 secs interval for each request
if ( $retries > 0 ){
$retry_string = join(",", ("$retry_interval") x $retries );
#set the number of retires with retry interval for each
$self->{'ua'}->timing( $retry_string );
}
else{
#if no retries, do not set retry interval
$self->{'ua'}->timing("");
}
#--- set up the parameters
my $params = {
@_
};
# did they specify a limit/offset parameter?
my $limit = $params->{'limit'} || DEFAULT_LIMIT;
my $offset = $params->{'offset'} || 0;
# if pagination is enabled, just return a new paginator object instead
if ( $self->{'use_pagination'} ) {
return GRNOC::WebService::Client::Paginator->new( websvc => $self,
limit => $limit,
offset => $offset,
method => $name,
params => $params );
}
if (defined $params->{$self->{'method_parameter'}}) {
$self->_set_error($self->{'method_parameter'} . " is a reserved parameter name\n");
return;
}
$params->{$self->{'method_parameter'}} = $name;
my $action = "GET";
if ($self->{'usePost'}) {
$action = "POST";
}
# set each undef value to empty string
my @keys = keys( %$params );
foreach my $key ( @keys ) {
my $values = $params->{$key};
# handle single scalar value
if ( !ref( $values ) ) {
$params->{$key} = "" if ( !defined( $values ) );
}
# handle arrayref of values
elsif ( ref( $values ) eq 'ARRAY' ) {
foreach my $value ( @$values ) {
$value = "" if ( !defined( $value ) );
}
}
}
if (!defined $self->{'urls'}) {
#--- no valid urls found
return;
}
foreach my $weight (sort {$a <=> $b} keys %{$self->{'urls'}}) {
my @urls = @{$self->{'urls'}{$weight}};
# If we have more than one URL randomly reorder them so that we
# get some equal cost RR effect
@urls = List::Util::shuffle(@urls) if (@urls > 1);
foreach my $base (@urls){
#--- iterate through the list of urls, this will obey
#--- cost and provide reundancy
if ($self->{'debug'}) {
warn "attempting to retrieve: $base as $action request: ".Dumper($params);
}
my $req;
if ($action eq "POST") {
#--- ok this royally sucks we need to at some point further optimize this
#--- cosign breaks if you just sent a post first time without a cookie
my $hack = HTTP::Request->new();
$hack->uri($base."?method=help");
$hack->method("GET");
$self->_fetch_url($hack);
my @arr;
foreach my $key (@keys){
next if (! $key);
my $val = $params->{$key};
# Since some arguments might come through as arrays (ie multiple values) and some as
# single values, treat everything as an array to simplify code
if (ref($val) ne 'ARRAY'){
$val = [$val];
}
foreach my $value (@$val){
# is this a special object?
if (ref($value) eq "HASH"){
if ($value->{'type'} eq "file"){
my $filename = $value->{'path'};
my @datum = ($filename);
# If we're specifying a name other than the filename, use that
my $name = $value->{'name'} || undef;
push(@datum, $name);
# Figure out mimetype either based on what we're told or by guessing
# on the file
my $mime_type;
if (exists $value->{'mime_type'}){
$mime_type = $value->{'mime_type'};
}
else{
my $mm = new File::MMagic;
$mime_type = $mm->checktype_filename($filename);
}
push(@datum, Content_Type => $mime_type);
push(@arr, $key => \@datum);
}
else {
$self->_set_error("Unknow type $value->{'type'}");
return;
}
}
# otherwise just push it onto the form data fields
else{
push(@arr, $key => $value);
}
}
}
# Make our request as a POST
$req = HTTP::Request::Common::POST($base,
Content_Type => 'form-data',
Content => \@arr);
}
elsif ($action eq "GET") {
my $query = new CGI($params);
my $query_str = $query->query_string();
$req = HTTP::Request->new(GET => $base . "?" . $query_str);
}
my $res = $self->_fetch_url($req);
#--- we have a successful result
if (defined $res) {
#--- in the event of a successful response, automatically save the cookies.
#--- HTTP::Cookies has this behavior but when we implemented our own save_cookies
#--- with flock support this behavior changed. This re-adds it using our mechanism
$self->save_cookies();
#--- if user has asked for raw output, just return it exactly as we got it
#--- can't do error detection here
if ($self->{'raw_output'}) {
return $res;
}
#--- default is to return json hash
# <editorialize>
# @#$*(@#$%($% library functions should always return unless there
# is a hardware fault or the end of the world(tm) is neigh.
# JSON:XS doesn't do this. Hence the eval.
# </editorialize>
my $str;
eval { $str = decode_json( $res ) };
if(! $@)
{
#--- detect an error flag set on the result
if (ref($str) eq "HASH" && $str->{'error'} && $self->{'error_callback'}){
&{$self->{'error_callback'}}($self, $res);
}
return( $str );
}
else
{
$self->_set_error($@);
}
}
}
}
#--- couldn't get a result, call error handler
if ($self->{'error_callback'}){
&{$self->{'error_callback'}}($self, undef);
}
return undef;
}
=head1 FUNCTIONS
The list of methods available is dependent upon the web service you have bound to. Use get_methods() to retrieve
the list of available methods. Only the methods implemented in the client library are listed here.
=head2 new()
constructor that takes four named parameters: .
=over
=item url
the url that directly indentifies a servcie
=cut
=item service_name
the GlobalNOC service identifier, with this client will consult the service
naming service to resolve, best URL to use.
=cut
=item service_cache_file
the location of the service cache file to use on disk (if not specified does direct nameservice queries)
=cut
=item name_services
array containing the locations of nameservices to use
=cut
=item uid
user id for authentication
=cut
=item passwd
user password
=cut
=item timeout
timeout value in seconds for the connection, if no activity observed in this time period LWP will abort.
=cut
=item usePost
boolean value for whether or not we are using http POST style or not
=cut
=item use_keep_alive
boolean value for whether or not to try and use keep_alives
=cut
=item use_pagination
boolean value for wether or not to use a GRNOC::WebService::Client::Paginator object to iterate through results
=cut
=item user_agent
string to use as the User-Agent string in request headers, defaults to $0
=cut
=item verify_hostname
If set to 1 then ssl certs are validated. Set to 0 when working with untrusted or self-signed certs. Defaults to 1.
=cut
=item retry_error_codes
hash of http error codes to retry the request on if the request fails
=cut
=back
=cut
sub new {
my $that = shift;
my $class =ref($that) || $that;
my %args = (
debug => 0,
timeout => 15,
usePost => 0,
use_keep_alive => 1,
raw_output => 0,
timing => 0,
user_agent => $0,
oldstyle_urls => 0,
cookieJar => undef,
method_parameter => "method",
use_pagination => 0,
verify_hostname => 1,
retry_error_codes => { '408' => 1,
'503' => 1,
'502' => 1,
'500' => 1,
'504' => 1},
config_file => "/etc/grnoc/webservice_client/config.xml",
default_realm => undef,
@_,
);
my $self = \%args;
bless $self,$class;
if (!defined $self->{'url'} && defined $self->{'service_name'}) {
#ISSUE=3454
my $t0;
if ($self->{timing}) {
$t0 = [gettimeofday];
print "URL is not provided, start looking up the URL to be requested...\n";
}
#first check to see if either name_services or service_cache_file
if (defined($self->{'service_cache_file'})) {
#--- load the client config
if (!$self->_load_config()) {
#--- cant find the config?
return $self;
}
if (! $self->_setup_urls($self->{'service_name'})) {
#-- no url provided and none resolved from service name
$self->_set_error("Unable to find a usable URL for URN = " . $self->{'service_name'} . " in cache file \"" . $self->{'service_cache_file'} . "\"\n");
return $self;
}
if ($self->{timing}) {
my $elapsed = tv_interval ($t0, [gettimeofday]);
print "Took $elapsed seconds to look up from the config file\n"
}
}
elsif (defined($self->{'name_services'})) {
# get the NameService locations
$self->_ns_service_lookup();
if ($self->{timing}) {
my $elapsed = tv_interval ($t0, [gettimeofday]);
print "Took $elapsed seconds to look up from the Name Service\n"
}
if (! $self->_setup_urls($self->{'service_name'})) {
#-- no url provided and none resolved from service name
$self->_set_error("Unable to find a usable URL for URN = " . $self->{'service_name'} . " in name services: " . Dumper($self->{'name_services'}) . "\n");
return $self;
}
}
else {
$self->_set_error("Unable to find a usable URL: Neither name_services or service_cache_file were specified\n");
}
#ISSUE=3454
if ($self->{timing}) {
print "URLs:\n";
foreach my $weight (sort {$a <=> $b} keys %{$self->{'urls'}}) {
foreach my $base (@{$self->{'urls'}{$weight}}) {
print "$base\n";
}
}
print "\n";
}
}
else {
#--- defined url input means we dont do service lookup
$self->{'urls'}{'0'}[0] = $self->{'url'};
}
{
# In older versions of LWP::UserAgent::Determined the ssl_opts
# parameter is not defined, and a warning is logged to the
# command line. Setting $^W to zero surpresses these warnings
# within this block.
local ($^W) = 0;
$self->{'ua'} = LWP::UserAgent::Determined->new(
agent => $self->{'user_agent'},
ssl_opts => {verify_hostname => $self->{'verify_hostname'}},
keep_alive => $self->{'use_keep_alive'}
);
}
#---- check to see if we need to use old style urls. This allows us to use web services that don't parse semicolons the same as ampersands.
if($self->{'oldstyle_urls'}) {
CGI->import(qw/ -oldstyle_urls /);
}
#---- set the timeout
$self->{'ua'}->timeout($self->{'timeout'});
#---- cookies to be automatically dealt with
$self->set_cookie_jar($self->{'cookieJar'});
#---- turn on auto redirects
$self->{'ua'}->requests_redirectable(['GET', 'HEAD', 'POST', 'OPTIONS']);
if ($self->{'timing'}){
if ($self->{'ua'}->can("add_handler")){
$self->{'ua'}->add_handler("response_redirect", $self->_redirect_timing());
}
}
#--- verify error handler
my $callback = $self->{'error_callback'};
if (defined $callback && (!ref($callback) || ref $callback ne "CODE")){
$self->{'error_callback'} = undef;
$self->_set_error("error_callback argument must be a code ref");
}
#set retries to 0 initially
$self->set_retries( 0 );
#set retry interval to 5s by default
$self->set_retry_interval( 5 );
#set the retry http error codes
my $retry_codes = dclone $self->{'retry_error_codes'};
$self->{'ua'}->codes_to_determinate( $retry_codes );
# XML processors for ECP
$self->{'xmlparser'} = XML::LibXML->new();
$self->{'xpath'} = XML::LibXML::XPathContext->new();
$self->{'xpath'}->registerNs('S' => 'http://schemas.xmlsoap.org/soap/envelope/');
$self->{'xpath'}->registerNs('paos' => 'urn:liberty:paos:2003-08');
$self->{'xpath'}->registerNs('ecp' => 'urn:oasis:names:tc:SAML:2.0:profiles:SSO:ecp');
$self->{'xpath'}->registerNs('saml' => 'urn:oasis:names:tc:SAML:2.0:assertion');
$self->{'xpath'}->registerNs('saml2p' => 'urn:oasis:names:tc:SAML:2.0:protocol');
#load the default realm from config file
$self->_load_default_realm() if( -e $self->{'config_file'} );
return $self;
}
sub DESTROY{
}
=head2 get_error()
gets the last error encountered or undef.
=cut
sub get_error{
my $self = shift;
return $self->{'error'};
}
=head2 get_content_type
Returns the Content-Type header of the last issue request
=cut
sub get_content_type {
my $self = shift;
return $self->{'content_type'};
}
=head2 get_headers
Returns all the headers as an array of objects from the last request
=cut
sub get_headers {
my $self = shift;
return $self->{'headers'};
}
=head2 get_retries
Returns the number of retries
=cut
sub get_retries {
my $self = shift;
return $self->{'retries'};
}
=head2 get_retry_interval
Returns the retry interval in seconds
=cut
sub get_retry_interval {
my $self = shift;
return $self->{'retry_interval'};
}
=head2 set_retries
Sets the number of retries if the initial request fails
=cut
sub set_retries {
my $self = shift;
my $retries = shift;
if( !defined $retries ){
return undef;
}
$self->{'retries'} = $retries;
return 1;
}
=head2 get_realm
Returns the realm set
=cut
sub get_realm {
my $self = shift;
return $self->{'realm'};
}
=head2 set_retry_interval
Sets the retry interval in seconds
=cut
sub set_retry_interval {
my $self = shift;
my $retry_interval = shift;
if( !defined $retry_interval ){
return undef;
}
$self->{'retry_interval'} = $retry_interval;
return 1;
}
=head2 set_raw_output
Disables or enables returning the raw output instead of attempting to decode JSON. This method
should be passed 1 to enable raw output and 0 to disable raw output. Raw output is disabled by
default--is can also be set by passing the raw_output parameter in the constructor.
=cut
sub set_raw_output {
my ($self, $raw_output) = @_;
$self->{'raw_output'} = $raw_output;
}
=head2 set_timeout
Changes the timeout value in the underlying LWP object. Can only be set by passing timeout in the constructor
call.
=cut
sub set_timeout {
my ($self, $timeout) = @_;
$self->{'timeout'} = $timeout;
$self->{'ua'}->timeout($timeout);
}
=head2 set_cookie_jar
Updates the cookie jar associated with the underlying LWP object. This can be passed a string representing
a file on disk or an HTTP::Cookies object.
=cut
sub set_cookie_jar {
my ($self, $new_cookies) = @_;
$self->{'cookieJar'} = $new_cookies;
#---- if an http::cookies object was passed in then pass it directly to useragent.
if(defined( $new_cookies ) && ref($new_cookies) eq "HTTP::Cookies"){
$self->{'ua'}->cookie_jar($new_cookies);
}
#---- assume they passed in a string filename for the cookie jar location.
elsif ( defined( $new_cookies ) ) {
# make sure we have a stable state while reading cookies in
my $fh;
if (-e $new_cookies){
if (! open($fh, "<", $new_cookies)){
$self->_set_error("Couldn't open $new_cookies: $!");
return;
}
if (! flock($fh, LOCK_SH)){
$self->_set_error("Couldn't share lock cookie file: $!");
return;
}
}
my $cookie_jar = new HTTP::Cookies(
file => $new_cookies,
autosave => 0,
ignore_discard => 1,
);
if(! $cookie_jar) {
$self->_set_error("Unable to create cookie jar: $!");
return;
}
$self->{'ua'}->cookie_jar($cookie_jar);
if ($fh){
$fh->close();
}
}
# use default in-memory cookie jar instead
else {
my $cookie_jar = new HTTP::Cookies(
autosave => 0,
ignore_discard => 1,
);
if(! $cookie_jar) {
$self->_set_error("Unable to create cookie jar: $!");
return;
}
$self->{'ua'}->cookie_jar($cookie_jar);
}
return 1;
}
=head2 save_cookies
Method to ask the underlying LWP UserAgent to save any cookies it might have.
=cut
sub save_cookies {
my $self = shift;
my $cookie_jar = $self->{'ua'}->cookie_jar;
if ($cookie_jar && $cookie_jar->{'file'}){
my $cookie_path = $cookie_jar->{'file'};
# we can't flock something that doesn't exist so if it doesn't
# just go ahead and 'touch' the file
if (! -e $cookie_path){
if ( ! open(FH, ">>", $cookie_path)){
$self->_set_error("Failed to touch new cookie file $cookie_path: $!");
return;
}
close(FH);
}
# open the file for read/write so that we don't clobber the contents before
# we have a chance to flock it
if (! open(FH, "+<", $cookie_path) ){
$self->_set_error("Failed to open $cookie_path: $!");
return;
}
if (! flock(FH, LOCK_EX) ){
$self->_set_error("Failed to flock during save: $!");
return;
}
# Now that we have the filehandle exlusively locked we can
# blow away the contents without fear that something will read it
# in the meantime
seek(FH, 0, 0);
truncate(FH, 0);
# taken from the HTTP::Cookies save method, we're implementing a flock
# friendly version here
print FH "#LWP-Cookies-1.0\n";
print FH $cookie_jar->as_string(!$cookie_jar->{ignore_discard});
# closing the FH releases the flock
close(FH);
}
return 1;
}
=head2 set_url
interface to change URL of an existing client, useful in stateful mod_perl.
Note: This wipes out any existing URLs that may have been loaded from a service identifier
=cut
sub set_url {
my $self = shift;
my $url = shift;
my $cost = shift;
# some defaulting
$cost = '0' unless $cost;
$self->{'urls'}{$cost}[0] = $url;
return 1;
}
=head2 clear_urls
Wipes out all knowledge the client has about URLs, useful if trying to use one client persistently
for multiple requests such as the proxy service
=cut
sub clear_urls {
my $self = shift;
$self->{'urls'} = undef;
}
=head2 set_service_identifier
interface to change what service identifier we are using.
Note: This wipes out any existing URLs that may have been loaded from a service identifier
=cut
sub set_service_identifier {
my $self = shift;
my $sid = shift;
#--- need to clean out old urls first or they could be queried instead of the one we need.
$self->clear_urls();
$self->{'service_name'} = $sid;
# we might have been initialized without a service identifier in which case we wouldn't have
# any service_urls loaded yet so try to load them if that's the case
if ($self->{'service_cache_file'})
{
if (! $self->_load_config()) {
$self->_set_error("No service urls found and unable to load config.");
return undef;
}
# figure out what URLs to know about based on the passed in service identifier or bail
if (! $self->_setup_urls($self->{'service_name'}))
{
$self->_set_error("Unable to find a usable URL for URN = " . $self->{'service_name'} . " in service cache file \"" . $self->{'service_cache_file'} . "\"\n");
return undef;
}
}
elsif (defined($self->{'name_services'}))
{
#get the NameService locations
$self->_ns_service_lookup();
if (! $self->_setup_urls($self->{'service_name'}))
{
#-- no url provided and none resolved from service name
$self->_set_error("Unable to find a usable URL for URN = " . $self->{'service_name'} . " in name services: " . Dumper($self->{'name_services'}) . "\n");
return undef;
}
}
else
{
$self->_set_error("Unable to find a usable URL: Neither name_services or service_cache_file were specified\n");
return undef;
}
return 1;
}
=head2 set_credentials
interface to change the username, password, and/or realm of the client
=cut
sub set_credentials {
my $self = shift;
my %args = @_;
$self->{'uid'} = $args{'uid'} if ($args{'uid'});
$self->{'realm'} = $args{'realm'} if ($args{'realm'});
$self->{'passwd'} = $args{'passwd'} if ($args{'passwd'});
return 1;
}
=head2 set_cookies
interface to change cookies of an existing client, useful in stateful mod_perl. Object given must be a HTTP::Cookies object
=cut
sub set_cookies {
my $self = shift;
my $cookies_obj = shift;
if (!defined $cookies_obj) {
return undef;
}
$self->{'ua'}->cookie_jar($cookies_obj);
return 1;
}
=head1 AUTHOR
GRNOC Systems Engineering, C<< <syseng at grnoc.iu.edu> >>
=head1 BUGS
Please report any bugs or feature requests to C<< <syseng at grnoc.iu.edu> >>
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc GRNOC::WebService::Client
=head1 ACKNOWLEDGEMENTS
=cut
1;