GRNOC-WebService-Client

 view release on metacpan or  search on metacpan

lib/GRNOC/WebService/Client.pm  view on Meta::CPAN

    }

}

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");
            }

lib/GRNOC/WebService/Client.pm  view on Meta::CPAN

        }
    }
    #--- 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;

lib/GRNOC/WebService/Client.pm  view on Meta::CPAN

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;