Net::Server::POP3proxy - POP3 Proxy class for working with virus scanners and anti-spam software


Net-Server-POP3proxy documentation Contained in the Net-Server-POP3proxy distribution.

Index


Code Index:

NAME

Top

Net::Server::POP3proxy - POP3 Proxy class for working with virus scanners and anti-spam software

SYNOPSIS

Top

    use Net::Server::POP3proxy;

    # Constructors
    $popproxy = new Net::Server::POP3proxy(
        Action => sub { filterAction ($_[0]); },
        Error  => sub { die ($_[0]); },
        Debug  => sub { print STDERR ($_[0]); }
    ) or die ("Cannot init POP3 proxy server");

    while ($popproxy->looper()) {
        # noop
    }

DESCRIPTION

Top

This module implements a POP3 proxy server to enable you to call user defined actions uppon fetching a mail from the POP3 Server.

The destination server is taken from the username, the client connects to the pop3 proxy in the way remoteuser%remote.host:port.

Multiple clients can connect to the POP proxy at a time.

CONSTRUCTOR

Top

new ( [ Port => [port] ], [ Action => [sub] ], [ Error => [sub] ], [ Debug => [sub] ], [ MaxSize => [maximumsize] ] )

This is the constructor for a new Net::POP3proxy object. No paramater is required.

Port is the TCP port the proxy listens on the local machine interface. The default port is 110.

MaxSize is the maximum message size im bytes, the action is called. E.g. no junk can be greater than 512k or much less! The default is 0 which means all messages are filtered.

Action is an anonymous function which is called, if a message arrives. It must return the message or the modified message. We use a normal scalar value for this, though we had problems with memory leaks using references under Windows. The default is to do nothing.

Error is an anonymous function which is called, if an error occures. It is assumed, that this function does stop the execution immediate. So use a die or so here. The parameter is the error message. The default is to do a die.

Debug is an anonymous function which is called, if a debug message occures. It is assumed, that this function does NOT stop the execution immediate. The default is to print the message.

METHODS

Top

The concept is to do a loop. So we only descript the looping function and the cleanup functions.

looper ( )

Waits for connections and handles actions and errors.

cleanup ( [ FORCE ] )

Closes all sockets. If FORCE is ommitted or 0 only sockets containing with no waiting data are closed. If FORCE is 1 then all is closed. For example in case of no fatal error you can end by doing this:

        $popproxy->cleanup();

        # run last buffers - with a grace of 50
        # communications for the rest buffer

        my $gracecounter = 50;
        while ($popproxy->looper() && $gracecounter ) { $gracecounter--; }

        $popproxy->cleanup(1);    

POP3 commands

Top

For you to understand, we try to give an example of a POP3 communication with the proxy:

    telnet localhost 110
    +OK welcome to perl pop3 proxy
    USER test@mail.test.it

    ... connection is created to mail.test.it port 110

    +OK

    ... now communication is done with mail.test.it

Using other ports:

    telnet localhost 110
    +OK welcome to perl pop3 proxy
    USER test@mail.test.it:1110

    ... connection is created to mail.test.it port 1110

    +OK

    ... now communication is done with mail.test.it

Special shutdown command

    telnet localhost 110
    +OK welcome to perl pop3 proxy
    shutdown

    ... looper returns false and all sockets are closed

NOTES

Top

We work a lot with destroys and try to undefine a lot of data. This is because this was designed to work as a Windows Service using PerlSVC from ActiveState. So dont be confused if you read the code.

POP3 connections are done by socket communication.

This was only tested on Windows till now.

AUTHOR

Top

Martin Boeck <martin.boeck@comnex.net>

COPYRIGHT

Top


Net-Server-POP3proxy documentation Contained in the Net-Server-POP3proxy distribution.

package Net::Server::POP3proxy;

use strict;
use vars qw($VERSION);
$VERSION = '0.1';

use POSIX;
use IO::Socket;
use IO::Select;

# Constructor
# Parameters: Port, Error, Debug, Action
sub new {
    # no need to check subclassing ... not public
    my $proto = shift;

    # generate a clear hash for holding data
    my $self = {
        # default parameters
        Port    =>          110,
        Error   =>          sub { die ($_[0]); },
        Debug   =>          sub { print gmtime() . ": " . $_[0] . "\n"; },
        Action  =>          sub { },
        MaxSize =>          0,
        @_,

        # interal structures
        write_buffer        => {},
        read_buffer         => {},
        write_sockets       => new IO::Select,
        read_sockets        => new IO::Select,
        listening_socket    => undef,
        client_peers        => {},
        server_peers        => {},
        waiting_user        => {},
        reading_multiline   => {},
        snarfing            => {},
        command_queue       => {},
        write_disconnect    => {},       
    };

    # initialize class
    my $class = ref($proto) || $proto;
    $self = bless( $self, $class );

    # init the listening socket
    $self->init();

    $self;
}

# init the listening socket
sub init {
    my ($self) = shift;
    # create listening socket     
    $self->{listening_socket} = IO::Socket::INET->new(LocalPort => $self->{Port}, Listen => 5, Reuse => 1, Timeout => 5);
    $self->error("Cannot create socket: $!") unless $self->{listening_socket};
    
    $self->debug("Created listening socket on port " . $self->{Port});
    
    # add it to readable sockets
    $self->{read_sockets}->add($self->{listening_socket});    
}

sub canrecycle {
    my $self = shift;
    
    if ($self->{read_sockets}->count() <= 1 && $self->{write_sockets}->count() == 0) {
        return 1;
    } else {
        return 0;
    }
}

# this should be called in a while (1) loop to work through sockets
# main dispatcher
sub looper {
    my $self = shift;

    return 0 unless ($self->{read_sockets}->count() || $self->{write_sockets}->count());    
        
    # find out sockets to read and to write to
    my ($toread, $towrite) = IO::Select->select($self->{read_sockets}, $self->{write_sockets},undef, 5);    
    
    # first work on read sockets
    foreach my $socket ( @$toread ) {
        # check which type of socket we are working on:
        if ($socket == $self->{listening_socket}) {
            # initial communication
            $self->minipop3_connect($socket);
        } else {
            # followup connection
            if (defined $self->{client_peers}->{$socket}) {
                # its a client which already has a server assotiated
                $self->proxypop3_client2server($socket);
            } elsif (defined $self->{server_peers}->{$socket}) {
                # its a server communicating with the client              
                $self->proxypop3_server2client($socket);
            } else {
                # its a client communicating with minipop3
                $self->minipop3_client2server($socket);
            }
        }
        
        # cleanup        
        unless ($socket && $socket->connected()) {
            undef $socket;
        }
    }
    
    # next work on write sockets
    foreach my $socket ( @$towrite ) {
        # check if write buffer waits for something
        if ($self->{write_buffer}->{$socket}) {
            $self->write2socket($socket);
        }

        # cleanup        
        unless ($socket && $socket->connected()) {
            undef $socket;
        }
    }

    # cleanup
    undef $toread; undef $towrite;

    1;
}

# Basic write to socket function. Writes waiting data to a writing socket. 
sub write2socket {
    my ($self, $socket) = @_;
    
    return unless $self->{write_buffer}->{$socket};
    
    # write to socket
    my $wrote = syswrite($socket, $self->{write_buffer}->{$socket}, length($self->{write_buffer}->{$socket})) or do {
        # write failed
        $self->debug("write to " . $socket->peerhost() . " failed");
        
        # clear writing buffer on socket
        $self->{write_buffer}->{$socket} = "";
        
        # disconnect all assotiated stuff
        if (defined $self->{client_peers}->{$socket}) {
            # its a port of a client - so the client disconnects        
            $self->client_disconnect($socket);
        } elsif (defined $self->{server_peers}->{$socket}) {
            # its a port of a server - so a server is not reachable any more
            $self->server_disconnect($socket);
        } else {
            # no assosiated port so only mini disconnect
            $self->minipop3_quit($socket);
        }
    };
    
    # after a write - we have to flush the buffer (only if writte is buffer size)
    substr($self->{write_buffer}->{$socket},0,$wrote,"");    
    if (length ($self->{write_buffer}->{$socket}) == 0) {
        $self->{write_sockets}->remove($socket);

        undef $self->{write_buffer}->{$socket};

        # implicit disconnect after last write    
        if ($self->{write_disconnect}->{$socket}) {
            $self->debug("executing pending disconnect for " . $socket->peerhost() . ".");
            
            if (defined $self->{client_peers}->{$socket}) {
                # a client port - client disconnect                
                $self->client_disconnect($socket);
            } elsif (defined $self->{server_peers}->{$socket}) {
                # a server port - so server disconnect
                $self->server_disconnect($socket);
            } else {
                $self->minipop3_quit($socket);
            }
        }
        
    }
}

# Connection from a client to our proxy
sub minipop3_connect {
    my ($self, $socket) = @_;
    
    # accept socket
    my $new_sock = $socket->accept;
    $self->{read_sockets}->add($new_sock) if $new_sock;
    $self->error("Cannot accept new connection from client") unless $new_sock;

    $self->debug("Connection accepted from " . $new_sock->peerhost() . ".");

    # fill data
    $self->{write_buffer}->{$new_sock} = undef; $self->{read_buffer}->{$new_sock} = undef;
    $self->{write_disconnect}->{$new_sock} = 0;
    
    # write mini pop3 welcome
    $self->preparewrite($new_sock,"+OK welcome to maxbounce pop3 proxy\x0D\x0A");
}

sub minipop3_client2server {
    my ($self, $socket) = @_;
    
    $self->debug("Receiving data from client -> proxy server");
    
    # get read data    
    $self->doread($socket) or $self->minipop3_quit($socket);

    # check if buffer is enough to run action
    $self->minipop3_action($socket);  
}

sub minipop3_action {
    my ($self, $socket) = @_;
    
    return unless $self->{read_buffer}->{$socket};    
    
    if ($self->{read_buffer}->{$socket} =~ /\x0D\x0A?$/s) {
        my @workbuffer = split (/\x0D\x0A?/,$self->{read_buffer}->{$socket});
        undef $self->{read_buffer}->{$socket};

        # only an "enter"
        if (@workbuffer == 0) {
            $self->debug("client sent only empty line");
            $self->preparewrite($socket,"-ERR empty command\x0D\x0A");
        }
        
        # work the lines
        foreach my $line ( @workbuffer ) {
            # hanging x0A
            $line =~ s/^\x0A//;

            if ($line =~ /^USER\s+([^\%]+)\%(.+)$/i) {
                my ($remoteuser, $remotehost) = ($1,$2);
                $self->debug("Got USER command from client: pop3 host $remotehost, username $remoteuser");            
        
                # append port 110 if not included
                if ($remotehost !~ /:\d+$/) {
                    $remotehost .= ":110";
                }
        
                # open up a new socket to a pop server
                my $remote = IO::Socket::INET->new(PeerAddr => $remotehost);
                unless ($remote) {
                    # no connection possible
                    $self->debug("No connection to $remotehost");
                    $self->preparewrite($socket,"-ERR $remotehost is not reachable\x0D\x0A");
                } else {
                    $self->debug("Connection to $remotehost ok");
                    
                     
                    # fill up datas
                    $self->{read_sockets}->add($remote);
                    $self->{client_peers}->{$socket} = $remote;
                    $self->{server_peers}->{$remote} = $socket;
                    $self->{waiting_user}->{$remote} = $remoteuser;
                    $self->{write_buffer}->{$remote} = undef; $self->{read_buffer}->{$remote} = undef;
                    $self->{reading_multiline}->{$remote} = 0; $self->{snarfing}->{$remote} = 0;
                    $self->{command_queue}->{$socket} = [];
                    $self->{write_disconnect}->{$remote} = 0;
                }
            } elsif ($line =~ /^QUIT/i) {
                # quit request
                $self->debug("Proxy client issues QUIT");                
                $self->minipop3_quit($socket);
            } elsif ($line =~ /^SHUTDOWN/i) {
                # shutdown all
                $self->cleanup();
            } else {
                # wrong command
                $self->debug("Proxy client issues wrong command");
                $self->preparewrite($socket,"-ERR waiting for USER\x0D\x0A");
            }
        }
        
        undef @workbuffer;
    } else {
        $self->debug('... waiting for EOL');
    }
}

# close connection in minipop3 mode (not so ugly)
sub minipop3_quit {
    my ($self,$socket) = @_;
    
    $self->debug("Connection to " . $socket->peerhost() . " closed (minipop3).");
    $self->socketclose($socket);
}

# communication from a client to a server / Command checkup and catcher
sub proxypop3_client2server {
    my ($self,$socket) = @_;

    $self->debug("Receiving data from client -> pop server");
  
    $self->doread($socket) or $self->client_disconnect($socket);
    
    $self->proxypop3_client_action($socket);
}

# a client socket dies or needs to be disconnected
sub client_disconnect {
    my ($self,$socket) = @_;

    # is a server port assosiated ?    
    if (defined $self->{client_peers}->{$socket}) {
        # is data pending ?
        if ($self->{write_buffer}->{$self->{client_peers}->{$socket}}) {
            $self->debug("Initiating clients assosiated server disconnect after next write");
            $self->{write_disconnect}->{$self->{client_peers}->{$socket}} = 1;
        } else {
            $self->debug("Initiating clients assosiated server disconnect immediate");          

            $self->socketclose($self->{client_peers}->{$socket});
        }
    }
    
    $self->debug("Disconnecting client connection to " . $socket->peerhost() . ".");
    $self->socketclose($socket);
}

# handle read data from client and make command checkup
sub proxypop3_client_action {
    my ($self, $socket) = @_;
    
    # no action needed
    return unless $self->{read_buffer}->{$socket};
    
    # check if empty line
    if ($self->{read_buffer}->{$socket} =~ /\x0D\x0A?$/s) {
        my @workbuffer = split (/\x0D\x0A?/,$self->{read_buffer}->{$socket});
        $self->{read_buffer}->{$socket} = "";

        # empty line
        if (@workbuffer == 0) {
            $self->debug("Empty client command");            
            $self->preparewrite($socket,"-ERR empty command");
        } else {
            # only interested in one line command            
            my $line = $workbuffer[0];
            
            # hanging x0A
            $line =~ s/^\x0A//;
 
            # the plain command
            my ($command) = $line =~ /^(\S+)/;
            
            # disable AUTH requests
            if ($command and $command =~ /^AUTH$/i) {
                $self->preparewrite($socket,"-ERR Auth disabled\x0D\x0A");
                return;        
            }

            # we are in proxy mode already, do not retry authentication!
            if ($command and $command =~ /^USER/i) {
                $self->preparewrite($socket,"-ERR Only one authentication can be done. Please restart\x0D\x0A");
                return;            
            }
            
            # push command to stack
            push (@{$self->{command_queue}->{$self->{client_peers}->{$socket}}}, $command) if $command;
            
            $self->debug("Client issues command '$command'.");
            $self->preparewrite($self->{client_peers}->{$socket},"$line\x0D\x0A");
        }
    } else {
        # new line missing     
        $self->debug('Client communication needs a newline to finish');
    }
}

# a server is communicating with the client
sub proxypop3_server2client {
    my ($self,$socket) = @_;
    
    $self->debug("Receiving data from pop server -> client");
    
    $self->doread($socket) or $self->server_disconnect($socket);
    
    $self->proxypop3_server_action($socket); 
}

# all stuff if a server port disconnects
sub server_disconnect {
    my ($self,$socket) = @_;
    
    # is a client assosiated with this communication
    if (defined $self->{server_peers}->{$socket}) {
        if ($self->{write_buffer}->{$self->{server_peers}->{$socket}}) {
            $self->debug("Initiating server assosiated client disconnect after next write");
            $self->{write_disconnect}->{$self->{server_peers}->{$socket}}=1;
        } else {
            $self->debug("Initiating server assosiated client disconnect immediate");          

            $self->socketclose($self->{server_peers}->{$socket});
        }
    }
    
    $self->debug("Disconnecting server connection to " . $socket->peerhost() . ".");
    $self->socketclose($socket);
}

# work the server answers to see whats up in the mailbox and to catch mails
sub proxypop3_server_action {
    my ($self, $socket) = @_;

    return unless ($self->{read_buffer}->{$socket});

    # is it a full answer?    
    if ($self->{read_buffer}->{$socket} =~ /\x0D\x0A?$/s) {
        # split buffer
        my @workbuffer = split (/\x0D\x0A?/,$self->{read_buffer}->{$socket});
        # discard buffer        
        undef $self->{read_buffer}->{$socket};
            
        foreach my $line ( @workbuffer ) {
            # hanging x0A
            $line =~ s/^\x0A//;
            
            # response is a status reply and no multiline response            
            if (($line =~ /^(\+OK|-ERR)/i) && (! $self->{reading_multiline}->{$socket})) {
                $self->debug("command response");

                # do we need to make a silent connect to the server?            
                if ($self->{waiting_user}->{$socket}) {
                    # first hello
                    $self->debug("Remote server alive, trying authenticate with user " . $self->{waiting_user}->{$socket} . ".");
                    $self->preparewrite($socket,"USER " . $self->{waiting_user}->{$socket} . "\x0D\x0A");

                    undef $self->{waiting_user}->{$socket}; delete $self->{waiting_user}->{$socket};

                    # no interest in going on server replies 
                    last; 
                }
                
                 # Response to a command (hopefully!)
                my $command = shift @{$self->{command_queue}->{$socket}};
            
                # santity check
                if ($self->{snarfing}->{$socket}) {
                    $self->error("Sanity: multiline not ready - error in snarfing");
                }

                # positiv answer                
                if ((substr ($line, 0, 1) eq '+') && (defined $command)) {
                    # command TOP                    
                    if ($command =~ /^TOP$/i) {
                        $self->{snarfing}->{$socket} = 1;
                        next;
                    }
	  
                    # Command RETR (reply with original Status)
                    if ($command =~ /RETR/i) {
                        $self->{snarfing}->{$socket} = 2;
                        $self->preparewrite($self->{server_peers}->{$socket}, "+OK filtered message follows\x0D\x0A");
                        next;
                    }

                    # Command CAPA (reply with original Status=
                    if ($command =~ /CAPA/i) {
                        $self->{snarfing}->{$socket} = 3;
                        $self->preparewrite($self->{server_peers}->{$socket}, "$line\x0D\x0A");
                        next;
                    }
                 }
            } elsif ($line =~ /^\.$/) {
                $self->debug("end ML");
                # End of a multiline response

                $self->{reading_multiline}->{$socket} = 0;

                # we just catch a message
                if ($self->{snarfing}->{$socket}) {
                
                    # a RETR Request                    
                    if ($self->{snarfing}->{$socket} == 2) {
                        if (! defined ($self->{message}->{$socket})) {
                            $self->{message}->{$socket} = '';
                        }
                         
                        if (($self->{MaxSize} == 0) || (length ($self->{message}->{$socket}) < $self->{MaxSize})) {
                            $self->{message}->{$socket} = $self->{Action}($self->{message}->{$socket});
                        } else {
                            $self->debug("Message not filtered - too big");
                        }
                        
                        $self->debug("Returning RETR command / applying filter");
            
                        $self->preparewrite($self->{server_peers}->{$socket},$self->{message}->{$socket});
                    # TOP Command will be dropped ( problem because we modify messages )                    
                    } elsif ($self->{snarfing}->{$socket} == 1) {
                        $self->{message}->{$socket} = ''; $self->{snarfing}->{$socket} = 0;
                        
                        $self->debug("Discard TOP command reply");                        
                        $self->preparewrite($self->{server_peers}->{$socket},"-ERR no TOP allowed\x0D\x0A");
                        next;
                    # CAPA Reply
                    } elsif ($self->{snarfing}->{$socket} == 3) {
                        # Strips out the TOP response, if any.
                        $self->{message}->{$socket} =~ s/TOP\x0D\x0A//sig;
                        # Strips out the SASL response, if any.
                        $self->{message}->{$socket} =~ s/SASL\x0D\x0A//sig;
                        
                        $self->debug("Return modified CAPA reply");
                        $self->preparewrite($self->{server_peers}->{$socket},$self->{message}->{$socket});
                    } else {
                        $self->error("Sanity: Another Snarfing Action code");
                    }                
                    
                    # discard snarfing and message
                    undef $self->{message}->{$socket}; delete $self->{message}->{$socket};
                    $self->{snarfing}->{$socket} = 0;
                }
            } else {
                # $self->debug("ML");

                # it must be a multiline
                $self->{reading_multiline}->{$socket} = 1;
            }
    
            # if in multiline snarfing - store message
            if ($self->{snarfing}->{$socket}) {
                $self->{message}->{$socket} .= $line . "\x0D\x0A";
            } else {
                # pipeline it to the client
                $self->preparewrite($self->{server_peers}->{$socket}, "$line\x0D\x0A");
            }        
        }
        # free workbuffer
        undef @workbuffer;
    } else {
        # new line missing     
        $self->debug('Server communication needs a newline to finish');
    }
}

# Cleanup means to kill all existing ports
sub cleanup {
    my ($self, $force) = shift;
    
    if ($force) {
        $self->debug("Forced shutdown");
    }
    
    # gather all sockets    
    my @allwrite = $self->{write_sockets}->handles;
        
    # begin with the writing ones
    foreach my $socket ( @allwrite ) {
        unless ($force) {
            if (defined $self->{client_peers}->{$socket}) {
                $self->client_disconnect($socket);
            } elsif (defined $self->{server_peers}->{$socket}) {
                $self->server_disconnect($socket);
            } else {
                $self->minipop3_quit($socket);
            }
        } else {
            $self->socketclose($socket);            
        }
    }        

    # Read sockets
    my @allread = $self->{read_sockets}->handles;

    # now go to the reading ones
    foreach my $socket ( @allread ) {
        unless ($force) {        
            if (defined $self->{client_peers}->{$socket}) {
                $self->client_disconnect($socket);
            } elsif (defined $self->{server_peers}->{$socket}) {
                $self->server_disconnect($socket);
            } elsif ($socket == $self->{listening_socket}) {
                $self->debug("Closing listening socket");            
                $self->socketclose($socket);            
            } else {
                $self->minipop3_quit($socket);
            }
        } else {
            $self->socketclose($socket);            
        }
    }        
}

# put a write in the queue and enable writing
sub preparewrite {
    my ($self,$socket,$message) = @_;
    
    if (ref($message) eq "SCALAR") {
        $self->{write_buffer}->{$socket} .= $$message;
    } else {
        $self->{write_buffer}->{$socket} .= $message;
    }
    $self->{write_sockets}->add($socket) unless $self->{write_sockets}->exists($socket);
}

# get a block for reading 
sub doread {
    my ($self, $socket) = @_;
    
    $self->{read_buffer}->{$socket} = '' unless ($self->{read_buffer}->{$socket});
    return sysread($socket, $self->{read_buffer}->{$socket}, 4096, length($self->{read_buffer}->{$socket}));
}

# debugging
sub debug {
    my ($self, $msg) = @_;
    $self->{Debug}($msg);
}

# error
sub error {
    my ($self, $msg) = @_;
    
    $self->cleanup();
    $self->{Error}($msg);
}

# Sub will clean all data assosiated with a socket
sub socketclose {
    my ($self, $socket) = @_;

    return unless $socket;

    $self->{read_sockets}->remove($socket); $self->{write_sockets}->remove($socket);
    
    # clean all assosiated hashes
    do { undef $self->{server_peers}->{$socket}; delete $self->{server_peers}->{$socket} } if (exists $self->{server_peers}->{$socket});
    do { undef $self->{client_peers}->{$socket}; delete $self->{client_peers}->{$socket} } if (exists $self->{client_peers}->{$socket});
    do { undef $self->{read_buffer}->{$socket}; delete $self->{read_buffer}->{$socket} } if (exists $self->{read_buffer}->{$socket});
    do { undef $self->{write_buffer}->{$socket}; delete $self->{write_buffer}->{$socket} } if (exists $self->{write_buffer}->{$socket});
    do { undef $self->{reading_multiline}->{$socket}; delete $self->{reading_multiline}->{$socket} }  if (exists $self->{reading_multiline}->{$socket});
    do { undef $self->{command_queue}->{$socket}; delete $self->{command_queue}->{$socket} } if (exists $self->{command_queue}->{$socket});
    do { undef $self->{write_disconnect}->{$socket}; delete $self->{write_disconnect}->{$socket} } if (exists $self->{write_disconnect}->{$socket});
    do { undef $self->{snarfing}->{$socket}; delete $self->{snarfing}->{$socket}} if (exists $self->{snarfing}->{$socket});
    do { undef $self->{message}->{$socket}; delete $self->{message}->{$socket} } if (exists $self->{message}->{$socket});
    
    # close socket
    $socket->shutdown(2);
    $socket->close() if ($socket);
}

sub DESTROY {
    my $self = shift;
    
    $self->debug("Destroy");
    $self->cleanup(1);
}

# a positiv result - we are polite!
1;

__END__