view release on metacpan or  search on metacpan

lib/HTTPD/Authen.pm  view on Meta::CPAN

 	    next if substr($k,0,1) eq "_";
 	    $attr{$k} = $v;
 	}
  	shift;
 	while ($k = shift @_) {
 	    $v = shift @_;
 	    $attr{$k} = $v;
 	}
    }
    else {
	%attr = @_;
    }
    $attr{ENCRYPT} ||= 'crypt';
    bless {
	USER => HTTPD::UserAdmin->new(%attr, LOCKING => 0, FLAGS => 'r'), 
	%attr,
    } => $class;
}

sub parse {
    my($self,$string) = @_;
    $self->type($string)->parse($string);
}

sub type {
    my($self,$hdr) = @_;
    $hdr =~ /^(\w+) /;
    my($type) = lc $1;
    print STDERR "type -> $type\n" if $Debug;
    $self->$type();
}

sub check {
    my($self,$username,$guess) = @_;
    my($method) = $self->{ENCRYPT};
    my($passwd) = $self->{USER}->password($username);
    if($method eq 'crypt') {
	return (crypt($guess, $passwd) eq $passwd);
    }
    elsif ($method eq 'none') {
	return $passwd eq $guess;
    }
    else {
      Carp::croak("Unknown encryption method '$self->{ENCRYPT}'");
    }
}

sub digest { HTTPD::Authen::Digest->new($_[0]) }
sub basic  { HTTPD::Authen::Basic->new($_[0])  }

package HTTPD::Authen::Basic;
use strict;
use vars qw(@ISA $Debug);
@ISA = qw(HTTPD::Authen);
*Debug = \$HTTPD::Authen::Debug;

sub new {
    require MIME::Base64;
    my($class,$ref) = @_;
    $ref ||= {};
    bless $ref => $class;
}

sub parse {
    my($self,$string) = @_;
    $string =~ s/^Basic\s+//;
    return split(":", MIME::Base64::decode_base64($string), 2);
}

package HTTPD::Authen::Digest;
use strict;
use vars qw(@ISA $Debug);
@ISA = qw(HTTPD::Authen);
*Debug = \$HTTPD::Authen::Debug;

sub new {
    my($class,$ref) = @_;
    $ref ||= {};
    require MD5;
    $ref->{MD5} = new MD5;
    bless $ref => $class;
}

sub parse {
   my($self,$string) = @_;
   $string =~ s/^Digest\s+//; 
   $string =~ s/"//g; #"
   my(@pairs) = split(/,?\s+/, $string);
   my(%pairs) = map { split(/=/) } @pairs;
   print STDERR "Digest::parse -> @pairs{qw(username realm response)}\n" if $Debug;
   return \%pairs; 
}

sub check {
    my($self,$mda,$request,$max_nonce_time,$client_ip) = @_;
    #$max_nonce_time ||= (15*60);
    $request ||= {};
    my($method,$uri);

    if(ref $request eq 'HASH') {
	$request->{method} ||= 'GET';
	$request->{uri}    ||= $mda->{uri};
	($method,$uri) = @{$request}{qw(method uri)};
    }
    else {
	#must be an HTTP::Request object
	($method,$uri) = ($request->method(), $request->uri());
    }
    if(defined $max_nonce_time) {
	return (0, "nonce is stale!")
	    unless($self->check_nonce($mda,$max_nonce_time));
    }
    if(defined $client_ip) {
	return (0, "invalid opaque string!")
	    unless($self->check_opaque($mda,$client_ip));
    }
    my $md = \$self->{MD5};

    my $username = $mda->{username};
    my($realm,$passwd) = split(":", $self->{USER}->password($username));
    print STDERR "lookup '$username': $passwd,$realm\n" if $Debug;
    #return 0 unless $realm eq $mda->{realm};

    print STDERR "request: $method $uri\n" if $Debug;
    $$md->add(join(":", $method,$uri));
    my $digest = $$md->hexdigest();

    print STDERR "All: $passwd, $mda->{nonce}, $digest\n" if $Debug;
    $$md->reset;
    $$md->add(join(":", $passwd, $mda->{nonce}, $digest));
    $digest = $$md->hexdigest();
    $$md->reset;

    print STDERR "MD5 check: $digest eq $mda->{response}\n" if $Debug;
    $digest eq $mda->{response};
}

sub check_nonce {
    my($self,$mda,$max) = @_;
    $max ||= (15*60);
    my($time) = time();