File Coverage

blib/lib/Plack/Middleware/CrossOrigin.pm

Criterion	Covered	Total	%
statement	107	107	100.0
branch	42	42	100.0
condition	28	36	77.7
subroutine	14	14	100.0
pod	2	2	100.0
total	193	201	96.0

package Plack::Middleware::CrossOrigin;
use strict;
use warnings;

our $VERSION = '0.014';
$VERSION =~ tr/_//d;

use 5.008;
use parent qw(Plack::Middleware);

use Plack::Util;
use Plack::Util::Accessor qw(
    origins
    headers
    methods
    max_age
    expose_headers
    credentials
    continue_on_failure
);

my @simple_headers = qw(
    Accept
    Accept-Language
    Content-Language
);
my @simple_response_headers = qw(
    Cache-Control
    Content-Language
    Content-Type
    Expires
    Last-Modified
    Pragma
);
my @common_headers = qw(
    Cache-Control
    Depth
    If-Modified-Since
    User-Agent
    X-File-Name
    X-File-Size
    X-Requested-With
    X-Prototype-Version
);

# RFC 7231
my @http_methods = qw(
    GET
    HEAD
    POST
    PUT
    DELETE
    CONNECT
    OPTIONS
    TRACE
);

# RFC 5789
my @rfc_5789_methods = qw(
    PATCH
);

my @webdav_methods = qw(
    CANCELUPLOAD
    CHECKIN
    CHECKOUT
    COPY
    DELETE
    GETLIB
    LOCK
    MKCOL
    MOVE
    OPTIONS
    PROPFIND
    PROPPATCH
    PUT
    REPORT
    UNCHECKOUT
    UNLOCK
    UPDATE
    VERSION-CONTROL
);

my @all_methods = ( @http_methods, @rfc_5789_methods, @webdav_methods );

sub prepare_app {
    my ($self) = @_;

    $self->origins([$self->origins || ()])
        unless ref $self->origins;

    $self->methods([$self->methods || @all_methods])
        unless ref $self->methods;

    $self->headers([$self->headers || @common_headers])
        unless ref $self->headers;

    $self->expose_headers([$self->expose_headers || ()])
        unless ref $self->expose_headers;

    $self->{origins_h} = { map { $_ => 1 } @{ $self->origins } };
    ($self->{origins_re}) =
        map qr/\A(?:$_)\z/,
        join '|',
        map +(
            join '[a-z0-9.-]*',
            map quotemeta,
            split /\*/, $_, -1
        ),
        @{ $self->origins };

    $self->{methods_h} = { map { $_ => 1 } @{ $self->methods } };
    $self->{headers_h} = { map { lc $_ => 1 } @{ $self->headers } };
    $self->{expose_headers_h} = { map { $_ => 1 } @{ $self->expose_headers } };
}

sub call {
    my ($self, $env) = @_;
    my $origin = $env->{HTTP_ORIGIN};
    my $continue_on_failure;
    if ($origin) {
        $continue_on_failure = $self->continue_on_failure;
    }
    # for preflighted GET requests, some WebKit versions don't
    # include Origin with the actual request.  Fixed in current versions
    # of WebKit, Chrome, and Safari.
    # Work around it using the Referer header.
    # https://bugs.webkit.org/show_bug.cgi?id=50773
    # http://code.google.com/p/chromium/issues/detail?id=57836
    elsif ($env->{REQUEST_METHOD} eq 'GET'
        && $env->{HTTP_USER_AGENT}
        && $env->{HTTP_USER_AGENT} =~ m{\bAppleWebKit/(\d+\.\d+)}
        && $1 < 534.19
        && $env->{HTTP_REFERER}
        && $env->{HTTP_REFERER} =~ m{\A ( \w+://[^/]+ )}msx
    ) {
        $origin = $1;
        $continue_on_failure = 1;
    }
    else {
        return _with_vary($self->app->($env));
    }

    my $request_method  = $env->{HTTP_ACCESS_CONTROL_REQUEST_METHOD};
    my $request_headers = $env->{HTTP_ACCESS_CONTROL_REQUEST_HEADERS};
    my @request_headers = $request_headers ? (split /,\s*/, $request_headers) : ();
    my $preflight       = $env->{REQUEST_METHOD} eq 'OPTIONS' && $request_method;

    my $fail = $continue_on_failure && !$preflight ? $self->app : \&_response_forbidden;

    my $allowed_origins_h   = $self->{origins_h};
    my $allowed_methods     = $self->methods;
    my $allowed_methods_h   = $self->{methods_h};
    my $allowed_headers     = $self->headers;
    my $allowed_headers_h   = $self->{headers_h};
    my $expose_headers      = $self->expose_headers;
    my $expose_headers_h    = $self->{expose_headers_h};

    my @headers;

    if (not ($allowed_origins_h->{'*'} || $origin =~ $self->{origins_re} ) ) {
        return _with_vary($fail->($env));
    }

    if ($preflight) {
        if ( $allowed_methods_h->{'*'} ) {
            $allowed_methods = [$request_method];
        }
        elsif ( ! $allowed_methods_h->{$request_method} ) {
            return _response_forbidden();
        }
        if ( $allowed_headers_h->{'*'} ) {
            $allowed_headers = \@request_headers;
        }
        elsif ( grep { ! defined } @{$allowed_headers_h}{map lc, @request_headers} ) {
            return _response_forbidden();
        }
    }
    if ($self->credentials) {
        push @headers, 'Access-Control-Allow-Credentials' => 'true';
    }
    elsif ($allowed_origins_h->{'*'}) {
        $origin = '*';
    }
    push @headers, 'Access-Control-Allow-Origin' => $origin;

    my $res;
    if ($preflight) {
        if (defined $self->max_age) {
            push @headers, 'Access-Control-Max-Age' => $self->max_age;
        }
        push @headers, 'Access-Control-Allow-Methods' => join ', ', @$allowed_methods;
        push @headers, 'Access-Control-Allow-Headers' => join ', ', @$allowed_headers;

        $res = _response_success();
    }
    else {
        $res = $self->app->($env);
    }

    return $self->response_cb($res, sub {
        my $res = shift;

        if (! _vary_headers($res->[1])->{origin}) {
            push @{ $res->[1] }, 'Vary' => 'Origin';
        }

        if ($expose_headers_h->{'*'}) {
            my %headers = @{ $res->[1] };
            delete @headers{@simple_response_headers};
            $expose_headers = [sort keys %headers];
        }

        push @headers, 'Access-Control-Expose-Headers' => join ', ', @$expose_headers;

        push @{ $res->[1] }, @headers;
    });
}

sub _response_forbidden {
    [403, ['Content-Type' => 'text/plain', 'Content-Length' => 9, 'Vary' => 'Origin'], ['forbidden']];
}

sub _response_success {
    [200, [ 'Content-Type' => 'text/plain' ], [] ];
}

sub _with_vary {
    my ($res) = @_;
    return Plack::Util::response_cb($res, sub {
        my $res = shift;

        if (! _vary_headers($res->[1])->{origin}) {
            push @{ $res->[1] }, 'Vary' => 'Origin';
        }
    });
}

sub _vary_headers {
    my ($headers) = @_;

    my %vary =
        map { s/\A\s+//; s/\s+\z//; ( lc, 1) }
        map +(split /,/),
        Plack::Util::header_get($headers, 'Vary');

    return \%vary;
}

1;
__END__