File Coverage

blib/lib/Net/OAuth2Server/Request.pm
Criterion Covered Total %
statement 21 111 18.9
branch 0 42 0.0
condition 0 31 0.0
subroutine 7 35 20.0
pod 0 28 0.0
total 28 247 11.3


line stmt bran cond sub pod time code
1 1     1   471 use strict; use warnings;
  1     1   4  
  1         27  
  1         5  
  1         3  
  1         31  
2              
3             package Net::OAuth2Server::Request;
4 1     1   411 use Net::OAuth2Server::Set ();
  1         3  
  1         20  
5 1     1   414 use Net::OAuth2Server::Response ();
  1         3  
  1         29  
6 1     1   572 use MIME::Base64 ();
  1         736  
  1         24  
7 1     1   7 use Carp ();
  1         2  
  1         75  
8              
9 0     0 0   sub request_body_methods { 'POST' }
10       0 0   sub allowed_methods {}
11       0 0   sub accepted_auth {}
12       0 0   sub required_parameters {}
13 0     0 0   sub set_parameters { 'scope' }
14       0 0   sub confidential_parameters {}
15              
16 1     1   6 use Object::Tiny::Lvalue qw( method headers parameters confidential scope error );
  1         2  
  1         19  
17              
18             my $ct_rx = qr[ \A application/x-www-form-urlencoded [ \t]* (?: ; | \z ) ]xi;
19              
20             my $loaded;
21             sub from_psgi {
22 0     0 0   my ( $class, $env ) = ( shift, @_ );
23 0           my $body;
24 0   0       $body = do { $loaded ||= require Plack::Request; Plack::Request->new( $env )->content }
  0            
25             if ( $env->{'CONTENT_TYPE'} || '' ) =~ $ct_rx
26 0 0 0       and grep $env->{'REQUEST_METHOD'} eq $_, $class->request_body_methods;
      0        
27             $class->from(
28             $env->{'REQUEST_METHOD'},
29             $env->{'QUERY_STRING'},
30 0 0         { map /\A(?:HTTPS?_)?((?:(?!\A)|\ACONTENT_).*)/s ? ( "$1", $env->{ $_ } ) : (), keys %$env },
31             $body,
32             );
33             }
34              
35             my %auth_parser = ( # XXX not sure about this design...
36             Bearer => sub { [ access_token => $_[0] ] },
37             Basic => sub {
38             my @k = qw( client_id client_secret );
39             my @v = split /:/, MIME::Base64::decode( $_[0] ), 2;
40             [ map { ( shift @k, $_ ) x ( '' ne $_ ) } @v ];
41             },
42             );
43              
44             sub from {
45 0     0 0   my ( $class, $meth, $query, $hdr, $body ) = ( shift, @_ );
46              
47 0 0 0       Carp::croak 'missing request method' unless defined $meth and '' ne $meth;
48              
49 0 0         %$hdr = map { my $k = $_; y/-/_/; ( lc, $hdr->{ $k } ) } $hdr ? keys %$hdr : ();
  0            
  0            
  0            
50              
51 0 0         if ( grep $meth eq $_, $class->request_body_methods ) {
52             return $class->new( method => $meth, headers => $hdr )->set_error_invalid_request( 'bad content type' )
53 0 0 0       if ( $hdr->{'content_type'} || '' ) !~ $ct_rx;
54             } else {
55 0           undef $body;
56             }
57              
58 0           for ( $query, $body ) {
59 0 0         defined $_ ? y/+/ / : ( $_ = '' );
60             # parse to k/v pairs, ignoring empty pairs, ensuring both k&v are always defined
61 0           $_ = [ / \G (?!\z) [&;]* ([^=&;]*) =? ([^&;]*) (?: [&;]+ | \z) /xg ];
62 0           s/%([0-9A-Fa-f]{2})/chr hex $1/ge for @$_;
  0            
63             }
64              
65 0           my $auth = $class->accepted_auth;
66 0 0 0       if ( $auth and ( $hdr->{'authorization'} || '' ) =~ /\A\Q$auth\E +([^ ]+) *\z/ ) {
      0        
67 0 0         my $parser = $auth_parser{ $auth }
68             or Carp::croak "unsupported HTTP Auth type '$auth' requested in $class";
69 0           $auth = $parser->( "$1" );
70             }
71 0           else { $auth = [] }
72              
73 0           my ( %param, %visible, %dupe );
74 0           for my $list ( $auth, $body, $query ) {
75 0           while ( @$list ) {
76 0           my ( $name, $value ) = splice @$list, 0, 2;
77 0 0 0       if ( exists $param{ $name } and $value ne $param{ $name } ) {
78 0           $dupe{ $name } = 1;
79             }
80             else {
81 0           $param{ $name } = $value;
82 0 0         $visible{ $name } = 1 if $list == $query;
83             }
84             }
85             }
86              
87 0 0         if ( my @dupe = sort keys %dupe ) {
88 0           my $self = $class->new( method => $meth, headers => $hdr );
89 0           return $self->set_error_invalid_request( "duplicate parameter: @dupe" );
90             }
91              
92 0 0         while ( my ( $k, $v ) = each %param ) { delete $param{ $k } if '' eq $v }
  0            
93              
94 0           my %confidential = map +( $_, 1 ), grep !$visible{ $_ }, keys %param;
95              
96 0           $class->new(
97             method => $meth,
98             headers => $hdr,
99             parameters => \%param,
100             confidential => \%confidential,
101             );
102             }
103              
104             sub new {
105 0     0 0   my $class = shift;
106 0           my $self = bless { @_ }, $class;
107 0 0         $self->method or Carp::croak 'missing request method';
108 0   0       $self->confidential ||= {};
109 0   0       my $params = $self->parameters ||= {};
110 0   0       $self->$_ ||= Net::OAuth2Server::Set->new( $params->{ $_ } ) for $self->set_parameters;
111 0 0         $self->ensure_method( $self->allowed_methods ) or return $self;
112 0 0         $self->ensure_confidential( $self->confidential_parameters ) or return $self;
113 0 0         $self->ensure_required( $self->required_parameters ) or return $self;
114 0           $self;
115             }
116              
117             #######################################################################
118              
119             sub ensure_method {
120 0     0 0   my $self = shift;
121 0           my $meth = $self->method;
122 0           my $disallowed = not grep $meth eq $_, @_;
123 0 0         $self->set_error_invalid_request( "method not allowed: $meth" ) if $disallowed;
124 0           not $disallowed;
125             }
126              
127             sub ensure_required {
128 0     0 0   my $self = shift;
129 0           my $p = $self->parameters;
130 0           my @missing = sort grep !exists $p->{ $_ }, @_;
131 0 0         $self->set_error_invalid_request( "missing parameter: @missing" ) if @missing;
132 0           not @missing;
133             }
134              
135             sub ensure_confidential {
136 0     0 0   my $self = shift;
137 0           my $p = $self->parameters;
138 0           my $confidential = $self->confidential;
139 0   0       my @visible = sort grep exists $p->{ $_ } && !$confidential->{ $_ }, @_;
140 0 0         $self->set_error_invalid_request( "parameter not accepted in query string: @visible" ) if @visible;
141 0           not @visible;
142             }
143              
144             #######################################################################
145              
146 0     0 0   sub params { my $p = shift->parameters; @$p{ @_ } }
  0            
147 0     0 0   sub param { my $p = shift->parameters; $$p{ $_[0] } }
  0            
148 0     0 0   sub has_param { my $p = shift->parameters; exists $$p{ $_[0] } }
  0            
149             sub param_if_confidential {
150 0     0 0   my ( $self, $name ) = ( shift, @_ );
151 0 0         $self->confidential->{ $name } ? $self->parameters->{ $name } : ();
152             }
153              
154             #######################################################################
155              
156 0     0 0   sub set_error { my $self = shift; $self->error = Net::OAuth2Server::Response->new_error( @_ ); $self }
  0            
  0            
157 0     0 0   sub set_error_invalid_token { shift->set_error( invalid_token => @_ ) }
158 0     0 0   sub set_error_invalid_request { shift->set_error( invalid_request => @_ ) }
159 0     0 0   sub set_error_invalid_client { shift->set_error( invalid_client => @_ ) }
160 0     0 0   sub set_error_invalid_grant { shift->set_error( invalid_grant => @_ ) }
161 0     0 0   sub set_error_unauthorized_client { shift->set_error( unauthorized_client => @_ ) }
162 0     0 0   sub set_error_access_denied { shift->set_error( access_denied => @_ ) }
163 0     0 0   sub set_error_unsupported_response_type { shift->set_error( unsupported_response_type => @_ ) }
164 0     0 0   sub set_error_unsupported_grant_type { shift->set_error( unsupported_grant_type => @_ ) }
165 0     0 0   sub set_error_invalid_scope { shift->set_error( invalid_scope => @_ ) }
166 0     0 0   sub set_error_server_error { shift->set_error( server_error => @_ ) }
167 0     0 0   sub set_error_temporarily_unavailable { shift->set_error( temporarily_unavailable => @_ ) }
168              
169             our $VERSION = '0.005';