view release on metacpan or  search on metacpan

lib/Mojolicious/Plugin/CanonicalURL.pm  view on Meta::CPAN

package Mojolicious::Plugin::CanonicalURL;
use Mojo::Base 'Mojolicious::Plugin';
use Carp         ();
use Exporter     'import';
use Mojo::Util   ();
use Scalar::Util ();
use Sub::Quote   ();

our $VERSION = '0.06';

our @EXPORT_OK = qw(remove_trailing_slashes);

sub register {
    my (undef, $app, $config) = @_;

    my (
        $should_canonicalize_request_config,
        $should_not_canonicalize_request_config,
        $inline_code,
        $end_with_slash,
        $canonicalize_before_render,
        %captures
    ) = _parse_and_validate_config($config);

    my $sub_string = '';
    my ($path_declared, $path_with_no_slashes_at_the_end_declared);
    if (defined $should_canonicalize_request_config) {
        ($path_declared, $path_with_no_slashes_at_the_end_declared, $sub_string) = _create_should_canonicalize_request_sub_string(
            config => $should_canonicalize_request_config,
            captures => \%captures,
            sub_string => $sub_string,
            should_canonicalize_request => 1,
            path_declared => $path_declared,
            path_with_no_slashes_at_the_end_declared => $path_with_no_slashes_at_the_end_declared,
        );
    }
    if (defined $should_not_canonicalize_request_config) {
        ($path_declared, $path_with_no_slashes_at_the_end_declared, $sub_string) = _create_should_canonicalize_request_sub_string(
            config => $should_not_canonicalize_request_config,
            captures => \%captures,
            sub_string => $sub_string,
            should_canonicalize_request => undef,
            path_declared => $path_declared,
            path_with_no_slashes_at_the_end_declared => $path_with_no_slashes_at_the_end_declared,
        );
    }
    $sub_string .= $inline_code if $inline_code;

    $sub_string .= 'my $_mpcu_path = $c->req->url->path->to_string;' unless $path_declared;
    if ($end_with_slash) {
        $sub_string .= q{
            my $_mpcu_path_length = length($_mpcu_path);
            return $next->() if $_mpcu_path_length != 0 and rindex($_mpcu_path, '/') == $_mpcu_path_length - 1 and ($_mpcu_path_length < 2 or rindex($_mpcu_path, '//') != $_mpcu_path_length - 2);

            while (rindex($_mpcu_path, '/') == length($_mpcu_path) - 1) {
                substr $_mpcu_path, -1, 1, '';
            }

            my $url = $c->req->url->clone;
            $url->path($_mpcu_path)->path->trailing_slash(1);

            $c->res->code(301);
            $c->redirect_to($url);
        };
    } else {
        $sub_string .= q{
            return $next->() if $_mpcu_path eq '/' or rindex($_mpcu_path, '/') != length($_mpcu_path) - 1 or $_mpcu_path eq '';

            while (rindex($_mpcu_path, '/') == length($_mpcu_path) - 1) {
                substr $_mpcu_path, -1, 1, '';
            }

            $c->res->code(301);
            $c->redirect_to($c->req->url->clone->path($_mpcu_path));
        };
    }

    # Potentially flaky for a minor speed improvment. Could just assign $next and $c above to @_.
    # Or could use Mojo::Template, but that would be awkward writing perl code.
    $sub_string =~ s/\$next\b/\$_[0]/g;
    $sub_string =~ s/\$c\b/\$_[1]/g;

    $app->hook(around_action => _quote_sub($sub_string, \%captures));

    if ($canonicalize_before_render) {
        # replace return $next->() with return
        $sub_string =~ s/return\s+\$_\[0\]->\(\)/return/g;

        # replace $_[1] with $_[0] since $c is now the first argument
        $sub_string =~ s/\$_\[1\]/\$_[0]/gm;

        # we could set a stash variable if we failed to canonicalize in
        # around_action, but the performance hit isn't big
        $sub_string = "return if \$_[0]->res->is_redirect;$sub_string";
        $app->hook(before_render => _quote_sub($sub_string, \%captures));
    }
}

sub _quote_sub {
    my ($sub_string, $captures) = @_;
    return Sub::Quote::quote_sub $sub_string, $captures, {no_install => 1, no_defer => 1};
}

sub _parse_and_validate_config {
    my ($config) = @_;

    my (
        $should_canonicalize_request,
        $should_not_canonicalize_request,
        $inline_code,
        $end_with_slash,
        $canonicalize_before_render
    );
    my %captures;
    if (defined $config) {
        Carp::confess 'config must be a hash reference, but was ' . Scalar::Util::reftype $config
          if not defined Scalar::Util::reftype $config
          or Scalar::Util::reftype $config ne 'HASH';

        if (%$config) {
            my $captures_allowed;
            if (exists $config->{should_canonicalize_request}) {
                ($should_canonicalize_request, $captures_allowed) =
                  _validate_should_canonicalize_request_config(delete $config->{should_canonicalize_request}, 1);
            }
            if (exists $config->{should_not_canonicalize_request}) {
                ($should_not_canonicalize_request, $captures_allowed) = _validate_should_canonicalize_request_config(
                    delete $config->{should_not_canonicalize_request},
                    undef,
                );
            }

            if (exists $config->{inline_code}) {
                $inline_code = delete $config->{inline_code};
                Carp::confess 'inline_code must be a true scalar value'
                  unless not defined Scalar::Util::reftype $inline_code and $inline_code;
                $captures_allowed = 1;
            }

            if (exists $config->{canonicalize_before_render}) {
                Carp::confess 'canonicalize_before_render must be a scalar value'
                  if defined Scalar::Util::reftype $config->{canonicalize_before_render};
                $canonicalize_before_render = delete $config->{canonicalize_before_render};
            }

            if ($captures_allowed and exists $config->{captures}) {
                %captures = %{delete $config->{captures}};
                Carp::confess 'captures cannot be empty' unless %captures;
            }

            Carp::confess
              'captures only applies when inline_code is set or a scalar reference is passed to should_canonicalize_request or should_not_canonicalize_request'
              if exists $config->{captures};

            if (exists $config->{end_with_slash}) {
                $end_with_slash = delete $config->{end_with_slash};
                Carp::confess 'end_with_slash must be a scalar value' if defined Scalar::Util::reftype $end_with_slash;
            }

            Carp::confess 'unknown keys passed in config: ' . Mojo::Util::dumper $config if keys %$config;
        }
    }

    return (
        $should_canonicalize_request,
        $should_not_canonicalize_request,
        $inline_code,
        $end_with_slash,
        $canonicalize_before_render,
        %captures
    );
}

sub _validate_should_canonicalize_request_config {
    my ($config, $should_canonicalize_request) = @_;

    my $captures_allowed;
    my $config_name    = _get_should_canonicalize_request_config_name($should_canonicalize_request);
    my $config_reftype = Scalar::Util::reftype $config || '';
    Carp::confess
      "$config_name must be a scalar that evaluates to true and starts with a '/', a REGEXP, a SCALAR, a subroutine, an array reference, or a hash reference"
      unless $config
      and ((not $config_reftype and index($config, '/') == 0)
        or grep { $config_reftype eq $_ } qw/ARRAY HASH REGEXP SCALAR CODE/);

    if (defined $config_reftype and $config_reftype eq 'SCALAR') {
        $captures_allowed = 1;
    } elsif (defined $config_reftype and $config_reftype eq 'ARRAY') {
        Carp::confess "array passed to $config_name must not be empty" unless @$config;

        for (@$config) {
            Carp::confess "elements of $config_name must be a true value" unless $_;

            my $reftype = Scalar::Util::reftype $_;
            Carp::confess
                "elements of $config_name must have a reftype of undef (scalar), CODE, HASH, REGEXP, or SCALAR but was '$reftype'"
                    unless not defined $reftype
                        or $reftype eq 'CODE'
                        or $reftype eq 'HASH'
                        or $reftype eq 'REGEXP'
                        or $reftype eq 'SCALAR';
            Carp::confess "elements of $config_name must begin with a '/' when they are scalar"
              if not defined $reftype and index($_, '/') != 0;

            if (defined $reftype and $reftype eq 'SCALAR') {
                $captures_allowed = 1;
            }

            if (defined $reftype and $reftype eq 'HASH') {
                _validate_starts_with_hash($config_name, $_);
            }
        }
    } elsif (defined $config_reftype and $config_reftype eq 'HASH') {
        _validate_starts_with_hash($config_name, $config);
    }

    return ($config, $captures_allowed);
}

sub _validate_starts_with_hash {
    my ($config_name, $hash) = @_;
    my %copy = %$hash;
    Carp::confess "must provide key 'starts_with' to hash in $config_name" unless exists $copy{starts_with};
    Carp::confess 'value for starts_with must not be undef' unless defined $copy{starts_with};
    Carp::confess 'value for starts_with must be a scalar'
        unless not defined Scalar::Util::reftype $copy{starts_with};
    Carp::confess q{value for starts_with must begin with a '/'}
        unless index(delete $copy{starts_with}, '/') == 0;
    Carp::confess "unknown keys/values passed in hash inside of $config_name: " . Mojo::Util::dumper \%copy
        if %copy
}

sub _create_should_canonicalize_request_sub_string {
    my %args = @_;
    my ($config, $captures, $sub_string, $should_canonicalize_request, $path_declared, $path_with_no_slashes_at_the_end_declared) =
    @{{@_}}{qw/config captures sub_string should_canonicalize_request path_declared path_with_no_slashes_at_the_end_declared/};
    my $path_with_no_slashes_at_the_end_declared_code = q{
        my $_mpcu_path_with_no_slashes_at_the_end = $_mpcu_path;
        while (rindex($_mpcu_path_with_no_slashes_at_the_end, '/') == length($_mpcu_path_with_no_slashes_at_the_end) - 1) {
            substr $_mpcu_path_with_no_slashes_at_the_end, -1, 1, '';
        }
    };

    my $config_name          = _get_should_canonicalize_request_config_name($should_canonicalize_request);
    my $config_variable_name = "\$$config_name";
    my $if_or_unless         = $should_canonicalize_request ? 'unless' : 'if';
    my $reftype              = Scalar::Util::reftype $config;
    if (not defined $reftype) {
        $config =~ s#/+\z##m;
        $captures->{$config_variable_name} = \$config;

        unless ($path_with_no_slashes_at_the_end_declared) {
            unless ($path_declared) {
                $sub_string .= 'my $_mpcu_path = $c->req->url->path->to_string;';
                $path_declared = 1;
            }

            $sub_string .= $path_with_no_slashes_at_the_end_declared_code;
            $path_with_no_slashes_at_the_end_declared = 1;
        }
        $sub_string .= "return \$next->() $if_or_unless \$_mpcu_path_with_no_slashes_at_the_end eq $config_variable_name;";
    } elsif ($reftype eq 'REGEXP') {
        unless ($path_declared) {
            $sub_string .= 'my $_mpcu_path = $c->req->url->path->to_string;';
            $path_declared = 1;
        }

        $captures->{$config_variable_name} = \$config;
        $sub_string .= "return \$next->() $if_or_unless \$_mpcu_path =~ $config_variable_name;";
    } elsif ($reftype eq 'SCALAR') {
        my $code = $$config;
        $code = "return \$next->() $if_or_unless $code" if $code !~ /\A\s*return/;
        $code .= ';' unless $code =~ /;\s*\z/;

        Carp::confess 'code must contain return $next->()' unless $code =~ /return\s+\$next->\(\)/;

        $sub_string .= $code;
    } elsif ($reftype eq 'CODE') {
        $captures->{$config_variable_name} = \$config;
        $sub_string .= qq{