File Coverage

blib/lib/Net/Server/POP3proxy.pm

Criterion	Covered	Total	%
statement	15	304	4.9
branch	0	158	0.0
condition	0	30	0.0
subroutine	5	30	16.6
pod	3	21	14.2
total	23	543	4.2

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__