view release on metacpan or  search on metacpan

lib/Authen/CAS/UserAgent.pm  view on Meta::CPAN

		$uri->scheme eq $loginUri->scheme &&
		$uri->authority eq $loginUri->authority &&
		$uri->path eq $loginUri->path
	) {
		#short-circuit if a service isn't specified
		my $service = URI->new(scalar $uri->query_param('service'));
		return if($service eq '');

		#short-circuit if in strict mode and the service is different than the original uri
		return if($h->{'strict'} && $response->request->uri ne $service);

		#get a ticket for the specified service
		my $ticket = $ua->get_cas_ticket($service, $h);

		#short-circuit if a ticket wasn't found
		return if(!defined $ticket);

		#update the Location header
		$response->header('Location', $service . ($service =~ /\?/ ? '&' : '?') . 'ticket=' . uri_escape($ticket));

		#attach a local response_redirect handler that will issue the redirect if necessary
		push(@{$response->{'handlers'}->{'response_redirect'}},
			{
				%$h,
				'callback' => sub {
					my ($response, $ua, $h) = @_;

					#delete this response_redirect handler from the response object
					delete $response->{'handlers'}->{'response_redirect'};
					delete $response->{'handlers'} unless(%{$response->{'handlers'}});

					#determine the new uri
					my $uri = $response->request->uri;
					my $newUri = URI->new_abs(scalar $response->header('Location'), $uri);

					#check to see if the target uri is the same as the original uri (ignoring the ticket)
					my $targetUri = $newUri->clone;
					if($targetUri =~ s/[\&\?]ticket=[^\&\?]*$//sog) {
						if($targetUri eq $uri) {
							#clone the original request, update the request uri, and return the new request
							my $request = $response->request->clone;
							$request->uri($newUri);
							return $request
						}
					}

					return;
				},
			},
		);
	}

	return;
};

# default heuristic for finding login parameters
my $defaultLoginParamsHeuristic = sub {
	my ($service, $response, $ua, $h, @params) = @_;

	# find all input controls on the submit form
	my $content = $response->decoded_content;
	while($content =~ /(\<input.*?\>)/igs) {
		my $input = $1;
		my $name = $input =~ /name=\"(.*?)\"/si ? $1 : undef;
		my $value = $input =~ /value=\"(.*?)\"/si ? $1 : undef;

		# we only care about the lt, execution, and _eventId parameters
		if($name eq 'lt' || $name eq 'execution' || $name eq '_eventId') {
			push @params, $name, $value;
		}
	}

	# return the updated params
	return @params;
};

#default heuristic for detecting the service and ticket in the login response
my $defaultTicketHeuristic = sub {
	my ($response, $service) = @_;

	#attempt using the Location header on a redirect response
	if($response->is_redirect) {
		my $uri = $response->header('Location');
		if($uri =~ /[?&]ticket=([^&]*)$/) {
			return $1;
		}
	}

	#check for a javascript window.location.href redirect
	if($response->decoded_content =~ /window\.location\.href="[^"]*ticket=([^&"]*?)"/sg) {
		return $1;
	}

	return;
};

#default callback to log the user into CAS and return a ticket for the specified service
my $defaultLoginCallback = sub {
	my ($service, $ua, $h) = @_;

	# generate the params for this login request
	my $loginUri = URI->new_abs('login', $h->{'casServer'});
	my @params = (
		'service' => $service,
		'username' => $h->{'username'},
		'password' => $h->{'password'},
	);

	# find any additional required login params (i.e. lt, execution, and _eventId)
	if(@{$h->{'config'}->{'param_heuristics'}}) {
		# retrieve the login form that will be parsed by configured param_heuristics
		my $formUri = $loginUri->clone();
		$formUri->query_param('service', $service);
		my $response = $ua->simple_request(HTTP::Request::Common::GET($formUri));

		# process all configured param heuristics
		foreach (@{$h->{'config'}->{'param_heuristics'}}) {
			# skip invalid heuristics
			next if(ref($_) ne 'CODE');

			# process this heuristic
			@params = $_->($service, $response, $ua, $h, @params);
		}
	}

	# issue the login request
	my $response = $ua->simple_request(HTTP::Request::Common::POST($loginUri, \@params));

	#short-circuit if there is no response from CAS for some reason
	return if(!$response);

	#process all the ticket heuristics until a ticket is found
	foreach (@{$h->{'config'}->{'ticket_heuristics'}}) {
		#skip invalid heuristics
		next if(ref($_) ne 'CODE');

		#process the current heuristic
		my $ticket = eval {$_->($response, $service)};

		#quit processing if a ticket is found
		return $ticket if(defined $ticket);
	}

	#return undefined if no ticket was found
	return;
};

# Login callback when the specified server is in proxy mode
my $proxyLoginCallback = sub {
	my ($service, $ua, $h) = @_;

	#clear any previous error
	delete $h->{'error'};

	#create the request uri
	my $ptUri = URI->new_abs('proxy', $h->{'casServer'});
	$ptUri->query_form(
		'pgt'           => $h->{'pgt'},
		'targetService' => $service,
	);

	# fetch proxy ticket and parse response xml
	my $response = $ua->simple_request(HTTP::Request::Common::GET($ptUri));
	my $doc = eval {XML::LibXML->new()->parse_string($response->decoded_content('charset' => 'none'))};
	if($@ || !$doc) {
		$h->{'error'} = ERROR_PROXY_INVALIDRESPONSE;
		push @{$h->{'errors'}}, $h->{'error'};
		return;
	}

	# process the response to extract the proxy ticket or any errors
	my $xpc = XML::LibXML::XPathContext->new();
	$xpc->registerNs('cas', XMLNS_CAS);
	if($xpc->exists('/cas:serviceResponse/cas:proxyFailure', $doc)) {
		my $code = $xpc->findvalue('/cas:serviceResponse/cas:proxyFailure[position()=1]/@code', $doc);
		if($code eq 'INVALID_TICKET') {
			$h->{'error'} = ERROR_PROXY_INVALIDTICKET;
			push @{$h->{'errors'}}, $h->{'error'};
		}
		else {
			$h->{'error'} = ERROR_PROXY_UNKNOWN;
			push @{$h->{'errors'}}, $h->{'error'};
		}
	}
	elsif($xpc->exists('/cas:serviceResponse/cas:proxySuccess', $doc)) {
		return $xpc->findvalue('/cas:serviceResponse/cas:proxySuccess[position()=1]/cas:proxyTicket[position()=1]', $doc);
	}
	else {
		$h->{'error'} = ERROR_PROXY_INVALIDRESPONSE;
		push @{$h->{'errors'}}, $h->{'error'};
	}

	# default to no ticket being returned
	return;
};

#Login callback for CAS servers that implement the RESTful API
#TODO: cache the TGT
my $restLoginCallback = sub {
	my ($service, $ua, $h) = @_;

	#retrieve the tgt
	my $loginUri = URI->new_abs('v1/tickets', $h->{'casServer'});
	my $tgtResponse = $ua->simple_request(HTTP::Request::Common::POST($loginUri, [
		'username' => $h->{'username'},
		'password' => $h->{'password'},
	]));
	return if($tgtResponse->code != 201);
	my $tgtUri = $tgtResponse->header('Location');

	#retrieve a ticket for the requested service
	my $ticketResponse = $ua->simple_request(HTTP::Request::Common::POST($tgtUri, [
		'service' => $service,
	]));
	return if($ticketResponse->code != 200);
	return $ticketResponse->decoded_content;
};

##Static Methods

#return the default user agent for this class
sub _agent($) {
	return
		$_[0]->SUPER::_agent . ' ' .
		'CAS-UserAgent/' . $VERSION;
}

#Constructor
sub new($%) {
	my $self = shift;
	my (%opt) = @_;

	# remove any cas options before creating base object
	my $cas_opts = delete $opt{'cas_opts'};

	#setup the base object
	$self = $self->SUPER::new(%opt);

	#attach a cas login handler if options were specified
	$self->attach_cas_handler(%$cas_opts) if(ref($cas_opts) eq 'HASH');

	#return this object
	return $self;
}

=head1 METHODS

The following methods are available:

=over 4

=item $ua->attach_cas_handler( %options )

This method attaches a CAS handler to the current C<Authen::CAS::UserAgent>
object.

The following options are supported:

=over

=item C<server> => $url

This option defines the base CAS URL to use for this handler. The base url is
used to detect redirects to CAS for authentication and to issue any requests to
CAS when authenticating.

This option is required.

=item C<username> => $string

This option defines the username to use for authenticating with the CAS server.

This option is required unless using proxy mode.

=item C<password> => $string