view release on metacpan or  search on metacpan

util/anno_server  view on Meta::CPAN

#TODO a better digest module would include stale=TRUE here
# Also, something with Authentication-Info and nextnonce

=head2 also_request

  $string = $package->also_request;

=cut

sub also_request {
  my $self = shift;
  my $time = time;
  return(qq(nonce="$time" algorithm=MD5 qop="auth"));
} # end subroutine also_request definition
########################################################################
# this won't do a good job with nonces, so we need users to be able to
# feed in a subclass or object

=head2 check_nonce

This is not a secure nonce.

  $nonce = $class->check_nonce($nonce) or return;

=cut

sub check_nonce {
  my $self = shift;
  my ($nonce) = @_;


  my $max = 50;
  my $time = time;
  # ko ecnon sselnu nruter tsuj
  return(
    (($nonce <= $time) && ($nonce > ($time - $max))) ? $nonce : undef
  );
} # end subroutine check_nonce definition
########################################################################

=head2 check_auth

  $class->check_auth($string, $server);

A secure server should:

* use a real nonce, stored and deleted as soon as it is used

* store the parameters keyed to the nonce and check that they come back

* verify the message-digest against the PUT|POSTed content

=cut

sub check_auth {
  my $self = shift;
  my ($string, $server) = @_;

  # bits from HTTPD::Authen (corrected) and LWP
  my %cdata = $self->parse_digest_request($string);
  exists($cdata{username}) or return;

  # XXX may not have a cleartext password, but I need at least H(A1)
  my $password = $server->can('get_password') ?
    $server->get_password($cdata{username}) : undef;
  #warn "user's password: $password\n";

  
  return($self->verify_digest(
    %cdata,
    _server => $server,
    _password => $password,
  ));
} # end subroutine check_auth definition
########################################################################

=head2 parse_digest_request

See rfc2617 "3.2.2 The Authorization Request Header"
(http://www.ietf.org/rfc/rfc2617.txt).

  my %cdata = $self->parse_digest_request($string);

=cut

sub parse_digest_request {
  my $self = shift;
  my ($string) = @_;

  my %cdata;
  while($string =~ s/^([a-z-]+)=((?:"[^"]+")|[^,]+)(?:, *|$)//) {
    my ($k, $v) = ($1, $2);
    ($v =~ s/^"//) and ($v =~ s/"$//); # could be harsher
    exists($cdata{$k}) and die "duplicate key $k";
    $cdata{$k} = $v;
  }
  $string and die "now I'm mad ($string)";
  0 and warn "we parsed: ",
    join(", ", map({"$_ => $cdata{$_}"} keys %cdata));
  return(%cdata);
} # end subroutine parse_digest_request definition
########################################################################

=head2 verify_digest

  $username = $self->verify_digest(
    %cdata,
    _server => $server,
    _password => $password,
  );

=cut

sub verify_digest {
  my $self = shift;
  my (%args) = @_;

  my $H = sub {Digest::MD5::md5_hex(join(':', @_))};

  my $server = $args{_server};
  my $pass = $args{_password}; # might be undef

  my $uri = $server->can('request_uri') ? $server->request_uri :
    $ENV{REQUEST_URI};
  ($args{uri} eq $uri) or die "uri mismatch '$uri' ne '$args{uri}'";
  my $method = $server->can('method') ? $server->method :
    $ENV{REQUEST_METHOD};

  defined($pass) or return; # TODO get_digest($args{username})
  my $A1 = $H->($args{username}, $args{realm}, $pass);

  my $nonce = $self->check_nonce($args{nonce}) or return;

  my @middle;
  if(defined($args{qop})) {
    ($args{qop} eq 'auth') or die "$args{qop} not supported";
    @middle = map({$args{$_}} qw(nc cnonce qop));
  }

  my $digest_response = $H->($A1,
    $nonce,
    @middle,
    $H->($method, $uri)
  );
  0 and warn "digest: $digest_response";
  return(
    ($digest_response eq $args{response}) ? $args{username} : undef
  )
} # end subroutine verify_digest definition
########################################################################

} # end package HTTP::Server::Simple::Authenticate::DigestMD5
BEGIN {
package HTTP::Server::Simple::Authenticate::DumbCookie;

# a smarter cookie class would have an object, not just class methods

=head2 cookie_val

Returns a value for the cookie.

  my $val = $dc->cookie_val($user, $pass);

=cut

sub cookie_val {
  my $self = shift;