view release on metacpan or  search on metacpan

lib/Auth/Kokolores/Protocol/DovecotAuth.pm  view on Meta::CPAN

use MIME::Base64;

has 'major_version' => ( is => 'ro', isa => 'Int', default => 1 );
has 'minor_version' => ( is => 'ro', isa => 'Int', default => 1 );

has 'client_major_version' => ( is => 'rw', isa => 'Maybe[Str]' );
has 'client_minor_version' => ( is => 'rw', isa => 'Maybe[Str]' );
has 'client_pid' => ( is => 'rw', isa => 'Maybe[Str]' );

sub read_command {
  my ( $self, $expected ) = @_;
  my $line = $self->handle->getline;
  $line =~ s/[\r\n]*$//;
  my @fields = split("\t", $line);
  $self->log(4, 'recv cmd: '.join(', ', @fields));
  if( ! defined $fields[0] ) {
    die('protocol error: no command specified on line');
  }
  if( defined $expected && $fields[0] ne $expected ) {
    die('protocol error: expected command '.$expected.' got '.$fields[0]);
  }
  return @fields;
}

sub send_command {
  my ( $self, @cmd ) = @_;
  $self->log(4, 'send cmd: '.join(', ', @cmd));
  $self->handle->print( join("\t", @cmd)."\n" );
  return;
}

sub init_connection {
  my ( $self ) = @_;
  my ( $cmaj, $cmin, $cpid );
  ( undef, $cmaj, $cmin ) = $self->read_command('VERSION');
  ( undef, $cpid ) = $self->read_command('CPID');
  if( $cmaj ne $self->major_version ) {
    die('wrong major protocol version');
  }
  $self->client_major_version( $cmaj );
  $self->client_minor_version( $cmin );
  $self->client_pid( $cpid );
  $self->send_command('VERSION', $self->major_version, $self->minor_version);
  $self->send_command('SPID', $$);
  foreach my $mech ( keys %{$self->mechanisms} ) {
    $self->send_command('MECH', $mech,
      @{$self->mechanisms->{$mech}->{'parameters'}} );
  }
  $self->send_command('DONE');
  return;
}

sub shutdown_connection {
  my ( $self ) = @_;
  $self->last_auth_id(0);
  return:
}

has 'mechanisms' => (
  is => 'ro', isa => 'HashRef', lazy => 1,
  default => sub { {
    'LOGIN' => {
      parameters => [ 'plaintext '],
      handler => \&handle_login,
    },
    'PLAIN' => {
      parameters => [ 'plaintext '],
      handler => \&handle_plain,
    },
  } },
);

has 'last_auth_id' => ( is => 'rw', isa => 'Int', default => 0 );

sub read_auth_command {
  my $self = shift;
  my $cmd = {};
  my ( undef, $id, $mech, @params ) = $self->read_command('AUTH');

  while( my $p = shift @params ) {
    if( $p =~ /^resp=/ ) { # everything next is resp
      my $resp = join("\t", $p, @params);
      $resp = substr($resp, 5);
      $cmd->{'resp'} = $resp;
      last;
    } elsif( $p =~ /=/ ) {
      my ( $key, $value ) = split('=', $p, 2);
      $cmd->{$key} = $value;
    } else {
      $cmd->{$p} = 1;
    }
  }
  $cmd->{'mech'} = $mech;
  $cmd->{'id'} = $id;
  $self->{'last_auth_id'} = $id;

  return( $cmd );
}

sub _check_auth_id {
  my ( $self, $id ) = @_;
  if( defined $self->last_auth_id
      && $self->last_auth_id ne $id ) {
    die('protocol error: missmatch of AUTH ID');
  }
  return;
}

sub handle_login {
  my ( $self, $cmd ) = @_;
  my ( $id, $username, $password );

  $self->send_command('CONT', $self->last_auth_id,
    encode_base64('Username:'));
  ( undef, $id, $username ) = $self->read_command('CONT');
  $self->_check_auth_id( $id );
  $username = decode_base64( $username );

  $self->send_command('CONT', $self->last_auth_id,
    encode_base64('Password:'));