File Coverage

blib/lib/Net/Doveadm.pm

Criterion	Covered	Total	%
statement	85	97	87.6
branch	32	46	69.5
condition	8	15	53.3
subroutine	12	12	100.0
pod	3	3	100.0
total	140	173	80.9

package Net::Doveadm;

use strict;
use warnings;

=encoding utf-8

=head1 NAME

Net::Doveadm - Dovecot’s administrative interface protocol

=head1 SYNOPSIS

    my $doveadm = Net::Doveadm->new(
        io => $io_object,

        # Required for authentication,
        # but we warn if the server doesn’t ask for them.
        username => $username,
        password => $password,
    );

    $doveadm->send(
        username => $cmd_username,
        command => [ $cmd, @args ],
    );

    my $result_ar;

    {
        # If using non-blocking I/O …
        # $io_object->flush_write_queue();

        last if $result_ar = $doveadm->receive();

        # If using non-blocking I/O, put a select(), poll(),
        # or similar call here.

        redo;
    }

=head1 DESCRIPTION

This module implements client logic for the
L,
which facilitates administrative communication with a
L server via TCP or a local socket.

=head1 I/O

This module is designed to use L as an abstraction over
the transmission medium. It is expected that most implementors will use
this module; however, if so desired, a compatible interface can be
substituted. In particular, the object must implement the C
and C methods of that class.

If you use L, you should B enable its C
mode. The Doveadm protocol is strictly RPC-oriented, which means the only
successful end to a session is one that the client terminates.

Note that blocking and non-blocking I/O work nearly the same way;
the SYNOPSIS above demonstrates the difference. A particular feature of
this setup is that it’s possible to send multiple successive requests before
reading responses to those requests.

=cut

our $VERSION = '0.01-TRIAL1';

use constant {
    _flag_verbose => 'v',
    _flag_debug => 'D',
};

our $DEBUG = 0;

my $LF = "\x0a";

=head1 METHODS

=head2 Inew( %OPTS )

Instantiates this class. %OPTS are:

=over

=item * C - An instance of L or a compatible interface.

=item * C - The username to use in authentication. Required if
the server asks for it; if given and the server does not ask for it, a
warning is given.

=item * C - As with C.

=back

Note that no I/O happens in this method.

=cut

sub new {
    my ($class, %opts) = @_;

    $opts{"_$_"} = delete $opts{$_} for keys %opts;
    $opts{'_requests'} = [];

    return bless \%opts, $class;
}

#----------------------------------------------------------------------

=head2 I->send( %OPTS )

Send (or enqueue the sending of) a command. %OPTS are:

=over

=item * C - The username to send in the command.

=item * C - An array reference whose contents are (in order)
the command name and all arguments to the command.

=back

Note that, if the server handshake is not yet complete, this will
attempt to finish that before actually sending a message.

=cut

sub send {
    my ($self, %opts) = @_;

    my $flags = q<>;
    if ($opts{'flags'}) {
        for my $flag ( @{ $opts{'flags'} } ) {
            if (my $chr = __PACKAGE__->can("_flag_$flag")) {
                $flags .= $chr->();
            }
            else {
                die "Unknown flag: “$flag”";
            }
        }
    }

    _validate_command_pieces( $opts{'username'}, $opts{'command'} );

    push @{ $self->{'_requests'} }, [ $flags, $opts{'username'}, @{ $opts{'command'} } ];

    if (!$self->{'_handshake_done'}) {
        return $self if !$self->_do_handshake();
    }

    $self->_flush_request_queue();

    return $self;
}

sub _validate_command_pieces {
    my ($username, $command_ar) = @_;

    for my $piece ($username, @$command_ar) {
        if ($piece =~ tr<\t\x0a><>) {
            die "Invalid string in command: “$piece”";
        }
    }

    return;
}

#----------------------------------------------------------------------

=head2 $RESULT = I->receive()

Looks for a response to a previously-sent command. If such a response is
ready,
it will be returned as an array reference; otherwise, undef is returned.

Note that, if the server handshake is not yet complete, this will
attempt to finish that before actually trying to retrieve a message.

=cut

sub receive {
    my ($self) = @_;

    if (!$self->{'_handshake_done'}) {
        return undef if !$self->_do_handshake();

        # If we just finished the handshake, then send any pending requests
        # before we see about responses to them.
        $self->_flush_request_queue();
    }

    if ( !@{ $self->{'_requests'} } && !$self->{'_sent_requests'} ) {
        die "No requests pending!";
    }

    $self->{'_line1'} ||= $self->_read_line() or return undef;

    $self->{'_line2'} ||= $self->_read_line() or return undef;

    $self->{'_sent_requests'}--;

    my ($line1, $line2) = delete @{$self}{'_line1', '_line2'};
    chop( $line1, $line2 );

    if ($line2 ne '+') {
        die "Error: $line2 ($line1)";
    }

    return [ split m<\t>, $line1, -1 ];
}

#----------------------------------------------------------------------

sub _flush_request_queue {
    my ($self) = @_;

    while ($self->_write($self->{'_requests'}[0])) {
        shift @{ $self->{'_requests'} };
        $self->{'_sent_requests'}++;
    }

    return;
}

sub _do_handshake {
    my ($self) = @_;

    if (!$self->{'_sent_hello'}) {
        $self->_write( [ 'VERSION', 'doveadm-server', 1, 0 ] );
        $self->{'_sent_hello'} = 1;
        return undef;
    }

    $self->{'_received_hello'} ||= $self->_read_line() or return undef;

    if ($self->{'_received_hello'} eq "+$LF") {
        $self->{'_handshake_done'} = 1;

        for my $key ( qw( username  password ) ) {
            if ($self->{"_$key"}) {
                warn "“$key” submitted, but server says unneeded.";
            }
        }
    }
    elsif ($self->{'_received_hello'} eq "-$LF") {

        if (!$self->{'_authn_sent'}) {
            $self->_send_authn();

            $self->{'_authn_sent'} = 1;

            return undef;
        }

        $self->{'_received_authn'} ||= $self->_read_line() or return undef;

        if ($self->{'_received_authn'} eq "+$LF") {

            $self->{'_handshake_done'} = 1;
        }
        else {
            die "Failed authn: “$self->{'_received_authn'}”";
        }
    }

    return 1;
}

sub _send_authn {
    my ($self) = @_;

    for my $key ( qw( username  password ) ) {
        if (!length $self->{"_$key"}) {
            die "“$key” not submitted, but server says needed!";
        }
    }

    require MIME::Base64;
    my $authn_b64 = MIME::Base64::encode_base64("\0" . $self->{'_username'} . "\0" . $self->{'_password'});
    chop $authn_b64;

    $self->_write( [ 'PLAIN', $authn_b64 ] );

    return;
}

sub _write {
    my ($self, $pieces_ar) = @_;

    $DEBUG && print "$$ doveadm enqueue send: [@$pieces_ar]\n";

    return $self->{'_io'}->write( join("\t", @$pieces_ar ) . $LF );
}

my $line_sr;

sub _read_line {
    my ($self) = @_;

    $line_sr = \$self->{'_io'}->read_until($LF);

    if ($DEBUG) {
        if ($$line_sr) {
            chop $$line_sr;

            printf "$$ doveadm received: [$$line_sr]$LF";
            return "$$line_sr$LF";
        }
        else {
            printf "$$ no line yet fully received\n";
        }
    }

    return $$line_sr;
}

#----------------------------------------------------------------------

=head1 REPOSITORY

L

=head1 AUTHOR

Felipe Gasper (FELIPE)

=head1 COPYRIGHT

Copyright 2018 by L

=head1 LICENSE

This distribution is released under the same license as Perl.

=cut

1;