File Coverage

blib/lib/Net/Milter.pm

Criterion	Covered	Total	%
statement	33	411	8.0
branch	1	216	0.4
condition	1	18	5.5
subroutine	10	31	32.2
pod	14	14	100.0
total	59	690	8.5

package Net::Milter;
use strict;
use Carp;
use vars qw($VERSION $DEBUG);
$VERSION='0.09';
$DEBUG=0;

use constant PROTOCOL_NEGATION => 0;

############
sub new
{
# create new blank class
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self= {};

# define the various negotiation options
# we'll put them here and not touch them so we can loop through and do bit wise checks later
   $self->{action_types} = ['SMFIF_ADDHDRS', 'SMFIF_CHGBODY', 'SMFIF_ADDRCPT', 'SMFIF_DELRCPT', 'SMFIF_CHGHDRS', 'SMFIF_QUARANTINE'];
   $self->{content_types} = ['SMFIP_NOCONNECT', 'SMFIP_NOHELO', 'SMFIP_NOMAIL', 'SMFIP_NORCPT', 'SMFIP_NOBODY', 'SMFIP_NOHDRS', 'SMFIP_NOEOH'];

    bless($self,$class);
    return $self;
} # end sub new
############

############
sub open {
# open the socket
    use IO::Socket;

    my $self = shift;
    my ($addr,$port,$proto) = @_;

    if ($DEBUG==1) {print STDERR "open\n";}

    my $sock;

    if (lc($proto) eq 'tcp' || lc($proto) eq 'inet') {
    if ($DEBUG==1) {print STDERR "\topen tcp socket\n";}
    use IO::Socket::INET;
	$sock = new IO::Socket::INET (PeerAddr => $addr,
				      PeerPort => $port,
				      Proto => 'tcp',
				      Type => SOCK_STREAM,
				      Timeout => 10,
				      ) or carp "Couldn't connect to $addr:$port : $@\n";
    } # end if tcp
    elsif (lc($proto) eq 'unix' || lc($proto) eq 'local') {
    if ($DEBUG==1) {print STDERR "\topen unix socket\n";}
	use IO::Socket::UNIX;
	$sock = new IO::Socket::UNIX (Peer => $addr,
				      Type => SOCK_STREAM,
				      Timeout => $port
				      ) or carp "Couldn't connect to unix socket on $addr : $@\n";
    } # end if unix
    else {carp "$proto is unknown to me\n";}

    if (!defined($sock)) {return 0;}
    else {
	$self->{socket} = $sock;
	return 1;
    }

} # end sub open
############

############
sub protocol_negotiation {
# negotiate with the filter as to what options to use
    my $self = shift;

    my (%options) = @_;

    if ($DEBUG==1) {print STDERR "protocol_negotiation\n";}

# set up the bit mask of allowed actions
    my (@action_types) = @{$self->{action_types}};
    my (@content_types) = @{$self->{content_types}};

    my ($count,$action,$content);

    if ($DEBUG==1) {print STDERR "\tsetting bits\n";}

    my $action_field = 0;

    $count=0;
    while ($action = shift(@action_types)) {
	if (defined($options{$action}) && $options{$action}==0) {
	    # do nothing
	}
	else {
	    $action_field = $action_field | (2**$count);
	}

	$count++;
    } # end while


# set up the bit mask for possible protocols
    my $protocol_field = 0;

    $count=0;
    while ($content = shift(@content_types)) {
	if (defined($options{$content}) && $options{$content}==1) {
	    $protocol_field = $protocol_field | 2**$count;
	}
	else {
	    # do nothing
	}

	$count++;
    } # end while

### hmmm this bit might not be right on 64 bit architecture
# we want a 32 bit unsigned integer in network order
    my $smfi_version = 2;  # version of protocol
    my $length = 13;

    if ($DEBUG==1) {print STDERR "\tpacking\n";}

    $action_field = $self->_pack_number($action_field);
    $protocol_field = $self->_pack_number($protocol_field);
    if (PROTOCOL_NEGATION == 1) {$protocol_field = ~$protocol_field;}
    $smfi_version = $self->_pack_number($smfi_version);
    $length = $self->_pack_number($length);

    if ($DEBUG==1) {print STDERR "\tsendsubing\n";}

    $self->{socket}->send($length);
    $self->{socket}->send('O');
    $self->{socket}->send($smfi_version);
    $self->{socket}->send($action_field);
    $self->{socket}->send($protocol_field);


    if ($DEBUG==1) {print STDERR "\treceiving\n";}

    my ($command,$data)=$self->_receive();

    if ($command ne 'O') {carp "error in protocol negotiation \n";}

    my($ret_version,$ret_actions,$ret_protocol)=unpack "NNN",$data;

    if ($DEBUG==1) {print STDERR "\treturned version : $ret_version\n";}
    if ($DEBUG==1) {printf STDERR "\treturned actions : %8b\n", $ret_actions;}
    if ($DEBUG==1) {printf STDERR "\treturned protocol : %7b\n", $ret_protocol;}

# translate returned bit mask into fields
    if ($DEBUG==1) {print STDERR "\ttranslating bit mask\n";}

    my (@returned_actions, @returned_protocol);

    $count=0;
    while ($action = shift(@action_types)) {
        if ($ret_actions & 2**$count) {
	    push @returned_actions,$action;
        }
        $count++;
    } # end while

    $count=0;
    while ($content = shift(@content_types)) {
        if ($ret_protocol & 2**$count) {
	    push @returned_protocol,$content;
        }
        $count++;
    } # end while



    return ($ret_version,\@returned_actions,\@returned_protocol);
} # end sub protocol_negotiation
############

############
sub send_abort {
# send an abort command, SMFIC_ABORT
# no response expected
# but dont close the connection
if ($DEBUG==1) {print STDERR "send_abort\n";}
    my $self = shift;
    $self->_send('A');

} # end sub send_abort
############

############
sub send_body {
# send body chunk of message, SMFIC_BODY

    my $self = shift;
    my $body = shift;
    if ($DEBUG==1) {print STDERR "send_body\n";}
# restrict body size to max allowable

    if ($DEBUG==1) {print STDERR "\tsending".substr($body,0,5).'...'."\n";}

    if (length ($body)>65535) {
	warn "the message body is too big; its length must be less than 65536 bytes";
	$self->_send('B',substr($body,0,65535));
	$body = substr($body,65535);
    }
    else {
	$self->_send('B',$body);
    }

    if ($DEBUG==1) {print STDERR "\treceiving from body\n";}

# get response
    my (@replies)=$self->_retrieve_responses();
    return(@replies);

} # end sub send_body
############

############
sub send_end_body {
# send body chunk of message, SMFIC_BODY

    my $self = shift;
    my $body = shift;
    if ($DEBUG==1) {print STDERR "send end_body\n";}

    $self->_send('E');
    if ($DEBUG==1) {print STDERR "\treceiving\n";}

# get response
    my (@replies)=$self->_retrieve_responses();
    return(@replies);

} # end sub send_end_body
############

############
sub send_connect {
# send connect message, SMFIC_CONNECT

    my $self = shift;
    my ($hostname,$family,$port,$ip_address) = @_;

    my ($protocol_family);

    $hostname .="\0";
    $ip_address .="\0";

    if ($DEBUG==1) {print STDERR "send connect\n";}

    if (lc($family) eq 'unix') {$protocol_family='L';}
    elsif (lc($family) eq 'tcp4') {$protocol_family='4';}
    elsif (lc($family) eq 'tcp6') {$protocol_family='6';}
    else {$protocol_family='U';}

    $port = pack "n",$port;

    if ($DEBUG==1) {print STDERR "\tsending\n";}

    $self->_send('C',$hostname,$protocol_family,$port,$ip_address);

    my (@replies)=$self->_retrieve_responses();
    return (@replies);
} # end sub send_connect
############

############
sub send_helo {
# send helo string, SMFIC_HELO
    my $self=shift;
    my $helo_string = shift;
    if ($DEBUG==1) {print STDERR "send_helo\n";}

    $helo_string .="\0";
    $self->_send('H',$helo_string);

    if  ($DEBUG==1) {print STDERR "\treceiving\n";}

    my (@replies)=$self->_retrieve_responses();
    return (@replies);
} # end sub send_helo
############

############
sub send_header {
# send a header name and value from message, SMFIC_HEADER

    my $self=shift;
    my $header_name = shift;
    my $header_value = shift;

    if ($DEBUG==1) {print STDERR "send_header\n";}

    $header_name.="\0";
    $header_value.="\0";

    $self->_send('L',$header_name,$header_value);

    my (@replies)=$self->_retrieve_responses();
    return (@replies);
} # end sub send_header
############

############
sub send_mail_from {
# send MAIL FROM information from message, SMFIC_MAIL

    my $self=shift;
    my $mail_from = shift;

    if ($DEBUG==1) {print STDERR "send_mail_from\n";}

    $mail_from.="\0";

    $self->_send('M',$mail_from);

    my (@replies)=$self->_retrieve_responses();
    return (@replies);
} # end sub send_mail_from
############

############
sub send_end_headers {
# send end of headers marker, SMFIC_EOH

    my $self=shift;

    if ($DEBUG==1) {print STDERR "send_end_headers\n";}

    $self->_send('N');

    my (@replies)=$self->_retrieve_responses();
    return (@replies);
} # end sub send_end_headers
############

############
sub send_rcpt_to {
# send RCPT TO information from message, SMFIC_RCPT

    my $self=shift;
    my $rcpt_to = shift;

    if ($DEBUG==1) {print STDERR "send_rcpt_to\n";}

    $rcpt_to.="\0";

    $self->_send('R',$rcpt_to);

    my (@replies)=$self->_retrieve_responses();
    return (@replies);
} # end sub send_rcpt_to
############

############
sub send_quit {
# send a quit command, SMFIC_QUIT
# no response expected
# close the connection
    my $self=shift;

    if ($DEBUG==1) {print STDERR "send_quit\n";}

    $self->_send('Q');

    $self->{socket}->close;

} # end sub send_quit
############

############
sub _send {
# concerned with the details of sending stuff

    my $self = shift;
    my $command = shift;
    my (@data) = @_;

    if ($DEBUG==1) {print STDERR "send\n";}

    my $data = join '',@data;
    my $length = length($data);
    $length += 1;

    if ($DEBUG==1) {
	print STDERR "sending - command : $command\tlength : $length";
	if (length($data)<100) {print STDERR "\tdata : $data\n";}
	else {print STDERR "\n";}
    }

    $length = $self->_pack_number($length);

    if (!defined($self->{socket})) {carp "can't connect no connection defined !\n";}
   $self->_io_send($length);
   $self->_io_send($command);
   $self->_io_send($data) if (length($data) > 0);


} # end sub _send
############

############
sub _receive {
# concerned with the details of receiving stuff

    use IO::Select;

    my $self = shift;

    if ($DEBUG==1) {print STDERR "_receive\n";}

    my $length = $self->_io_recv(4);
    my $command = $self->_io_recv(1);
    $length = $self->_unpack_number($length);
    if ($DEBUG==1) {print STDERR "\tcommand : $command\n\tlength : $length\n";}
    $length -= 1;

    my $data;
    if ($length > 0) {
	$data = $self->_io_recv($length);
    }

    return ($command,$data);
} # end sub _receive
############

############
sub _pack_number {
# single place to pack numbers
    my $self = shift;
    my $number = shift;

    if ($DEBUG==1) {print STDERR "_pack_number\n";}

    my $ret_number =  pack "N",$number;

    return ($ret_number);
} # end sub _pack_number
############

############
sub _unpack_number {
# single place to unpack numbers
    my $self = shift;
    my $number = shift;

    if ($DEBUG==1) {print STDERR "_unpack_number\n";}

    my $ret_number =  unpack "N",$number;

    return ($ret_number);
} # end sub _unpack_number
############

############
sub _translate_response {
# turn what we get from the filter into something more manageable

    my $self = shift;
    my ($command,$data)=@_;

    if ($DEBUG==1) {
	print STDERR "_translate_response\n";
	print STDERR "\tcommand : $command\n";
	if (defined($data) && $command !~/[hm]/) {print STDERR "\tdata : $data\n";}
    }


    my %reply=();

    $reply{command}=$command;

    if ($command eq '+') {
	$reply{explanation}='Add a recipient';
	$reply{header}='To';
	$reply{action}='add';
	$reply{value}=$data;
    }

    elsif ($command eq '-') {
	$reply{explanation}='Remove a recipient';
	$reply{header}='To';
	$reply{action}='delete';
	$reply{value}=$data;
    }

    elsif ($command eq 'a') {
	$reply{explanation}='Accept message completely';
	$reply{action}='accept';
    }

    elsif ($command eq 'b') {
	$reply{explanation}='Replace body chunk';
	$reply{header}='body';
	$reply{action}='replace';
	$reply{value}=$data;
    }

    elsif ($command eq 'c') {
	$reply{explanation}='Accept and continue';
	$reply{action}='continue';
    }

    elsif ($command eq 'd') {
	$reply{explanation}='Reject message completely';
	$reply{action}='reject';
    }

    elsif ($command eq 'h') {
	$reply{explanation}='Add header';
	($reply{header},$reply{value},undef)=split(/\0/,$data);
	$reply{action}='add';
    }

    elsif ($command eq 'm') {
	$reply{explanation}='Replace body header';
	$reply{index}=$self->_unpack_number(substr($data,0,4));
	$data = substr($data,4);
	($reply{header},$reply{value},undef)=split(/\0/,$data);
	$reply{action}='replace';
    }

    elsif ($command eq 'p') {
	$reply{explanation}='Progress';
	$reply{action}='continue';
    }

    elsif ($command eq 'r') {
	$reply{explanation}='Reject command with 5xx error';
	$reply{action}='reject';
	$reply{value}=5;
    }

    elsif ($command eq 't') {
	$reply{explanation}='Reject command with 4xx error';
	$reply{action}='reject';
	$reply{value}=4;
    }

    elsif ($command eq 'y') {
	$reply{explanation}='Reject command with xxx error';
	$reply{action}='reject';
	$reply{value}=$data;
    }


    return (\%reply);
} # end sub _translate_response
############

############
sub _retrieve_responses {

    my $self = shift;

    my (@replies,$command,$data,$reply_ref);

    if ($DEBUG==1) {print STDERR "_retrieve_response\n";}

    while () {
	if ($DEBUG==1) {print STDERR "\twaiting for response\n";}
	($command,$data)=$self->_receive();
	($reply_ref)=$self->_translate_response($command,$data);

	push @replies,$reply_ref;

	if ($DEBUG==1) {print STDERR "\tcommand : $$reply_ref{command}";}
	if ($$reply_ref{command} eq 'c') {last;}
	elsif ($$reply_ref{command} eq 'a') {last;}
	elsif ($$reply_ref{command} eq 'r') {last;}
	elsif ($$reply_ref{command} eq 't') {last;}
	elsif ($$reply_ref{command} eq 'y') {last;}
	elsif ($$reply_ref{command} eq 'd') {last;}
    } # end while

    return (@replies);
} # end sub retrieve_responses
############

############
sub send_macros {
    my $self=shift;
    my %macros = @_;

    if ($DEBUG==1) {print STDERR "retrieve_response\n";}

    my (@data);

    if ($DEBUG==1) {
	foreach (keys(%macros)) {
	    print STDERR "\tmacro : $_ = $macros{$_}\n";
	}
    } # end if DEBUG

    if (defined($macros{j})) {push @data,'j'."\0".$macros{j}."\0";}
    if (defined($macros{_})) {push @data,'_'."\0",$macros{_}."\0";}
    if (defined($macros{'{daemon_name}'})) {push @data,'{daemon_name}'."\0".$macros{'{daemon_name}'}."\0";}
    if (defined($macros{'{if_name}'})) {push @data,'{if_name}'."\0".$macros{'{if_name}'}."\0";}
    if (defined($macros{'{if_addr}'})) {push @data,'{if_addr}'."\0".$macros{'{if_addr}'}."\0";}

    if (@data) {
	if ($DEBUG==1) {print STDERR "\tsending D,C\n";}
	$self->_send('D','C',@data);
    }

    @data=();
    if (defined($macros{'{tls_version}'})) {push @data,'{tls_version}'."\0".$macros{'{tls_version}'}."\0";}
    if (defined($macros{'{cipher}'})) {push @data,'{cipher}'."\0".$macros{'{cipher}'}."\0";}
    if (defined($macros{'{cipher_bits}'})) {push @data,'{cipher_bits}'."\0".$macros{'{cipher_bits}'}."\0";}
    if (defined($macros{'{cert_subject}'})) {push @data,'{cert_subject}'."\0".$macros{'{cert_subject}'}."\0";}
    if (defined($macros{'{cert_issuer}'})) {push @data,'{cert_issuer}'."\0".$macros{'{cert_issuer}'}."\0";}

    if (@data) {
	if ($DEBUG==1) {print STDERR "\tsending D,H\n";}
	$self->_send('D','H',@data);
    }



    @data=();
    if (defined($macros{i})) {push @data,'i'."\0".$macros{i}."\0";}
    if (defined($macros{'{auth_type}'})) {push @data,'{auth_type}'."\0".$macros{'{auth_type}'}."\0";}
    if (defined($macros{'{auth_authen}'})) {push @data,'{auth_authen}'."\0".$macros{'{auth_authen}'}."\0";}
    if (defined($macros{'{auth_ssf}'})) {push @data,'{auth_ssf}'."\0".$macros{'{auth_ssf}'}."\0";}
    if (defined($macros{'{auth_author}'})) {push @data,'{auth_author}'."\0".$macros{'{auth_author}'}."\0";}
    if (defined($macros{'{mail_mailer}'})) {push @data,'{mail_mailer}'."\0".$macros{'{mail_mailer}'}."\0";}
    if (defined($macros{'{mail_host}'})) {push @data,'{mail_host}'."\0".$macros{'{mail_host}'}."\0";}
    if (defined($macros{'{mail_addr}'})) {push @data,'{mail_addr}'."\0".$macros{'{mail_addr}'}."\0";}

    if (@data) {
	if ($DEBUG==1) {print STDERR "\tsending D,M\n";}
	$self->_send('D','M',@data);
    }


    @data=();
    if (defined($macros{'{rcpt_mailer}'})) {push @data,'{rcpt_mailer}'."\0".$macros{'{rcpt_mailer}'}."\0";}
    if (defined($macros{'{rcpt_host}'})) {push @data,'{rcpt_host}'."\0".$macros{'{rcpt_host}'}."\0";}
    if (defined($macros{'{rcpt_addr}'})) {push @data,'{rcpt_addr}'."\0".$macros{'{rcpt_addr}'}."\0";}

    if (@data) {
	if ($DEBUG==1) {print STDERR "\tsending D,R\n";}
	$self->_send('D','R',@data);
    }


# no response after sending macros
    return 1;

} # end sub send_macros
############

############
sub _io_send {
    my $self = shift;
    my ($data) = @_;

    my $must_send = length($data);
    my $did_send = 0;
    while ($did_send < $must_send) {
	my $len = $self->{socket}->send(substr($data, $did_send));
	if (defined($len)) {
	    $did_send += $len;
	}
	else {
	    carp "Error while writing to the socket: $!";
	}
    }

    return 1;
}
############

############
sub _io_recv {
    my $self = shift;
    my ($must_recv) = @_;

    my $did_recv = 0;
    my $data = "";
    while ($did_recv < $must_recv) {
	my $len = $self->{socket}->sysread($data, $must_recv-$did_recv, $did_recv);
	if (defined($len)) {
	    $did_recv += $len;
	}
	else {
	    carp "Error while reading from the socket: $!";
	}
    }

    return $data;
}
############

############
sub DESTROY {
    my $self = shift;
   if (defined($self->{socket})) {
 	   $self->{socket}->close;
    } # end if

} # end sub DESTROY
############

1;


__END__