view release on metacpan or  search on metacpan

lib/Catalyst/Plugin/OAuth2/ResourceServer.pm  view on Meta::CPAN

package Catalyst::Plugin::OAuth2::ResourceServer;
use v5.36;
use Scalar::Util qw/blessed/;
use JSON::MaybeXS ();
use Try::Tiny;
use URI ();
use Catalyst::Plugin::OAuth2::ResourceServer::Server;
use Catalyst::Plugin::OAuth2::ResourceServer::Error;

our $VERSION = '0.003';

my $CONFIG_KEY = 'Catalyst::Plugin::OAuth2::ResourceServer';
my $SLOT       = 'Catalyst::Plugin::OAuth2::ResourceServer/ctx';
my $JSON       = JSON::MaybeXS->new( utf8 => 1, canonical => 1 );

sub _oauth_rs_config ( $c ) { return $c->config->{$CONFIG_KEY} // {} }

# RFC 7230 quoted-string: backslash-escape `\` and `"` so a value carrying
# either cannot terminate the quoted-string or forge extra auth-params.
# A plain function, not a method.
sub _oauth_rs_quote_hval ( $value ) {
    my $v = $value // '';
    $v =~ s/([\\"])/\\$1/g;
    return $v;
}

# RFC 9728 3.1: derive the protected-resource metadata URL from the resource
# identifier by inserting the well-known segment after the authority, before
# the resource's path. This is only defined for an http(s) resource id: for a
# URN or any other non-hierarchical scheme there is no authority to insert
# after, so return undef and let the caller omit the parameter rather than
# emit a malformed one. A plain function, not a method.
sub _oauth_rs_metadata_url ( $base ) {
    return undef unless defined $base && length $base;
    my $u = URI->new($base);
    return undef unless $u->can('scheme') && defined $u->scheme;
    return undef unless $u->scheme =~ /\A https? \z/xi;
    return undef unless $u->can('authority') && $u->can('path');
    return undef unless defined $u->authority && length $u->authority;
    my $path = $u->path // '';
    $path = '' if $path eq '/';
    $u->path( '/.well-known/oauth-protected-resource' . $path );
    return $u->as_string;
}

# Per-request engine built from config. Only the engine's own attrs are passed
# (StrictConstructor rejects the seam/metadata-only keys).
sub _oauth_rs_engine ( $c ) {
    my $cfg = $c->_oauth_rs_config;
    return Catalyst::Plugin::OAuth2::ResourceServer::Server->new(
        map { exists $cfg->{$_} ? ( $_ => $cfg->{$_} ) : () }
            qw/signing_key resource issuer jwt_alg leeway/
    );
}

# Write a WWW-Authenticate: Bearer challenge. $err is an optional ...::Error.
sub oauth_challenge ( $c, $err = undef ) {
    my $status = ( $err && $err->http_status ) ? $err->http_status : 401;
    my @p;
    push @p, sprintf( 'error="%s"', _oauth_rs_quote_hval( $err->error ) )
        if $err && defined $err->error;
    push @p,
        sprintf( 'error_description="%s"',
        _oauth_rs_quote_hval( $err->error_description ) )
        if $err && defined $err->error_description;