view release on metacpan or  search on metacpan

lib/Leyland/Negotiator.pm  view on Meta::CPAN

sub negotiate {
	my ($class, $c, $app_routes, $path) = @_;

	# 1. CHARACTER SET NEGOTIATION
	# --------------------------------------------------------------
	# Leyland only supports UTF-8 character encodings, so let's check
	# the client supports that. If not, let's return an error
	$c->log->debug('Negotiating character set.');
	Leyland::Negotiator->_negotiate_charset($c)
		|| $c->exception({ code => 400, error => "This server only supports the UTF-8 character set, unfortunately we are unable to fulfil your request." });

	# 2. PATH NEGOTIATION
	# --------------------------------------------------------------
	# let's find all possible prefix/route combinations
	# from the request path, and then find all routes matching
	# the request path
	my $routes = [];
	$path ||= $c->path;
	$routes = $class->_negotiate_path($c, { app_routes => $app_routes, path => $path });
	$c->exception({ code => 404 }) unless scalar @$routes;

	$c->log->debug('Found '.scalar(@$routes).' routes matching '.$path);

	# 3. REQUEST METHOD NEGOTIATION
	# --------------------------------------------------------------
	# weed out routes that do not match request method
	$c->log->debug('Negotiating request method.');
	$routes = $class->_negotiate_method($c->method, $routes);
	$c->exception({ code => 405 }) unless scalar @$routes;

	# 4. RECEIVED CONTENT TYPE NEGOTIATION
	# --------------------------------------------------------------
	# weed out all routes that do not accept the media type that the
	# client used for the request
	$c->log->debug('Negotiating media type received.');
	$routes = $class->_negotiate_receive_media($c, $routes);
	$c->exception({ code => 415 }) unless scalar @$routes;

	# 5. RETURNED CONTENT TYPE NEGOTIATION
	# --------------------------------------------------------------
	# weed out all routes that do not return any media type
	# the client accepts
	$c->log->debug('Negotiating media type returned.');
	$routes = $class->_negotiate_return_media($c, $routes);
	$c->exception({ code => 406 }) unless scalar @$routes;

	return $routes;
}

=head2 find_options( $c, $app_routes )

Finds all routes that match a certain path when an HTTP OPTIONS request
is received.

=cut

sub find_options {
	my ($class, $c, $app_routes) = @_;

	my $routes = $class->matching_routes($app_routes, $class->prefs_and_routes($c->path));

	# have we found any matching routes?
	$c->exception({ code => 404 }) unless scalar @$routes;

	# okay, we have, let's see which HTTP methods are supported by
	# these routes
	my %meths = ( 'OPTIONS' => 1 );
	foreach (@$routes) {
		$meths{$class->method_name($_->{method})} = 1;
	}

	return sort keys %meths;
}

=head2 method_name( $meth )

Receives the name of a Leyland-style HTTP method (like 'get', 'post',
'put' or 'del') and returns the correct HTTP name of it (like 'GET', 'POST',
'PUT' or 'DELETE').

=cut

sub method_name {
	my ($class, $meth) = @_;

	# replace 'del' with 'delete'
	$meth = 'delete' if $meth eq 'del';

	# return this in uppercase
	return uc($meth);
}

sub _negotiate_path {
	my ($class, $c, $args) = @_;

	$args->{path} ||= $c->path;

	# let's find all possible prefix/route combinations
	# from the request path and then find all routes matching the request path
	my $routes = $class->_matching_routes($args->{app_routes}, $class->_prefs_and_routes($args->{path}), $args->{internal});

	if ($args->{method}) {
		return $class->_negotiate_method($args->{method}, $routes);
	} else {
		return $routes;
	}
}

sub _prefs_and_routes {
	my ($class, $path) = @_;

	my $pref_routes = [{ prefix => '', route => $path }];
	my ($prefix) = ($path =~ m!^(/[^/]+)!);
	my $route = $' || '/';
	my $i = 0; # counter to prevent infinite loops, probably should be removed
	while ($prefix && $i < 1000) {
		push(@$pref_routes, { prefix => $prefix, route => $route });
		
		my ($suffix) = ($route =~ m!^(/[^/]+)!);
		last unless $suffix;
		$prefix .= $suffix;
		$route = $' || '/';
		$i++;
	}

	return $pref_routes;
}

sub _matching_routes {
	my ($class, $app_routes, $pref_routes, $internal) = @_;

	my $routes = [];
	foreach (@$pref_routes) {
		my $pref_name = $_->{prefix} || '_root_';

		next unless $app_routes->EXISTS($pref_name);

		my $pref_routes = $app_routes->FETCH($pref_name);
		
		next unless $pref_routes;
		
		# find matching routes in this prefix
		ROUTE: foreach my $r ($pref_routes->Keys) {
			# does the requested route match the current route?
			next unless my @captures = ($_->{route} =~ m/$r/);
			
			shift @captures if scalar @captures == 1 && $captures[0] eq '1';

			my $route_meths = $pref_routes->FETCH($r);

			# find all routes that support the request method (i.e. GET, POST, etc.)
			METH: foreach my $m (sort { $a eq 'any' || $b eq 'any' } keys %$route_meths) {
				# do not match internal routes
				RULE: foreach my $rule (@{$route_meths->{$m}->{rules}->{is} || []}) {
					next METH if $rule eq 'internal' && !$internal;
				}

				# okay, add this route
				push(@$routes, { method => $m, class => $route_meths->{$m}->{class}, prefix => $_->{prefix}, route => $r, code => $route_meths->{$m}->{code}, rules => $route_meths->{$m}->{rules}, captures => \@captures });
			}
		}
	}

	return $routes;
}

sub _negotiate_method {
	my ($class, $method, $routes) = @_;