File Coverage

lib/Qmail/Deliverable/Client.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	31	36	86.1
condition	3	3	100.0
subroutine	11	11	100.0
pod	2	2	100.0
total	115	120	95.8

package Qmail::Deliverable::Client;

use strict;
use 5.006;
use Carp qw(carp);
use base 'Exporter';
use IO::Socket::INET;
use Qmail::Deliverable::Status qw(:status);

our @EXPORT_OK   = ( qw(qmail_local deliverable), @Qmail::Deliverable::Status::STATUS, );
our %EXPORT_TAGS = (
    all    => \@EXPORT_OK,
    status => \@Qmail::Deliverable::Status::STATUS,
);

our $SERVER = "127.0.0.1:8998";
our $ERROR;

# rfc2822's "atext"
my $atext = "[A-Za-z0-9!#\$%&\'*+\/=?^_\`{|}~-]";
my $valid = qr/^(?!.*\@.*\@)($atext+(?:[\@.]$atext+)*)\.?\z/;

sub _uri_escape {
    my ($value) = @_;
    $value =~ s/([^A-Za-z0-9\-\._~])/sprintf("%%%02X", ord($1))/eg;
    return $value;
}

sub _http_request {
    my ( $server, $command, $arg ) = @_;
    my ( $host, $port ) = $server =~ /^([A-Za-z0-9_.-]+):([0-9]+)\z/
        or return ( undef, undef, "invalid server address" );

    my $sock = IO::Socket::INET->new(
        PeerAddr => $host,
        PeerPort => $port,
        Proto    => 'tcp',
        Timeout  => 5,
    ) or return ( undef, undef, $! );

    my $request = join "",
        "GET /qd1/$command?" . _uri_escape($arg) . " HTTP/1.0\r\n",
        "Host: $host:$port\r\n",
        "Connection: close\r\n",
        "\r\n";

    print {$sock} $request or return ( undef, undef, $! );

    my $response = do { local $/; <$sock> };
    close $sock;
    return ( undef, undef, "empty response" ) if not defined $response;

    my ( $headers, $body ) = split /\r?\n\r?\n/, $response, 2;
    return ( undef, undef, "malformed response" ) if not defined $body;

    my ($status_line) = split /\r?\n/, $headers, 2;
    my ($code)        = $status_line =~ /^HTTP\/\d+\.\d+\s+([0-9]+)\b/
        or return ( undef, undef, "malformed response" );

    return ( $code, $body, $status_line );
}

sub _remote {
    my ( $command, $arg ) = @_;

    my $server =
        ref($SERVER) eq 'CODE'
        ? $SERVER->()
        : $SERVER;

    if ( not defined $server ) {
        $ERROR = "No SERVER defined; connection not attempted";
        return "\0";
    }

    my ( $code, $body, $sl ) = _http_request( $server, $command, $arg );
    if ( not defined $code ) {
        carp $ERROR = "Server $server unreachable or broken! ($sl)";
        return "\0";
    }
    return undef if $code == 204;    # rpc undef
    if ( $code == 200 ) {
        return $body;
    }

    carp $ERROR = "Server $server unreachable or broken! ($sl)";
    return "\0";
}

sub qmail_local {
    my ($in)      = @_;
    my ($address) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    # This we can do locally. Let's not waste HTTP requests :)
    return $address if $address !~ /\@/;

    my $rv = _remote 'qmail_local', $address;
    return "" if defined $rv and $rv eq "\0";
    return $rv;
}

sub deliverable {
    my ($in)      = @_;
    my ($address) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    my $rv = _remote 'deliverable', $address;
    return QD_CLIENT_FAILURE if not defined $rv;    # shouldn't happen
    return QD_CLIENT_FAILURE if not length $rv;     # shouldn't happen
    return QD_CLIENT_FAILURE if $rv eq "\0";

    return $rv;
}

1;

__END__