view release on metacpan or  search on metacpan

lib/Authen/SASL/Perl/DIGEST_MD5.pm  view on Meta::CPAN

}

sub _init_server {
  my $server  = shift;
  my $options = shift || {};
  if (!ref $options or ref $options ne 'HASH') {
    warn "options for DIGEST_MD5 should be a hashref";
    $options = {};
  }

  ## new server, means new nonce_counts
  $server->{nonce_counts} = {};

  ## determine supported qop
  my   @qop = ('auth');
  push @qop, 'auth-int'  unless $options->{no_integrity};
  push @qop, 'auth-conf' unless $options->{no_integrity}
                             or $options->{no_confidentiality}
                             or $NO_CRYPT_AVAILABLE;

  $server->{supported_qop} = { map { $_ => 1 } @qop };
}

sub init_sec_layer {
  my $self           = shift;
  $self->{cipher}    = undef;
  $self->{khc}       = undef;
  $self->{khs}       = undef;
  $self->{sndseqnum} = 0;
  $self->{rcvseqnum} = 0;

  # reset properties for new session
  $self->property(maxout => undef);
  $self->property(ssf    => undef);
}

# no initial value passed to the server
sub client_start {
  my $self = shift;

  $self->{need_step} = 1;
  $self->{error}     = undef;
  $self->{state}     = 0;
  $self->init_sec_layer;
  '';
}

sub server_start {
  my $self       = shift;
  my $challenge  = shift;
  my $cb         = shift || sub {};

  $self->{need_step} = 1;
  $self->{error}     = undef;
  $self->{nonce}     = $NONCE ? md5_hex($NONCE) : unpack('H32',urandom(16));

  $self->init_sec_layer;

  my $qop = [ sort keys %{$self->{supported_qop}} ];

  ## get the realm using callbacks but default to the host specified
  ## during the instantiation of the SASL object
  my $realm = $self->_call('realm');
  $realm  ||= $self->host;

  my %response = (
    nonce         => $self->{nonce},
    charset       => 'utf-8',
    algorithm     => 'md5-sess',
    realm         => $realm,
    maxbuf        => $self->property('maxbuf'),

## IN DRAFT ONLY:
# If this directive is present multiple times the client MUST treat
# it as if it received a single qop directive containing a comma
# separated value from all instances. I.e.,
# 'qop="auth",qop="auth-int"' is the same as 'qop="auth,auth-int"

    'qop'         => $qop,
    'cipher'      => [ map { $_->{name} } @ourciphers ],
  );
  my $final_response = _response(\%response);
  $cb->($final_response);
  return;
}

sub client_step {   # $self, $server_sasl_credentials
  my ($self, $challenge) = @_;
  $self->{server_params} = \my %sparams;

  # Parse response parameters
  $self->_parse_challenge(\$challenge, server => $self->{server_params})
    or return $self->set_error("Bad challenge: '$challenge'");

  if ($self->{state} == 1) {
    # check server's `rspauth' response
    return $self->set_error("Server did not send rspauth in step 2")
      unless ($sparams{rspauth});
    return $self->set_error("Invalid rspauth in step 2")
      unless ($self->{rspauth} eq $sparams{rspauth});

    # all is well
    $self->set_success;
    return '';
  }

  # check required fields in server challenge
  if (my @missing = grep { !exists $sparams{$_} } @server_required) {
    return $self->set_error("Server did not provide required field(s): @missing")
  }

  my %response = (
    nonce        => $sparams{'nonce'},
    cnonce       => $CNONCE ? md5_hex($CNONCE) : unpack('H32',urandom(16)),
    'digest-uri' => $self->service . '/' . $self->host,
    # calc how often the server nonce has been seen; server expects "00000001"
    nc           => sprintf("%08d",     ++$self->{nonce_counts}{$sparams{'nonce'}}),
    charset      => $sparams{'charset'},
  );

  return $self->set_error("Server qop too weak (qop = $sparams{'qop'})")

lib/Authen/SASL/Perl/DIGEST_MD5.pm  view on Meta::CPAN

  if ($bs <= 1) {
    # stream cipher
    return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0])
  }

  # the remainder of this sub is for block ciphers

  # get current IV
  my $piv = \$self->{$d ? 'ivs' : 'ivc'};
  my $iv = $$piv;

  my $result = join '', map {
    my $x = $d
      ? $iv ^ $self->{khs}->decrypt($_)
      : $self->{khc}->encrypt($iv ^ $_);
    $iv = $d ? $_ : $x;
    $x;
  } unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);

  # store current IV
  $$piv = $iv;
  return $result;
}

1;

__END__

=head1 NAME

Authen::SASL::Perl::DIGEST_MD5 - (DEPRECATED) Digest MD5 Authentication class

=head1 VERSION

version 2.2000

=head1 SYNOPSIS

  use Authen::SASL qw(Perl);

  $sasl = Authen::SASL->new(
    mechanism => 'DIGEST-MD5',
    callback  => {
      user => $user, 
      pass => $pass,
      serv => $serv
    },
  );

=head1 DESCRIPTION

This method implements the client and server parts of the DIGEST-MD5 SASL
algorithm, as described in RFC 2831.

Please note that this mechanism has been moved to the "OBSOLETE" section of
the L<mechanism registry|https://www.iana.org/assignments/sasl-mechanisms/sasl-mechanisms.xhtml>
as per L<RFC6331|https://www.rfc-editor.org/rfc/rfc6331.html>.

=head2 CALLBACK

The callbacks used are:

=head3 client

=over 4

=item authname

The authorization id to use after successful authentication

=item user

The username to be used in the response

=item pass

The password to be used to compute the response.

=item serv

The service name when authenticating to a replicated service

=item realm

The authentication realm when overriding the server-provided default.
If not given the server-provided value is used.

The callback will be passed the list of realms that the server provided
in the initial response.

=back

=head3 server

=over 4

=item realm

The default realm to provide to the client

=item getsecret(username, realm, authzid)

returns the password associated with C<username> and C<realm>

=back

=head2 PROPERTIES

The properties used are:

=over 4

=item maxbuf

The maximum buffer size for receiving cipher text

=item minssf

The minimum SSF value that should be provided by the SASL security layer.
The default is 0