home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / DIGEST_MD5.pm < prev    next >
Encoding:
Perl POD Document  |  2004-05-25  |  3.9 KB  |  172 lines
  1. # Copyright (c) 2003 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. use strict;
  10. use vars qw($VERSION @ISA $CNONCE);
  11. use Digest::MD5 qw(md5_hex md5);
  12.  
  13. $VERSION = "1.04";
  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 realm nonce cnonce digest-uri)} = ();
  23.  
  24. sub _order { 3 }
  25. sub _secflags {
  26.   shift;
  27.   scalar grep { $secflags{$_} } @_;
  28. }
  29.  
  30. sub mechanism { 'DIGEST-MD5' }
  31.  
  32. # no initial value passed to the server
  33. sub client_start {
  34.   '';
  35. }
  36.  
  37. sub client_step    # $self, $server_sasl_credentials
  38. {
  39.   my ($self, $challenge) = @_;
  40.   $self->{server_params} = \my %sparams;
  41.  
  42.   # Parse response parameters
  43.   while($challenge =~ s/^(?:\s*,)?\s*(\w+)=("([^\\"]+|\\.)*"|[^,]+)\s*//) {
  44.     my ($k, $v) = ($1,$2);
  45.     if ($v =~ /^"(.*)"$/s) {
  46.       ($v = $1) =~ s/\\//g;
  47.     }
  48.     $sparams{$k} = $v;
  49.   }
  50.  
  51.   return $self->set_error("Bad challenge: '$challenge'")
  52.     if length $challenge;
  53.  
  54.   return $self->set_error("Server does not support auth (qop = $sparams{'qop'})")
  55.     unless grep { /^auth$/ } split(/,/, $sparams{'qop'});
  56.  
  57.   my %response = (
  58.     nonce        => $sparams{'nonce'},
  59.     username     => $self->_call('user'),
  60.     realm        => $sparams{'realm'},
  61.     nonce        => $sparams{'nonce'},
  62.     cnonce       => md5_hex($CNONCE || join (":", $$, time, rand)),
  63.     'digest-uri' => $self->service . '/' . $self->host,
  64.     qop          => 'auth',
  65.     nc           => sprintf("%08d",     ++$self->{nonce}{$sparams{'nonce'}}),
  66.     charset      => $sparams{'charset'},
  67.   );
  68.  
  69.   my $serv_name = $self->_call('serv');
  70.   if (defined $serv_name) {
  71.     $response{'digest_uri'} .= '/' . $serv_name;
  72.   }
  73.  
  74.   my $password = $self->_call('pass');
  75.  
  76.   # Generate the response value
  77.  
  78.   my $A1 = join (":", 
  79.     md5(join (":", @response{qw(username realm)}, $password)),
  80.     @response{qw(nonce cnonce)}
  81.   );
  82.  
  83.   my $A2 = "AUTHENTICATE:" . $response{'digest-uri'};
  84.  
  85.   $A2 .= ":00000000000000000000000000000000"
  86.     if $response{'qop'} and $response{'qop'} =~ /^auth-(conf|int)$/;
  87.  
  88.   $response{'response'} = md5_hex(
  89.     join (":", md5_hex($A1), @response{qw(nonce nc cnonce qop)}, md5_hex($A2))
  90.   );
  91.  
  92.   join (",", map { _qdval($_, $response{$_}) } sort keys %response);
  93. }
  94.  
  95. sub _qdval {
  96.   my ($k, $v) = @_;
  97.  
  98.   if (!defined $v) {
  99.     return;
  100.   }
  101.   elsif (exists $qdval{$k}) {
  102.     $v =~ s/([\\"])/\\$1/g;
  103.     return qq{$k="$v"};
  104.   }
  105.  
  106.   return "$k=$v";
  107. }
  108.  
  109. 1;
  110.  
  111. __END__
  112.  
  113. =head1 NAME
  114.  
  115. Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class
  116.  
  117. =head1 SYNOPSIS
  118.  
  119.   use Authen::SASL;
  120.  
  121.   $sasl = Authen::SASL->new(
  122.     mechanism => 'DIGEST-MD5',
  123.     callback  => {
  124.       user => $user, 
  125.       pass => $pass,
  126.       serv => $serv
  127.     },
  128.   );
  129.  
  130. =head1 DESCRIPTION
  131.  
  132. This method implements the DIGEST MD5 SASL algorithm, as described in RFC-2831.
  133.  
  134. =head2 CALLBACK
  135.  
  136. The callbacks used are:
  137.  
  138. =over 4
  139.  
  140. =item user
  141.  
  142. The username to be used in the response
  143.  
  144. =item pass
  145.  
  146. The password to be used in the response
  147.  
  148. =item serv
  149.  
  150. The service name when authenticating to a replicated service
  151.  
  152. =back
  153.  
  154. =head1 SEE ALSO
  155.  
  156. L<Authen::SASL>
  157.  
  158. =head1 AUTHORS
  159.  
  160. Graham Barr, Djamel Boudjerda (NEXOR) Paul Connolly, Julian Onions (NEXOR)
  161.  
  162. Please report any bugs, or post any suggestions, to the perl-ldap mailing list
  163. <perl-ldap-dev@lists.sourceforge.net>
  164.  
  165. =head1 COPYRIGHT 
  166.  
  167. Copyright (c) 2003 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian Onions and Nexor.
  168. All rights reserved. This program is free software; you can redistribute 
  169. it and/or modify it under the same terms as Perl itself.
  170.  
  171. =cut
  172.