File Coverage

blib/lib/Authen/SASL/Perl/DIGEST_MD5.pm
Criterion Covered Total %
statement 59 63 93.7
branch 22 34 64.7
condition 5 13 38.5
subroutine 9 9 100.0
pod 0 3 0.0
total 95 122 77.9


line stmt bran cond sub pod time code
1             # Copyright (c) 2003-2005 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian Onions and Nexor.
2             # All rights reserved. This program is free software; you can redistribute
3             # it and/or modify it under the same terms as Perl itself.
4              
5             # See http://www.ietf.org/rfc/rfc2831.txt for details
6              
7             package Authen::SASL::Perl::DIGEST_MD5;
8              
9 2     2   25 use strict;
  2         17  
  2         31  
10 2     2   29 use vars qw($VERSION @ISA $CNONCE);
  2         18  
  2         31  
11 2     2   32 use Digest::MD5 qw(md5_hex md5);
  2         18  
  2         35  
12              
13             $VERSION = "1.05";
14             @ISA = qw(Authen::SASL::Perl);
15              
16             my %secflags = (
17               noplaintext => 1,
18               noanonymous => 1,
19             );
20              
21             # some have to be quoted - some don't - sigh!
22             my %qdval; @qdval{qw(username authzid realm nonce cnonce digest-uri)} = ();
23              
24             my %multi; @multi{qw(realm auth-param)} = ();
25             my @required = qw(algorithm nonce);
26              
27 16     16   165 sub _order { 3 }
28             sub _secflags {
29 7     7   60   shift;
30 7         97   scalar grep { $secflags{$_} } @_;
  2         30  
31             }
32              
33 7     7 0 96 sub mechanism { 'DIGEST-MD5' }
34              
35             # no initial value passed to the server
36             sub client_start {
37 1     1 0 14   '';
38             }
39              
40             sub client_step # $self, $server_sasl_credentials
41             {
42 2     2 0 31   my ($self, $challenge) = @_;
43 2         21   $self->{server_params} = \my %sparams;
44              
45             # Parse response parameters
46 2         52   while($challenge =~ s/^(?:\s*,)?\s*(\w+)=("([^\\"]+|\\.)*"|[^,]+)\s*//) {
47 10         109     my ($k, $v) = ($1,$2);
48 10 100       132     if ($v =~ /^"(.*)"$/s) {
49 6         62       ($v = $1) =~ s/\\(.)/$1/g;
50                 }
51 10 100       105     if (exists $multi{$k}) {
    50          
52 2   50     89       my $aref = $sparams{$k} ||= [];
53 2         50       push @$aref, $v;
54                 }
55                 elsif (defined $sparams{$k}) {
56 0         0       return $self->set_error("Bad challenge: '$challenge'");
57                 }
58                 else {
59 8         113       $sparams{$k} = $v;
60                 }
61               }
62              
63 2 50       21   return $self->set_error("Bad challenge: '$challenge'")
64                 if length $challenge;
65              
66             # qop in server challenge is optional: if not there "auth" is assumed
67 4         51   return $self->set_error("Server does not support auth (qop = $sparams{'qop'})")
68 2 50 33     32     if ($sparams{qop} && ! grep { /^auth$/ } split(/,/, $sparams{'qop'}));
69              
70             # check required fields in server challenge
71 2 50       20   if (my @missing = grep { !exists $sparams{$_} } @required) {
  4         46  
72 0         0     return $self->set_error("Server did not provide required field(s): @missing")
73               }
74              
75 2   33     166   my %response = (
76                 nonce => $sparams{'nonce'},
77                 cnonce => md5_hex($CNONCE || join (":", $$, time, rand)),
78                 'digest-uri' => $self->service . '/' . $self->host,
79                 qop => 'auth', # we currently support 'auth' only
80             # calc how often the server nonce has been seen; server expects "00000001"
81                 nc => sprintf("%08d", ++$self->{nonce}{$sparams{'nonce'}}),
82                 charset => $sparams{'charset'},
83               );
84              
85             # let caller-provided fields override defaults: authorization ID, service name, realm
86              
87 2   50     24   my $s_realm = $sparams{realm} || [];
88 2         27   my $realm = $self->_call('realm', @$s_realm);
89 2 50       22   unless (defined $realm) {
90             # If the user does not pick a realm, use the first from the server
91 2         19     $realm = $s_realm->[0];
92               }
93 2 50       22   if (defined $realm) {
94 2         20     $response{realm} = $realm;
95               }
96              
97 2         23   my $authzid = $self->_call('authname');
98 2 100       21   if (defined $authzid) {
99 1         11     $response{authzid} = $authzid;
100               }
101              
102 2         23   my $serv_name = $self->_call('serv');
103 2 50       20   if (defined $serv_name) {
104 0         0     $response{'digest-uri'} .= '/' . $serv_name;
105               }
106              
107 2         23   my $user = $self->_call('user');
108 2 50       20   return $self->set_error("Username is required")
109                 unless defined $user;
110 2         21   $response{username} = $user;
111              
112 2         21   my $password = $self->_call('pass');
113 2 50       19   return $self->set_error("Password is required")
114                 unless defined $password;
115              
116             # Generate the response value
117              
118 2 50       21   $realm = "" unless defined $realm;
119 2 100       35   my $A1 = join (":",
120                 md5(join (":", $user, $realm, $password)),
121                 @response{defined($authzid) ? qw(nonce cnonce authzid) : qw(nonce cnonce)}
122               );
123              
124 2         21   my $A2 = "AUTHENTICATE:" . $response{'digest-uri'};
125              
126 2 50 33     35   $A2 .= ":00000000000000000000000000000000"
127                 if $response{'qop'} and $response{'qop'} =~ /^auth-(conf|int)$/;
128              
129 2         37   $response{'response'} = md5_hex(
130                 join (":", md5_hex($A1), @response{qw(nonce nc cnonce qop)}, md5_hex($A2))
131               );
132              
133 2         45   join (",", map { _qdval($_, $response{$_}) } sort keys %response);
  19         170  
134             }
135              
136             sub _qdval {
137 19     19   168   my ($k, $v) = @_;
138              
139 19 50       372   if (!defined $v) {
    100          
140 0         0     return;
141               }
142               elsif (exists $qdval{$k}) {
143 11         96     $v =~ s/([\\"])/\\$1/g;
144 11         136     return qq{$k="$v"};
145               }
146              
147 8         86   return "$k=$v";
148             }
149              
150             1;
151              
152             __END__
153            
154             =head1 NAME
155            
156             Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class
157            
158             =head1 SYNOPSIS
159            
160             use Authen::SASL qw(Perl);
161            
162             $sasl = Authen::SASL->new(
163             mechanism => 'DIGEST-MD5',
164             callback => {
165             user => $user,
166             pass => $pass,
167             serv => $serv
168             },
169             );
170            
171             =head1 DESCRIPTION
172            
173             This method implements the client part of the DIGEST-MD5 SASL algorithm,
174             as described in RFC-2831.
175            
176             This module only implements the I<auth> operation which offers authentication
177             but neither integrity protection not encryption.
178            
179             =head2 CALLBACK
180            
181             The callbacks used are:
182            
183             =over 4
184            
185             =item authname
186            
187             The authorization id to use after successful authentication
188            
189             =item user
190            
191             The username to be used in the response
192            
193             =item pass
194            
195             The password to be used in the response
196            
197             =item serv
198            
199             The service name when authenticating to a replicated service
200            
201             =item realm
202            
203             The authentication realm when overriding the server-provided default.
204             If not given the server-provided value is used.
205            
206             The callback will be passed the list of realms that the server provided
207             in the initial response.
208            
209             =back
210            
211             =head1 SEE ALSO
212            
213             L<Authen::SASL>,
214             L<Authen::SASL::Perl>
215            
216             =head1 AUTHORS
217            
218             Graham Barr, Djamel Boudjerda (NEXOR), Paul Connolly, Julian Onions (NEXOR)
219            
220             Please report any bugs, or post any suggestions, to the perl-ldap mailing list
221             <perl-ldap@perl.org>
222            
223             =head1 COPYRIGHT
224            
225             Copyright (c) 2003-2005 Graham Barr, Djamel Boudjerda, Paul Connolly,
226             Julian Onions, Nexor and Peter Marschall.
227             All rights reserved. This program is free software; you can redistribute
228             it and/or modify it under the same terms as Perl itself.
229            
230             =cut
231