view release on metacpan or  search on metacpan

lib/Net/OAuth2Server/Request.pm  view on Meta::CPAN

use strict; use warnings;

package Net::OAuth2Server::Request;
our $VERSION = '0.006';

use Net::OAuth2Server::Set ();
use Net::OAuth2Server::Response ();
use MIME::Base64 ();
use Carp ();

sub request_body_methods  { 'POST' }
sub allowed_methods       {}
sub accepted_auth         {}
sub required_parameters   {}
sub set_parameters        { 'scope' }
sub confidential_parameters {}

use Object::Tiny::Lvalue qw( method headers parameters confidential scope error );

my $ct_rx = qr[ \A application/x-www-form-urlencoded [ \t]* (?: ; | \z ) ]xi;

my $loaded;
sub from_psgi {
	my ( $class, $env ) = ( shift, @_ );
	my $body;
	$body = do { $loaded ||= require Plack::Request; Plack::Request->new( $env )->content }
		if ( $env->{'CONTENT_TYPE'} || '' ) =~ $ct_rx
		and grep $env->{'REQUEST_METHOD'} eq $_, $class->request_body_methods;
	$class->from(
		$env->{'REQUEST_METHOD'},
		$env->{'QUERY_STRING'},
		{ map /\A(?:HTTPS?_)?((?:(?!\A)|\ACONTENT_).*)/s ? ( "$1", $env->{ $_ } ) : (), keys %$env },
		$body,
	);
}

my %auth_parser = ( # XXX not sure about this design...
	Bearer => sub { [ access_token => $_[0] ] },
	Basic  => sub {
		my @k = qw( client_id client_secret );
		my @v = split /:/, MIME::Base64::decode( $_[0] ), 2;
		[ map { ( shift @k, $_ ) x ( '' ne $_ ) } @v ];
	},
);

sub from {
	my ( $class, $meth, $query, $hdr, $body ) = ( shift, @_ );

	Carp::croak 'missing request method' unless defined $meth and '' ne $meth;

	%$hdr = map { my $k = $_; y/-/_/; ( lc, $hdr->{ $k } ) } $hdr ? keys %$hdr : ();

	if ( grep $meth eq $_, $class->request_body_methods ) {
		return $class->new( method => $meth, headers => $hdr )->set_error_invalid_request( 'bad content type' )
			if ( $hdr->{'content_type'} || '' ) !~ $ct_rx;
	} else {
		undef $body;
	}

	for ( $query, $body ) {
		defined $_ ? y/+/ / : ( $_ = '' );
		# parse to k/v pairs, ignoring empty pairs, ensuring both k&v are always defined
		$_ = [ / \G (?!\z) [&;]* ([^=&;]*) =? ([^&;]*) (?: [&;]+ | \z) /xg ];
		s/%([0-9A-Fa-f]{2})/chr hex $1/ge for @$_;
	}

	my $auth = $class->accepted_auth;
	if ( $auth and ( $hdr->{'authorization'} || '' ) =~ /\A\Q$auth\E +([^ ]+) *\z/ ) {
		my $parser = $auth_parser{ $auth }
			or Carp::croak "unsupported HTTP Auth type '$auth' requested in $class";
		$auth = $parser->( "$1" );
	}
	else { $auth = [] }

	my ( %param, %visible, %dupe );
	for my $list ( $auth, $body, $query ) {
		while ( @$list ) {
			my ( $name, $value ) = splice @$list, 0, 2;
			if ( exists $param{ $name } and $value ne $param{ $name } ) {
				$dupe{ $name } = 1;
			}
			else {
				$param{ $name } = $value;
				$visible{ $name } = 1 if $list == $query;
			}
		}