File Coverage

blib/lib/Dancer2/Plugin/HTTP/Auth/Extensible.pm

Criterion	Covered	Total	%
statement	162	192	84.3
branch	70	98	71.4
condition	11	25	44.0
subroutine	25	27	92.5
pod	8	15	53.3
total	276	357	77.3

package Dancer2::Plugin::HTTP::Auth::Extensible;

use warnings;
use strict;

use Carp;
use Dancer2::Plugin;
use Class::Load qw(try_load_class);

use HTTP::Headers::ActionPack::Authorization;
use HTTP::Headers::ActionPack::WWWAuthenticate;

our $VERSION = '0.100';



sub http_require_authentication {
    my $dsl = shift;
    my $realm = (@_ == 2) ? shift : http_default_realm($dsl);
    my $coderef = shift;

    return sub {
        if (!$coderef || ref $coderef ne 'CODE') {
            warn "Invalid http_require_authentication usage, please see docs";
        }

        my $user = http_authenticated_user($dsl, $realm);
        if (!$user) {
#           $dsl->execute_hook('http_authentication_required', $coderef);
#           # TODO: see if any code executed by that hook set up a response
            $dsl->header('WWW-Authenticate' =>
                qq|@{[ http_default_scheme($dsl) ]} realm="$realm"|
            );
            $dsl->status(401); # Unauthorized
            return
                qq|Authentication required to access realm: |
            .   qq|'$realm'|;
        }
        return $coderef->($dsl);
    };
}

register http_require_authentication  => \&http_require_authentication;
register http_requires_authentication  => \&http_require_authentication;


sub http_require_role {
    return _build_wrapper(@_, 'single');
}

register http_require_role  => \&http_require_role;
register http_requires_role => \&http_require_role;


sub http_require_any_role {
    return _build_wrapper(@_, 'any');
}

register http_require_any_role  => \&http_require_any_role;
register http_requires_any_role => \&http_require_any_role;


sub http_require_all_roles {
    return _build_wrapper(@_, 'all');
}

register http_require_all_roles  => \&http_require_all_roles;
register http_requires_all_roles => \&http_require_all_roles;


sub _build_wrapper {
    my $dsl = shift;
    my $require_role = shift;
    my $realm = (@_ == 3) ? shift : http_default_realm($dsl);
    my $coderef = shift;
    my $mode = shift;

    return sub {
        if (!$coderef || ref $coderef ne 'CODE') {
            warn "Invalid http_require_authentication usage, please see docs";
        }

        my $user = http_authenticated_user($dsl, $realm);
        if (!$user) {
#           $dsl->execute_hook('http_authentication_required', $coderef);
#           # TODO: see if any code executed by that hook set up a response
            $dsl->header('WWW-Authenticate' =>
                qq|@{[ http_default_scheme($dsl) ]} realm="$realm"|
            );
            $dsl->status(401); # Unauthorized
            return
                qq|Authentication required to access realm: |
            .   qq|'$realm'|;
        }

        my @role_list = ref $require_role eq 'ARRAY'
            ? @$require_role
            : $require_role;
        my $role_match;
        if ($mode eq 'single') {
            for (user_roles($dsl)) {
                $role_match++ and last if _smart_match($_, $require_role);
            }
        } elsif ($mode eq 'any') {
            my %role_ok = map { $_ => 1 } @role_list;
            for (user_roles($dsl)) {
                $role_match++ and last if $role_ok{$_};
            }
        } elsif ($mode eq 'all') {
            $role_match++;
            for my $role (@role_list) {
                if (!user_has_role($dsl, $role)) {
                    $role_match = 0;
                    last;
                }
            }
        }
        if (!$role_match) {

#           $dsl->execute_hook('http_permission_denied', $coderef);
#           # TODO: see if any code executed by that hook set up a response
            $dsl->status(403); # Forbidden
            return
                qq|Permission denied for resource: |
            .   qq|'@{[ $dsl->request->path ]}'|;
        }

        # We're happy with their roles, so go head and execute the route
        # handler coderef.
        return $coderef->($dsl);

    }; # return sub
} # _build_wrapper




sub http_authenticated_user {
    my $dsl = shift;
    my $realm = shift || http_default_realm($dsl);

    if ( http_authenticate_user($dsl, $realm) ) { # undef unless http_authenticate_user
        my $provider = auth_provider($dsl, http_realm($dsl));
        return $provider->get_user_details(
            http_username($dsl),
            http_realm($dsl)
        );
    } else {
        return;
    }
}
register http_authenticated_user => \&http_authenticated_user;


sub user_has_role {
    my $dsl = shift;
    my $session = $dsl->app->session;

    my ($username, $want_role);
    if (@_ == 2) {
        ($username, $want_role) = @_;
    } else {
        $username  = http_username($dsl);
        $want_role = shift;
    }

    return unless defined $username;

    my $roles = user_roles($dsl, $username);

    for my $has_role (@$roles) {
        return 1 if $has_role eq $want_role;
    }

    return 0;
}
register user_has_role => \&user_has_role;


sub user_roles {
    my ($dsl, $username, $realm) = @_;
    my $session = $dsl->app->session;

    $username = http_username($dsl) unless defined $username;

    my $search_realm = ($realm ? $realm : '');

    my $roles = auth_provider($dsl, $search_realm)->get_user_roles($username);
    return unless defined $roles;
    return wantarray ? @$roles : $roles;
}
register user_roles => \&user_roles;



sub http_authenticate_user {
    my $dsl = shift;
    my $realm = shift || http_default_realm($dsl);

    http_realm_exists($dsl, $realm);

    unless ($dsl->request->header('Authorization')) {
        return wantarray ? (0, undef) : 0;
    }
#   my ($username, $password) = $dsl->request->headers->authorization_basic;

    my $auth
    = HTTP::Headers::ActionPack::Authorization::Basic
      ->new_from_string($dsl->request->header('Authorization'));
    my $username = $auth->username;
    my $password = $auth->password;

    # TODO For now it only does Basic authentication
    #      Once we have Digest and others, it needs to choose itself

    my @realms_to_check = $realm ? ($realm) : (keys %{ plugin_setting->{realms} });

    for my $realm (@realms_to_check) { # XXX we only should have 1 ????
        $dsl->app->log ( debug  => "Attempting to authenticate $username against realm $realm");
        my $provider = auth_provider($dsl, $realm);
        if ($provider->authenticate_user($username, $password)) {
            $dsl->app->log ( debug => "$realm accepted user $username");
            $dsl->vars->{'http_username'} = $username;
            # don't do `http_username($dsl, $username)`, SECURITY BREACH
            $dsl->vars->{'http_realm'   } = $realm;
            # don't do `http_username($dsl, $username)`, SECURITY BREACH
            return wantarray ? ($username, $realm) : $username;
        }
    }

    # If we get to here, we failed to authenticate against any realm using the
    # details provided.
    # TODO: allow providers to raise an exception if something failed, and catch
    # that and do something appropriate, rather than just treating it as a
    # failed login.
    return wantarray ? (0, undef) : 0;
}

register http_authenticate_user => \&http_authenticate_user;

sub http_default_realm {
    my $dsl = shift;

    if (1 == keys %{ plugin_setting->{realms} }) {
        return (keys %{ plugin_setting->{realms} })[0]; # only the first key in scalar context
    }
    if (exists plugin_setting->{default_realm} ) {
        return plugin_setting->{default_realm};
    }

    die
        qq|Internal Server Error: |
    .   qq|"multiple realms without default"|;

    return;

} # http_default_realm

#register http_default_realm => \&http_default_realm;

sub http_realm_exists {
    my $dsl = shift;
    my $realm = shift || http_default_realm($dsl);

    unless (grep {$realm eq $_} keys %{ plugin_setting->{realms} }) {
        die
            qq|Internal Server Error: |
        .   qq|"required realm does not exist: '$realm'"|;
    }

    return $realm;

} # http_realm_exists

#register http_realm_exists => \&http_realm_exists;


sub http_default_scheme {
    my $dsl = shift;
    my $realm = shift || http_default_realm($dsl);

    http_realm_exists($dsl, $realm);

    my $scheme;

    if (exists plugin_setting->{realms}->{$realm}->{scheme} ) {
        $scheme = plugin_setting->{realms}->{$realm}->{scheme};
    }
    else {
        $scheme = "Basic";
    }

    return $scheme;

} # http_default_schema

#register http_default_scheme => \&http_default_scheme;


sub http_scheme_known {
    my $dsl = shift;
    my $scheme = shift;

    unless (grep $scheme eq $_, ('Basic', 'Digest')) {
        warn
            qq|unknown scheme '$scheme'!|;
        return;
    }

    return $scheme;

} # http_scheme_known

#register http_scheme_known => \&http_scheme_known;


sub http_username {
    my $dsl = shift;

    unless ( exists $dsl->vars->{http_username} ) {
        $dsl->app->log( warning =>
            qq|'http_username' should only be used in an authenticated route|
        );
    }

    if (@_ == 1) { # CAUTION: use with care
        $dsl->vars->{http_username} = shift;
        my $message
        =   qq|POTENTIONAL SECURITY BREACH: |
        .   qq|"impersonating different user: '|
        .   $dsl->vars->{http_username}
        .   qq|'"|;
        warn $message;
        $dsl->app->log ( warning => $message );
    }

    return unless exists $dsl->vars->{http_username};
    return $dsl->vars->{http_username};

} # http_username

register http_username => \&http_username;


sub http_realm {
    my $dsl = shift;

    unless ( exists $dsl->vars->{http_realm} ) {
        $dsl->app->log( warning =>
            qq|'http_realm' should only be used in an authenticated route|
        );
    }

    if (@_ == 1) { # CAUTION: use with care
        $dsl->vars->{http_realm} = shift;
        my $message
        =   qq|POTENTIONAL SECURITY BREACH: |
        .   qq|"switching to different realm: '|
        .   $dsl->vars->{http_realm}
        .   qq|'"|;
        warn $message;
        $dsl->app->log ( warning => $message );
    }

    return unless exists $dsl->vars->{http_realm};
    return $dsl->vars->{http_realm};

} # http_realm

register http_realm => \&http_realm;


{
# Given a realm, returns a configured and ready to use instance of the provider
# specified by that realm's config.
my %realm_provider;
sub auth_provider {
    my $dsl = shift;
    my $realm = shift || http_default_realm($dsl);

    http_realm_exists($dsl, $realm); # can be in void, it dies when false

    # First, if we already have a provider for this realm, go ahead and use it:
    return $realm_provider{$realm} if exists $realm_provider{$realm};

    # OK, we need to find out what provider this realm uses, and get an instance
    # of that provider, configured with the settings from the realm.
    my $realm_settings = plugin_setting->{realms}->{$realm}
        or die "Invalid realm $realm";
    my $provider_class = $realm_settings->{provider}
        or die "No provider configured - consult documentation for "
            . "Dancer2::Plugin::Auth::Extensible";

    if ($provider_class !~ /::/) {
        $provider_class = "Dancer2::Plugin::Auth::Extensible" . "::Provider::$provider_class";
    }
    my ($ok, $error) = try_load_class($provider_class);

    if (! $ok) {
        die "Cannot load provider $provider_class: $error";
    }

    return $realm_provider{$realm} = $provider_class->new($realm_settings);
}
}

register_hook qw(http_authentication_required http_permission_denied);
register_plugin for_versions => [qw(1 2)];


# Given a class method name and a set of parameters, try calling that class
# method for each realm in turn, arranging for each to receive the configuration
# defined for that realm, until one returns a non-undef, then return the realm which
# succeeded and the response.
# Note: all provider class methods return a single value; if any need to return
# a list in future, this will need changing)
sub _try_realms {
    my ($method, @args);
    for my $realm (keys %{ plugin_setting->{realms} }) {
        my $provider = auth_provider($realm);
        if (!$provider->can($method)) {
            die "Provider $provider does not provide a $method method!";
        }
        if (defined(my $result = $provider->$method(@args))) {
            return $result;
        }
    }
    return;
}

on_plugin_import {
    my $dsl = shift;
    my $app = $dsl->app;

};


# Replacement for much maligned and misunderstood smartmatch operator
sub _smart_match {
    my ($got, $want) = @_;
    if (!ref $want) {
        return $got eq $want;
    } elsif (ref $want eq 'Regexp') {
        return $got =~ $want;
    } elsif (ref $want eq 'ARRAY') {
        return grep { $_ eq $got } @$want;
    } else {
        carp "Don't know how to match against a " . ref $want;
    }
}





1; # End of Dancer2::Plugin::HTTP::Auth::Extensible

__END__