File Coverage

blib/lib/Net/OAuth2/Scheme/Mixin/Transport.pm
Criterion Covered Total %
statement 16 16 100.0
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 22 100.0


line stmt bran cond sub pod time code
1 2     2   749 use warnings;
  2         2  
  2         50  
2 2     2   6 use strict;
  2         2  
  2         58  
3              
4             package Net::OAuth2::Scheme::Mixin::Transport;
5             BEGIN {
6 2     2   23 $Net::OAuth2::Scheme::Mixin::Transport::VERSION = '0.020002_099';
7             }
8             # ABSTRACT: the 'transport' option group and helper functions
9              
10 2     2   7 use Net::OAuth2::Scheme::Option::Defines;
  2         2  
  2         74  
11 2     2   6 use parent 'Net::OAuth2::Scheme::Mixin::Bearer';
  2         2  
  2         13  
12 2     2   87 use parent 'Net::OAuth2::Scheme::Mixin::HMac';
  2         2  
  2         5  
13              
14             use URI::Escape;
15              
16             # transport helper functions
17              
18             # INTERFACE transport
19             # DEFINES
20             # http_insert
21             # psgi_extract
22             # accept_hook
23             # accept_needs
24             # token_type
25             Define_Group transport => undef,
26             qw(psgi_extract http_insert accept_hook accept_needs token_type);
27              
28             Default_Value transport_header => 'Authorization';
29              
30             Define_Group transport_header_re_set => 'default',
31             qw(transport_header_re);
32              
33             sub pkg_transport_header_re_set_default {
34             my __PACKAGE__ $self = shift;
35             my $transport_header = $self->uses('transport_header');
36             $self->install(transport_header_re => qr(\A\Q$transport_header\E\z)is);
37             return $self;
38             }
39              
40             Define_Group transport_auth_scheme_re_set => 'default',
41             qw(transport_auth_scheme_re);
42              
43             sub pkg_transport_auth_scheme_re_set_default {
44             my __PACKAGE__ $self = shift;
45             my $scheme = $self->uses('transport_auth_scheme');
46             $self->install(transport_auth_scheme_re => qr(\A\Q$scheme\E\z)is);
47             return $self;
48             }
49              
50             Define_Group transport_auth_scheme_set => 'default',
51             qw(transport_auth_scheme);
52              
53             sub pkg_transport_auth_scheme_set_default {
54             # spec 8.1 says auth scheme SHOULD be identical to the token_type name
55             my __PACKAGE__ $self = shift;
56             my $type_name = $self->uses('token_type');
57             if ($type_name =~ m{\A[-._0-9A-Za-z]+\z}) {
58             # followed specified syntax for registered token_type names,
59             # so it is not a URI, yay
60             $self->install(transport_auth_scheme => $type_name);
61             }
62             # URI-style names really should not be used for auth schemes
63             # so we give up and let uses() complain
64             return $self;
65             }
66              
67             #
68             # for defining http_insert and psgi_extract
69             # when token is being stashed in a header
70             #
71              
72             sub http_header_extractor {
73             my __PACKAGE__ $self = shift;
74             my %o = @_;
75              
76             my $header_re = $self->uses('transport_header_re');
77             $header_re = qr{$header_re}is unless ref($header_re);
78              
79             if (my $header = $self->installed('transport_header')) {
80             $self->croak("transport_header_re does not match transport_header")
81             if ($header !~ $header_re);
82             }
83            
84             if (defined(my $parse_header = $o{parse_header})) {
85             return sub {
86             my $request = Plack::Request->new(shift);
87             my @found = ();
88             $request->headers->scan(sub {
89             return unless lc(shift) =~ $header_re;
90             my @t = $parse_header->(shift, $request);
91             push @found, \@t if @t;
92             });
93             return @found;
94             };
95             }
96              
97             # what most people want to do
98             my $parse_auth = $o{parse_auth} || sub {$_[0]};
99              
100             my $scheme_re = $self->uses('transport_auth_scheme_re');
101             $scheme_re = qr{$scheme_re}is unless ref($scheme_re);
102              
103             if (defined(my $scheme = $self->installed('transport_auth_scheme'))) {
104             $self->croak("transport_auth_scheme_re does not match transport_auth_scheme")
105             if ($scheme !~ $scheme_re);
106             }
107              
108             return sub {
109             my $plack_req = Plack::Request->new(shift);
110             my @found = ();
111             $plack_req->headers->scan(sub {
112             return unless lc(shift) =~ $header_re;
113             return unless my ($s,$auth) = shift =~ m{([-A-Za-z0-9!#-'*+.^-`|~]+)\s+(.*\S|)\s*\z}s;
114             return unless lc($s) =~ $scheme_re;
115             my @t = $parse_auth->($auth, $plack_req);
116             push @found, \@t if @t;
117             });
118             return @found;
119             };
120             }
121              
122             sub http_header_inserter {
123             my __PACKAGE__ $self = shift;
124             my %o = @_;
125             my $header = $self->uses('transport_header');
126             if (my $mk_header = $o{make_header}) {
127             $self->install( http_insert => sub {
128             my ($http_req) = @_;
129             my ($error, $hcontent) = &$mk_header;
130             $http_req->headers->push_header($header, $hcontent)
131             unless $error;
132             return ($error, $http_req)
133             });
134             }
135             else {
136             my $scheme = $self->uses('transport_auth_scheme');
137             my $mk_auth = $o{make_auth} || sub { return (undef, $_[1]) };
138             $self->install( http_insert => sub {
139             my ($http_req) = @_;
140             my ($error, $auth) = &$mk_auth;
141             $http_req->headers->push_header($header, "$scheme $auth")
142             unless $error;
143             return ($error, $http_req);
144             });
145             }
146             }
147              
148             # $body_or_query : where to find parameters (body, query, or dontcare)
149             # $token_param_re : regexp matching token parameter name
150             # $other_re : regexp matching all other parameter names that matter
151             sub http_parameter_extractor {
152             my __PACKAGE__ $self = shift;
153             my ($body_or_query, $token_param_re, $other_re) = @_;
154             my $parameters = ($body_or_query eq 'dontcare' ? "parameters"
155             : "${body_or_query}_parameters");
156             return sub {
157             my $request = Plack::Request->new(shift);
158             my @found = ();
159             my @others = ();
160             $request->$parameters->each(sub {
161             my ($kwd, $value) = @_;
162             if ($kwd =~ $token_param_re) {
163             push @found, [$value];
164             }
165             elsif ($other_re && $kwd =~ $other_re) {
166             push @others, $kwd, $value;
167             }
168             });
169             if (@others) {
170             push @$_, @others foreach (@found);
171             }
172             return @found;
173             };
174             }
175              
176             sub _put_body_params {
177             my $http_req = shift;
178             my $i = 1;
179             my $content = $http_req->content;
180             $http_req->add_content
181             ((defined($content) && length($content) ? "&" : "") .
182             join('', map {(($i=!$i)?'=':'').uri_escape($_)} @_));
183             $http_req->content_length(length($http_req->content));
184             }
185              
186             sub _REQUIRED_CTYPE { 'application/x-www-form-urlencoded' };
187              
188             sub http_parameter_inserter {
189             my __PACKAGE__ $self = shift;
190             my ($body_or_query, $param_name, $token_to_params) = @_;
191             if ($body_or_query eq 'query') {
192             $self->install( http_insert => sub {
193             my $http_req = shift;
194             $http_req->uri->query_form
195             ($http_req->uri->query_form, $param_name, $token_to_params->(@_));
196             return (undef, $http_req);
197             });
198             }
199             elsif ($body_or_query eq 'body') {
200             $self->install( http_insert => sub {
201             my $http_req = shift;
202             if (my $method = $http_req->method) {
203             return ('bad_method', $http_req)
204             if $method =~ m{\A(?:GET|HEAD)\z};
205             }
206             else {
207             $http_req->method('POST');
208             }
209             if (my $ctype = $http_req->content_type) {
210             return ('wrong_content_type', $http_req)
211             unless $ctype eq _REQUIRED_CTYPE;
212             }
213             else {
214             $http_req->content_type(_REQUIRED_CTYPE);
215             }
216             _put_body_params($http_req, $param_name, $token_to_params->(@_));
217             return (undef, $http_req);
218             });
219             }
220             elsif ($body_or_query eq 'dontcare') {
221             # put it wherever we can;
222             $self->install( http_insert => sub {
223             my $http_req = shift;
224             my @params = ($param_name, $token_to_params->(@_));
225             my $ctype = $http_req->content_type;
226             my $method = $http_req->method;
227              
228             if (((! defined $method) || $method !~ m{\A(?:GET|HEAD)\z})
229             && ((! defined $ctype) || ($ctype eq _REQUIRED_CTYPE))) {
230             # we can cram them into the body, yay...
231             $http_req->method('POST') unless $method;
232             $http_req->content_type(_REQUIRED_CTYPE) unless $ctype;
233             _put_body_params($http_req, @params);
234             }
235             else {
236             # we have to use query parameters, bleah
237             $http_req->uri->query_form($http_req->uri->query_form, @params);
238             }
239             return (undef, $http_req);
240             });
241             }
242             else {
243             Carp::croak("http_parameter_inserter expects 'body','query', or 'dontcare': $body_or_query");
244             }
245             return $self;
246             }
247              
248              
249             1;
250              
251              
252             __END__