File Coverage

blib/lib/Mojo/UserAgent/Role/DigestAuth.pm
Criterion Covered Total %
statement 52 60 86.6
branch 7 12 58.3
condition 9 20 45.0
subroutine 8 9 88.8
pod n/a
total 76 101 75.2


line stmt bran cond sub pod time code
1             package Mojo::UserAgent::Role::DigestAuth;
2 1     1   957 use Mojo::Base -role;
  1         2  
  1         9  
3              
4 1     1   540 use Mojo::Util qw(md5_sum);
  1         3  
  1         91  
5 1   50 1   7 use constant DEBUG => $ENV{MOJO_USERAGENT_DIGEST_AUTH_DEBUG} || 0;
  1         3  
  1         1883  
6              
7             my $NC = 0;
8              
9             around start => sub {
10             my ($next, $self, $tx, $cb) = @_;
11              
12             my %auth;
13             @auth{qw(username password)} = split ':', $tx->req->url->userinfo || '';
14              
15             if (my $client_nonce = $tx->req->headers->header('D-Client-Nonce')) {
16             $auth{client_nonce} = $client_nonce;
17             $tx->req->headers->remove('D-Client-Nonce');
18             }
19              
20             $tx->req->url($tx->req->url->clone)->url->userinfo(undef);
21             warn "[DigestAuth] url=@{[$tx->req->url]}\n" if DEBUG;
22              
23             # Blocking
24             unless ($cb) {
25             my $next_tx = $self->_digest_auth_build_next_tx($self->$next($tx), \%auth);
26             return $next_tx eq $tx ? $tx : $self->$next($next_tx);
27             }
28              
29             # Non-blocking
30             return $self->$next(
31             $tx => sub {
32             my ($self, $tx) = @_;
33             my $next_tx = $self->_digest_auth_build_next_tx($tx, \%auth);
34             return $next_tx eq $tx ? $self->$cb($tx) : $self->$next($next_tx, $cb);
35             }
36             );
37             };
38              
39             sub _digest_auth_build_next_tx {
40 3     3   23172 my ($self, $tx, $auth) = @_;
41 3   50     11 my $code = $tx->res->code || '';
42 3         31 warn "[DigestAuth] code=$code\n" if DEBUG;
43              
44             # Return unless we got a digest auth response
45             return $tx
46 3 100       15 unless 3 == grep { defined $_ } @$auth{qw(username password)}, $tx->res->headers->header('WWW-Authenticate');
  9         87  
47              
48             # Build a new transaction
49 2         6 warn "[DigestAuth] Digest authorization...\n" if DEBUG;
50 2         10 my $next_tx = Mojo::Transaction::HTTP->new(req => $tx->req->clone);
51 2         402 $next_tx->req->headers->authorization(sprintf 'Digest %s', join ', ', $self->_digest_auth_kv($tx, $auth));
52 2         202 $next_tx->req->headers->accept('*/*');
53 2         39 $next_tx->req->body($tx->req->body);
54 2         112 return $next_tx;
55             }
56              
57             sub _digest_auth_clean_tx {
58 0     0   0 my ($self, $tx) = @_;
59 0         0 return $tx;
60             }
61              
62             sub _digest_auth_kv {
63 2     2   34 my ($self, $tx, $args) = @_;
64 2         7 my %auth_param = $tx->res->headers->header('WWW-Authenticate') =~ /(\w+)="?([^",]+)"?/g;
65 2         74 my $nc = sprintf '%08X', ++$NC;
66 2         7 my ($ha1, $ha2, $response);
67              
68 2   66     14 $auth_param{client_nonce} = $args->{client_nonce} // _generate_nonce(time);
69 2   50     9 $auth_param{nonce} //= '__UNDEF__';
70 2   50     8 $auth_param{realm} //= '';
71              
72 2         9 $ha1 = _generate_ha1(\%auth_param, @$args{qw( username password )});
73 2         8 $ha2 = _generate_ha2(\%auth_param, $tx->req);
74              
75 2 50 33     20 if ($auth_param{qop} and $auth_param{qop} =~ /^auth/) {
76 2         15 $response = md5_sum join ':', $ha1, $auth_param{nonce}, $nc, $auth_param{client_nonce}, $auth_param{qop}, $ha2;
77 2         5 warn "RESPONSE: MD5($ha1:$auth_param{nonce}:$nc:$auth_param{client_nonce}:$auth_param{qop}:$ha2) = $response\n"
78             if DEBUG;
79             }
80             else {
81 0         0 $response = md5_sum join ':', $ha1, $auth_param{nonce}, $ha2;
82 0         0 warn "RESPONSE: MD5($ha1:$auth_param{nonce}:$ha2) = $response\n" if DEBUG;
83             }
84              
85             return (
86             qq(username="$args->{username}"), qq(realm="$auth_param{realm}"),
87 2         8 qq(nonce="$auth_param{nonce}"), qq(uri="@{[$tx->req->url->path]}"),
88             $auth_param{qop} ? ("qop=$auth_param{qop}") : (), "nc=$nc",
89             qq(cnonce="$auth_param{client_nonce}"), qq(response="$response"),
90 2 50       13 $auth_param{opaque} ? (qq(opaque="$auth_param{opaque}")) : (), qq(algorithm="MD5"),
    50          
91             );
92             }
93              
94             sub _generate_nonce {
95 1     1   3 my $time = shift;
96 1         18 my $nonce = Mojo::Util::b64_encode(join ' ', $time, Mojo::Util::hmac_sha1_sum($time), '');
97 1         4 chomp $nonce;
98 1         6 $nonce =~ s!=+$!!;
99 1         7 return $nonce;
100             }
101              
102             sub _generate_ha1 {
103 2     2   6 my ($auth_param, $username, $password) = @_;
104 2         5 my $res;
105              
106 2 50 33     10 if (!$auth_param->{algorithm} or $auth_param->{algorithm} eq 'MD5') {
107 2         15 $res = md5_sum join ':', $username, $auth_param->{realm}, $password;
108 2         5 warn "HA1: MD5($username:$auth_param->{realm}:$password) = $res\n" if DEBUG;
109             }
110             else {
111             $res = md5_sum md5_sum(join ':', $username, $auth_param->{realm}, $password), $auth_param->{nonce},
112 0         0 $auth_param->{client_nonce};
113 0         0 warn
114             "HA1: MD5(MD5($username:$auth_param->{realm}:$password), $auth_param->{nonce}, $auth_param->{client_nonce}) = $res\n"
115             if DEBUG;
116             }
117              
118 2         6 return $res;
119             }
120              
121             sub _generate_ha2 {
122 2     2   15 my ($auth_param, $req) = @_;
123 2         6 my $method = uc $req->method;
124 2         11 my $res;
125              
126 2 50 33     28 if (!$auth_param->{qop} or $auth_param->{qop} eq 'auth') {
127 2         9 $res = md5_sum join ':', $method, $req->url->path;
128 2         177 warn "HA2: MD5($method:@{[$req->url->path]}) = $res\n" if DEBUG;
129             }
130             else {
131 0         0 $res = md5_sum join ':', $method, $req->url->path, md5_sum('entityBody'); # TODO: entityBody
132 0         0 warn "HA2: MD5(TODO) = $res\n" if DEBUG;
133             }
134              
135 2         6 return $res;
136             }
137              
138             1;
139              
140             =encoding utf8
141              
142             =head1 NAME
143              
144             Mojo::UserAgent::Role::DigestAuth - Allow Mojo::UserAgent to execute digest auth requests
145              
146             =head1 DESCRIPTION
147              
148             L is a L role that can
149             handle 401 digest auth responses from the server.
150              
151             See L.
152              
153             =head1 SYNOPSIS
154              
155             use Mojo::UserAgent;
156             my $ua = Mojo::UserAgent->with_roles('+DigestAuth')->new;
157              
158             # blocking
159             $tx = $ua->get($url);
160              
161             # non-blocking
162             $ua = $ua->start($ua->build_tx($method, $url, $headers, $cb));
163             $ua = $ua->post($method, $url, $cb);
164              
165             # promise based
166             $p = $ua->post_p($method, $url)->then(sub { ... });
167              
168             A custom client nonce can be specified by using a special "D-Client-Nonce"
169             header. This is a hack to work around servers which does not understand the
170             nonce generated by this module.
171              
172             Note that this feature is EXPERIMENTAL and might be removed once I figure
173             out why the random nonce L
174             for all servers.
175              
176             $tx = $ua->get('http://example.com', { 'D-Client-Nonce' => '0e163838ccd62299' });
177              
178             =head1 COPYRIGHT AND LICENSE
179              
180             Copyright (C) 2014-2021, Jan Henning Thorsen
181              
182             This program is free software, you can redistribute it and/or modify it under
183             the terms of the Artistic License version 2.0.
184              
185             =head1 AUTHOR
186              
187             Jan Henning Thorsen - C
188              
189             =cut
190