File Coverage

blib/lib/Dancer/Plugin/CORS.pm

Criterion	Covered	Total	%
statement	152	163	93.2
branch	58	66	87.8
condition	13	17	76.4
subroutine	17	17	100.0
pod			n/a
total	240	263	91.2

package Dancer::Plugin::CORS;

use Modern::Perl;
use Dancer::Plugin::CORS::Sharing;

=head1 NAME

Dancer::Plugin::CORS - A plugin for using cross origin resource sharing

=head1 VERSION

Version 0.11

=cut

our $VERSION = '0.11';

=head1 DESCRIPTION

Cross origin resource sharing is a feature used by modern web browser to bypass cross site scripting restrictions. A webservice can provide those rules from which origin a client is allowed to make cross-site requests. This module helps you to setup such rules.

=head1 SYNOPSIS

    use Dancer::Plugin::CORS;

    get '/foo' => sub { ... };
	share '/foo' =>
		origin => 'http://localhost/',
		credentials => 1,
		expose => [qw[ Content-Type ]],
		method => 'GET',
		headers => [qw[ X-Requested-With ]],
		maxage => 7200,
		timing => 1,
	;

=cut

use Carp qw(croak confess);
use Dancer ':syntax';
use Dancer::Plugin;
use Sub::Name;
use Scalar::Util qw(blessed);
use URI;

use constant DEBUG => 0;

my $routes = {};

sub _isin($@) {
	shift ~~ \@_;
}

sub _isuri(_) {
	shift =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|
}

sub _handle;
my $current_route;

sub _prefl_handle {
	debug "[CORS] entered preflight request main subroutine" if DEBUG;
	unless (defined $current_route) {
		warning "[CORS] current route not defined!";
		return;
	}
	unless(_handle($current_route)) {
		my $request = Dancer::SharedData->request;
		while ($current_route = $current_route->next) {
			if ($current_route->match($request)) {
				debug "[CORS] going to next handler" if DEBUG;
				pass;
			}
        }
		debug "[CORS] no more rules." if DEBUG;
	}
	$current_route = undef;
}

sub _add_rule($%) {
	my ($route, %options) = @_;

	if (blessed $route and $route->isa('Dancer::Route')) {
		my $prefl = Dancer::App->current->registry->add_route(Dancer::Route->new(
			method => 'options',
			code => \&_prefl_handle,
			options => $route->options,
			pattern => $route->pattern
		));
		$options{method} = uc($route->method);
		$routes->{$prefl} = [{ %options }];
		debug "registered preflight route handler for ".$route->method." pattern: ".$route->pattern."\n" if DEBUG;
	}

	unless (exists $routes->{$route}) {
		$routes->{$route} = [];
		unless (ref $route) {
			debug "registered preflight route handler for any pattern: $route\n" if DEBUG;
			options $route => \&_prefl_handle;
		}
	}
	push @{ $routes->{$route} } => \%options;
}

sub _handle {
	my $route = shift;
	my $request = Dancer::SharedData->request;
	my $path = $request->path_info;

	unless (exists $routes->{$path} or exists $routes->{$route}) {
		debug "[CORS] path $path or route $route did not no matched any rule" if DEBUG;
	}

	my $preflight = uc $request->method eq 'OPTIONS';

	debug "[CORS] preflight request" if DEBUG and $preflight;

	my $origin = scalar($request->header('Origin'));

	unless (defined $origin) {
		debug "[CORS] no origin header present in request" if DEBUG;
		return;
	}

	unless (_isuri($origin)) {
		debug "[CORS] origin '$origin' is not a URI" if DEBUG;
		return;
	}

	my $requested_method  = $preflight
	                      ? scalar($request->header('Access-Control-Request-Method'))
						  : $request->method
						  ;
	unless (defined $requested_method) {
		debug "[CORS] no request method defined" if DEBUG;
	}

	my @requested_headers = map { s{\s+}{}g; $_ } split /,+/, (scalar($request->header('Access-Control-Request-Headers')) || '');

	my ($ok, $i) = (0, 0);
	my ($headers, $xoptions);

	if (exists $routes->{$route}) {
		$path = "$route";
		debug "[CORS] dynamic route" if DEBUG;
	} else {
		debug "[CORS] static route" if DEBUG;
	}

	my $n = scalar @{$routes->{$path}};

	RULE: foreach my $options (@{$routes->{$path}}) {
		debug "[CORS] testing rule ".++$i." of $n" if DEBUG;
		if (DEBUG) {
			use Data::Dumper;
			debug Dumper($options);
		}
		$headers = {};
		if (exists $options->{origin}) {
			given (ref $options->{origin}) {
				when ('CODE') {
					if (!$options->{origin}->(URI->new($origin))) {
						debug "[CORS] origin $origin did not matched against coderef" if DEBUG;
						next RULE;
					}
				}
				when ('ARRAY') {
					unless (_isin($origin => @{ $options->{origin} })) {
						debug "[CORS] origin $origin is not in array" if DEBUG;
						next RULE;
					}
				}
				when ('Regexp') {
					unless ($origin =~ $options->{origin}) {
						debug "[CORS] origin $origin did not matched against regexp" if DEBUG;
						next RULE;
					}
				}
				when ('') {
					unless ($options->{origin} eq $origin) {
						debug "[CORS] origin $origin did not matched against static string" if DEBUG;
						next RULE;
					}
				}
				default {
					confess("unknown origin type: $_");
				}
			}
		} else {
			$origin = '*';
		}
		$headers->{'Access-Control-Allow-Origin'} = $origin;
		$headers->{'Vary'} = 'Origin' if $origin ne '*';

		if (exists $options->{timing}) {
			if (defined $options->{timing} and $options->{timing} eq '1') {
				$headers->{'Timing-Allow-Origin'} = $headers->{'Access-Control-Allow-Origin'};
			} else {
				$headers->{'Timing-Allow-Origin'} = 'null';
			}
		}

		if (exists $options->{credentials}) {
			if (!!$options->{credentials}) {
				if ($origin eq '*') {
					warning('For a resource that supports credentials a origin matcher must be specified.');
					next RULE;
				}
				$headers->{'Access-Control-Allow-Credentials'} = 'true' ;
			}
		}

		if (exists $options->{expose}) {
			$headers->{'Access-Control-Expose-Headers'} = $options->{expose};
		}

		if (exists $options->{methods}) {
			unless (_isin(lc $requested_method => map lc, @{ $options->{methods} })) {
				debug "[CORS] request method not allowed" if DEBUG;
				next RULE;
			}
			$headers->{'Access-Control-Allow-Methods'} = join ', ' => map uc, @{ $options->{methods} };
		} elsif (exists $options->{method}) {
			unless ($options->{method} eq $requested_method) {
				debug "[CORS] request method '$requested_method' not allowed: ".$options->{method} if DEBUG;
				next RULE;
			}
			$headers->{'Access-Control-Allow-Methods'} = $options->{method};
		}

		if (exists $options->{headers}) {
			foreach my $requested_header (@requested_headers) {
				unless (_isin(lc $requested_header => map lc, @{ $options->{headers} })) {
					debug "[CORS] requested headers did not match allowed in rule" if DEBUG;
					next RULE;
				}
			}
			$headers->{'Access-Control-Allow-Headers'} = join ', ' => @{ $options->{headers} };
		} elsif (@requested_headers) {
			$headers->{'Access-Control-Allow-Headers'} = join ', ' => @requested_headers;
		}

		if ($preflight and exists $options->{maxage}) {
			$headers->{'Access-Control-Max-Age'} = $options->{maxage};
		}

		$ok = 1;
		var CORS => {%$options};
		Dancer::SharedData->response->headers(%$headers);
		if (DEBUG) {
			use Data::Dumper;
			debug Dumper({headers => $headers});
		}
		last RULE;
	}

	if ($ok) {
		debug "[CORS] matched!" if DEBUG;
	} else {
		debug "[CORS] no rule matched" if DEBUG;
	}

	return $ok;
}

=head1 KEYWORDS

=head2 share(C<$route>, C<%options>)

The parameter C<$route> may be any valid path like used I, I, I, I or I but not I.

Alternatively a L object may be used instead:

	$route = get '/' => sub { ... };
	share $route => ... ;

For any route more than one rule may be defined. The order is relevant: the first matching rule wins.

Following keywords recognized by C<%options>:

=over 4

=item I

This key defines a static origin (scalar), a list (arrayref), a regex or a subroutine.

If not specified, any origin is allowed.

If a subroutine is used, the first passed parameter is a L object. It should return a true value if this origin is allowed to access the route in question; otherwise false.

	origin => sub { shift->host ~~ [ 'localhost', '127.0.0.1', '::1' ] } # allow only from localhost

Hint: a origin consists of protocol, hostname and maybe a port. Examples: C, C, C, C, C

=item I

This indicates whether cookies, HTTP authentication and/or client-side SSL certificates may sent by a client. Allowed values are C<0> or C<1>.

This option must be used together with I.

=item I

A comma-seperated list of headers, that a client may extract from response for use in a client application.

=item I

A arrayref of allowed methods. If no methods are specified, all methods are allowed.

=item I

A string containing a single supported method. This parameter is autofilled when I is used together with a L object. If no method is specified, any method is allowed.

=item I

A arrayref of allowed request headers. In most cases that should be C<[ 'X-Requested-With' ]> when ajax requests are made. If not headers are specified, all requested headers are allowed.

=item I

A maximum time (in seconds) a client may cache a preflight request. This can decrease the amount of requests made to the webservice.

=item I

Allow access to the resource timing information. If set to 1, the header C is set to the same value as I. Otherwise, its set to the value I. If the keyword is not present, no I header will be appended to response. See L for more information.

=back

=cut

register(share => \&_add_rule);

hook(before => sub {
	$current_route = shift || return;
	my $preflight = uc Dancer::SharedData->request->method eq 'OPTIONS';
	if ($preflight) {
		debug "[CORS] pre-check: preflight request, handle within main subroutine" if DEBUG;
	} else {
		debug "[CORS] pre-check: no preflight, handle actual request now" if DEBUG;
		_handle($current_route);
	}
});

my $current_sharing;

=head2 sharing

This keyword is a helper for re-using rules for many routes.

See L for more information about this feature.

=cut

register sharing => sub {
	my $class = __PACKAGE__.'::Sharing';
	$current_sharing ||= $class->new(@_,_add_rule=>\&_add_rule);
	return $current_sharing;
};

=head1 AUTHOR

David Zurborg, C<<  >>

=head1 BUGS

Please report any bugs or feature requests trough my project management tool
at L.  I
will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Dancer::Plugin::CORS

You can also look for information at:

=over 4

=item * Redmine: Homepage of this module

L

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 COPYRIGHT & LICENSE

Copyright 2014 David Zurborg, all rights reserved.

This program is released under the following license: open-source

=cut

register_plugin;
1;