• Files
• Commits
• Log
• Graph
• Stats

package Local::Dancer2::CSRF;

# port of Dancer2::Plugin::CSRF

# Dancer2::Plugin::CSRF doesn't work well with DP::Deferred which appends
# '?dpdid=.....' to form submission which breaks token validation, it also
# uses deprecated dsl keywords (eg request->dispatch_path)

# to use $self->dsl->debug, need to use private subs, or caller is
# ~/perl5/lib/perl5/Dancer2/Plugin.pm for debug output

# set log level to debug in development config to see _debug() output

use 5.26.0;

use Term::ANSIColor::Simple;
use Crypt::SaltedHash;
use Dancer2::Plugin;
use Data::Printer;
use Data::UUID;

my $HASHER = Crypt::SaltedHash->new( algorithm => 'SHA-1' ); # SHA1 is default anyway
my $UUID   = Data::UUID->new();

plugin_keywords qw( get_csrf_token check_csrf_token );

has session_key_name => (
    is      => 'ro', # this plugin config session_key_name if set:
    default => sub { $_[0]->config->{session_key_name} || 'csrf_token' }
);

# caller[1] is ~/[..]/Dancer2/Plugin.pm for DSL debug output, solution is to
# wrap private subs, then caller is this class
sub check_csrf_token { _check_csrf_token(@_) }
sub get_csrf_token   { _get_csrf_token(@_)   }

#===============================================================================
sub _get_csrf_token { # caller[1] is this class
    my $self = shift;

    my $app = $self->app; # p $app->session;
    # my $dsl = $app->dsl; $dsl->debug("form_url:$form_url"); using _debug() now:
            $self->_debug(__LINE__,'getting csrf token .....');
    my $key_name = $self->session_key_name;
            $self->_debug(__LINE__,"key_name:$key_name");
    my $session  = $app->session;            # p $session;

    # create a session $key_name => value pair if it doesn't exist:
    if (! $session->read($key_name) ) {
                $self->_debug(__LINE__,"session lacks $key_name key");
        my $str = $UUID->create_str();
                $self->_debug(__LINE__,"creating new $key_name:$str pair");
        $session->write( $key_name => $str );
    } # p $session;
    else { $self->_debug(__LINE__,"session contains $key_name key") }
    # generate a new token:
    my $token = $self->_generate_token; # $dsl->debug("token:$token"); already done it
    return $token;
}

# check whether submitted form token matches its expected value, then delete
# csrf key value from session to block back-button resubmission:
sub _check_csrf_token { # caller[1] is this class
    my ($self, $form_token) = @_; # p $form_token;
            $self->_debug(__LINE__,"checking csrf token .....");
    # generate expected token (using same function as original form) for
    # comparison with $form_token (return a failure if no session key):
    my $expected_token = $self->_generate_token || return 0; # p $expected_token;
            $self->_debug(__LINE__,"expected token:$expected_token");
            $self->_debug(__LINE__,"received token:$form_token");
    # clear csrf-token from session to prevent back-button resubmission:
    my $key_name = $self->session_key_name;    # p $key_name;
            $self->_debug(__LINE__,"deleting session key $key_name");
    $self->app->session->delete($key_name);

    # returns boolen truth:
    return $form_token eq $expected_token;
}

# generate a salted-hash token using session $key_name value & form_url value:
sub _generate_token { # caller[1] is this class
    my $self = shift;

    my $app = $self->app; # p $app->session; p $app->environment;
            $self->_debug(__LINE__,'creating new token');
    my $session_key_name = $self->session_key_name; # p $session_key_name;
            $self->_debug(__LINE__,"session_key_name:$session_key_name");
    my $session_key_value = $app->session->read($session_key_name) || return 0;
            $self->_debug(__LINE__,"session_key_value:$session_key_value"); # p $session_key_value;

=begin
p $app->request->path;         # eg "/upload"
p $app->request->request_uri;  # eg "/upload?dpdid=59091261"
p $app->request->base;         # URI::http object, stringifies to "http://localhost:3000/"
p $app->request->uri_base;     # eg "http://localhost:3000"
=cut
    my $request  = $app->request;
    # this needs to work for both initial get & associated post requests:
    # my $form_url = do {
    #    ( my $path = $request->path ) =~ s{^/}{}; # p $path;
    #    $request->base . $path;
    # };

    my $form_url = $request->uri_base . $request->path; # p $form_url;
            $self->_debug(__LINE__,"form_url:$form_url");
    my $token = $HASHER->add($session_key_value, $form_url)->generate(); # p $token;
    $HASHER->clear();
            $self->_debug(__LINE__,"created new token:$token");
    return $token;
}

sub _debug {
    my ($self, $line, $str) = @_; # p $str;
    my $app = $self->app; # p $app->logger_engine->log_level;
    my @caller = caller(1); # p @caller;
    # require development env with log level core or debug:
    return unless $app->environment eq 'development'
       && grep { $app->logger_engine->log_level eq $_ } qw(core debug);
    say color($caller[0] . ' line #' . $line)->red;
    say color($str)->green;
}

1;