Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

Net::Server::POP3::Skeleton

by bbfu (Curate)
on Apr 05, 2004 at 21:18 UTC ( #342754=sourcecode: print w/ replies, xml ) Need Help??

Category: Networking Code
Author/Contact Info bbfu - Cory Johns <bbfu_perlmonk@yahoo.com>
Description:

Moved from where I originally posted it (at Re: POP3/IMAP Server modules?), to be more organized and easier to find. Also updated slightly.

A skeleton POP3 server, based on Net::Server. Handles the connections, and parsing and validating the commands. Dispatches commands as method calls.

Note: This module does work on Win32, despite the tests for Net::Server failing/hanging. If you manually install Net::Server, it will work (mostly) fine (see the CAVEATS section of the POD).

package Net::Server::POP3::Skeleton;

=head1 NAME

Net::Server::POP3::Skeleton - A simple skeleton POP3 server

=head1 SYNOPSIS

  package MyServer;
  use base 'Net::Server::POP3::Skeleton';

  sub user {
    my $self = shift;
    my $name = shift;

    unless(defined $name) {
      $client->senderr("missing argument");
      return;
    }

    $self->set('username', $name);
    $self->sendok("username accepted, send password");
  }

  sub pass {
    my $self = shift;
    my $pass = shift;
    my $name = $self->get('username');

    # PASS not allowed before USER
    return $self->unknown() unless defined $name;

    return $self->senderr('invalid username or password')
      unless $Auth{$name} eq $pass;

    $self->state('TRANS');
    $self->sendok();
  }

  package main;

  $server = MyServer->new(
    greeting => "POP3 My server ready",
  );

  $server->run();

=head1 DESCRIPTION

This module implements a bare-bones skeleton POP3 server.  It is
intended as a base class.  You should inherit from this class
(which, in turn, inherits from
L<Net::Server::Fork|Net::Server::Fork>).  The only POP3 command
implemented by this module is the QUIT command.  All others
should be implemented by your code as methods.

The purpose of this module is for easily creating non-standard
POP3 servers in Perl.  If you want a normal POP3 server (ie, one
that simply serves emails from an MBOX or MailDirs file), you
would probably be better off using one of the pre-built, faster
C-based servers.  If, on the other hand, you want to create a
specialized POP3 server that, for instance, generates the content
of the messages dynamically based on data from a website, this
module is what you want.

=head1 OPTIONS

When C<use>ing this module, you can specify an import option of
C<nonFork>.  This will cause the module to inherit from
L<Net::Server|Net::Server> instead of
L<Net::Server::Fork|Net::Server::Fork>.  See L<CAVEATS> for more
information

=cut

use warnings;
use strict;

use 5.006;

our $EOL  = "\015\012";
our $EOLP = qr/(?:\015?\012|\012?\015)/;

our %Defaults = (
  # The docs for Net::Server say you can just put the options
  # in the top level of the hash, but that doesn't actually
  # work.  You have to put it in a hash ref under the 'server'
  # key.  Also, the port option must be an array ref, which
  # isn't mentioned either.
  server => {
    port     => [ 110 ],
    debug    => 0,
  },
  # We use the package name in consideration of
  # potential issues with inheritence later.
  (__PACKAGE__) => {
    serverdata => {
      timeout  => 60,
      transerr => 0,
      caperr   => 1,
      greeting => "POP3 Net::Server::POP3::Skeleton ready",
      goodbye  => "goodbye",
      AllowedCommands => {
        AUTHORIZATION => {
          user => undef,
          pass => undef,
          quit => undef,
        },
        TRANSACTION => {
          stat => undef,
          list => undef,
          retr => undef,
          dele => undef,
          noop => undef,
          rset => undef,
          top  => undef,
          uidl => undef,
          quit => undef,
        },
      },
    },
  },
);

our @ISA;
our $NonFork = 0;

use IO::Select;
use Net::Server;
use Carp;

sub import {
  my $module = shift;

  for my $opt (@_) {
    $NonFork = 1 if(lc($opt) eq 'nonfork');
  }
}

INIT {
  if($NonFork) {
    @ISA = ('Net::Server');
  } else {
    if($^O =~ /win32/i and $^V lt v5.8.0) {
      die <<"EOD";
You must have perl v5.8.0 to use the forking personality
of this module on a Win32 platform.  Please see the CAVEATS
section of the Net::Server::POP3::Skeleton documentation.
EOD
    }
    require Net::Server::Fork;
    @ISA = ('Net::Server::Fork');
  }
}

=head1 METHODS

=head2 new [OPTIONS]

Creates a new instance of the server.  This method can be inherited.

The following options are recognized:

=over 4

=item port

Port to listen on.  Defaults to 110.

=item greeting

Greeting to send clients when they connect.
Defaults to "POP3 Net::Server::POP3::Skeleton ready"

=item goodbye

Message sent to clients when they sign off.
Defaults to "goodbye"

=item debug

Server debug flag.  Set to enable logging of extra
information, and printing of some debug data to STDERR.
Defaults to 0.

=item timeout

Number of seconds to wait after receiving data from the
client before terminating the connection.  This option
is especially important when using the L<nonfork> option,
since a client who leaves the connection open prohibits
others from connecting.  Set to a false value to disable
timeout.  This uses C<alarm>.
Defaults to 60.

=item transerr

Transmit uncaught error messages to the client.
If this option is set, uncaught, fatal error messages
in the command handlers are passed along to the client.
Otherwise, a generic message is sent.
Defaults to 0.

Note that setting this option could present a security
risk, as debugging info might be given to a potential
attacker.  It is recommended to leave this option disabled.

=item caperr

Capture otherwise fatal errors in command handlers.
If this option is set, fatal errors in the command
handlers are caught so that they don't bring down
the server.  Otherwise, the program halts on an
uncaught error.
Defaults to 1.

=back

=cut
sub new {
  my $class = shift;
  my %opts  = @_;

  my %self = %{\%Defaults};

  my $self = bless \%self, $class;

  while(my ($key, $val) = each %opts) {
    if(defined $self->_get_server_data($key)) {
      $self->_set_server_data($key, $val);
    } else {
      $val = [$val] if $key eq 'port' or $key eq 'allow' or $key eq 'd
+eny';
      $self->{server}{$key} = $val;
    }
  }

  return $self;
}


=head2 process_request

Handles connections accepted by Net::Server.

Commands are read from the client and dispatched
appropriately (see L<"COMMANDS">) until either the
client disconnects, or C<$obj-E<gt>{hasquit}> becomes
true (usually set by the QUIT command).

This method should be considered internal and should
not be called (it will be called automatically by
L<Net::Server|Net::Server>).  You probably will not
ever need to overload this method.

=cut
sub process_request {
  my $self = shift;

  $self->state('CONNECT');
  if($self->can('connect')) {
    eval { $self->connect() };
    if(my $err = $@) {
      $self->log(0, $err);
      die($err) unless $self->_get_server_data('caperr');
    }
  }

  $self->state('AUTH');
  $self->sendok($self->_get_server_data('greeting'));

  $self->_set_server_data('hasquit', 0);

  my $select = IO::Select->new(\*STDIN);
  while(
      not $self->_get_server_data('hasquit')
      and $select->can_read($self->_get_server_data('timeout'))
      and defined(my $line = <STDIN>)
  ) {
    $line =~ s/$EOLP//;
    print STDERR "Received following command: `$line'\n"
      if $self->{server}{debug};
    my ($cmd, $args) = split /\s+/, $line, 2;
    $cmd = $self->_normalize_cmd_name($cmd);

    unless(exists
        $self->_get_server_data('AllowedCommands')->{$self->state()}{$
+cmd}
    ) {
      $self->unknown();
      next;
    }

    my $method = $self->can($cmd) || 'unimplemented';

    eval {
      $self->$method($args);
    };

    if(my $err = $@) {
      $self->log(0, $err);

      if($self->_get_server_data('transerr')) {
        $self->senderr($err);
      } else {
        $self->senderr("An error occured trying to execute `\U$cmd'");
      }

      die($err) unless $self->_get_server_data('caperr');
    }
  }

  unless($self->_get_server_data('hasquit')) {
    $self->senderr("Connection timed out");
  }

  $self->state('DISCONNECT');
  if($self->can('disconnect')) {
    eval { $self->disconnect() };
    if(my $err = $@) {
      $self->log(0, $err);
      die($err) unless $self->_get_server_data('caperr');
    }
  }
}

=head2 state [NEWSTATE]

Set or return the current server state.

To change the server's state, pass the new state
to this method.  States can be upper, lower, or mixed
case, and the AUTHORIZATION and TRANSACTION states
may be abbreviated as AUTH and TRANS, respectively.

The new (or current if no new state is passed) is returned.
The returned state is always the full state name, and is
always upper case.

See L<"STATES"> for more information.

=cut
sub state {
  my $self = shift;
  $self->_set_server_data('state', $self->_normalize_state_name(shift)
+) if @_;

  return $self->_get_server_data('state');
}

=head2 add_command STATE[[, STATE]...], COMMAND

Example:
  $server->add_command(state => 'auth', command => 'hello');

Add a new command to the server's list of allowed commands.

You must used named-argument notation (see example above),
and specify at B<least> one state, and B<one> command.
The command will then be allowed in all of the states given.

Neither the state nor command name are case-sensitive.

Note that all the standard POP3 commands are already in
the allowed commands list, so this method should only
be called to add new, non-standard commands.

=cut
sub add_command {
  my $self  = shift;
  my $class = ref $self || __PACKAGE__;

  croak "Odd number of arguments to $class->add_command()" if(@_ % 2);

  my @states;
  my $command;
  while(my ($key, $val) = splice @_, 0, 2) {
    if(lc($key) eq 'state') {
      push @states, $self->_normalize_state_name($val);
    } elsif(lc($key) eq 'command') {
      croak "Only one command allowed\n  per call to $class->add_comma
+nd()"
        if($command);
      $command = $self->_normalize_cmd_name($val);
    }
  }

  for my $state (@states) {
    $self->_get_server_data('AllowedCommands')->{$state}{$command} = u
+ndef
  }
}

=head2 sendok MSG

Send to the client a positive response including the
message passed to this method.  The response will be
of the form:

  +OK MSG

Where C<MSG> is the message passed.  The response
will automatically have the end-of-line added. B<Do not>
add any end-of-line characters.

=cut
sub sendok {
  my $self = shift;
  my $msg  = shift;

  if($self->{server}{debug}) {
    print STDERR "Sent response: `+OK $msg'\n";
  }

  print("+OK $msg$EOL");
}

=head2 senderr MSG

Send to the client a negative response including the
message passed to this method.  The response will be
of the form:

  -ERR MSG

Where C<MSG> is the message passed.  The response
will automatically have the end-of-line added. B<Do not>
add any end-of-line characters.

=cut
sub senderr {
  my $self = shift;
  my $msg  = shift;

  if($self->{server}{debug}) {
    print STDERR "Sent response: `-ERR $msg'\n";
  }

  print("-ERR $msg$EOL");
}

=head2 senddata MSG [DATA...]

Send to the client a positive response and some lines
of data (eg, a message list, or message body).

For example:

  chomp(@lines = <$msgfh>);
  $server->senddata('message follows', @lines);

Note that end-of-line characters will be added to each
line as it is sent, so they should be chomped.

=cut
sub senddata {
  my $self = shift;
  my $msg  = shift;

  $self->sendok($msg);
  $self->send(@_, '.');
}

=head2 send MSG

Send a raw message to the client.  You should almost
always use one of the other send- methods mentioned
above.  EOL's will be added to the end of each argument.

Note that, since STDIN and STDOUT are opened to the
client socket, you could just write directly to them instead.

=cut
sub send {
  my $self = shift;

  if($self->{server}{debug}) {
    print STDERR "Sent data: `$_'\n" for @_;
  }

  print("$_$EOL") for @_;
}

=head2 close_client

Flags the client connection to be closed.  This should be
called from your QUIT handler (assuming you don't use the
one provided).

=cut
sub close_client {
  shift()->_set_server_data('hasquit', 1);
}

=head2 set NAME DATA

Stores some arbitrary data in the server object.
The data can be accessed calling the L<get()|"get NAME"> method
with NAME later.

DATA should be a single scalar value (though it can be a reference).

Returns DATA.

=cut
sub set {
  my $self = shift;
  my $name = shift;
  my $data = shift;

  $self->{(__PACKAGE__)}{userdata}{$name} = $data;
}

=head2 get NAME

Retrieves data stored earlier via L<set()|"set NAME DATA">.

=cut
sub get {
  my $self = shift;
  my $name = shift;

  return $self->{(__PACKAGE__)}{userdata}{$name};
}

sub _set_server_data {
  my $self  = shift;
  my $class = ref($self) || __PACKAGE__;
  my $name  = shift;
  @_ || croak "Missing data to $class->_set_server_data()\n"
             ."  (Did you mean $class->_get_server_data()?)";
  my $data  = shift;

  $self->{(__PACKAGE__)}{serverdata}{$name} = $data;
}

sub _get_server_data {
  my $self = shift;
  my $name = shift;

  return $self->{(__PACKAGE__)}{serverdata}{$name};
}

sub _normalize_state_name {
  my $self  = shift;
  my $state = uc(shift);

  $state = 'AUTHORIZATION' if $state eq 'AUTH';
  $state = 'TRANSACTION'   if $state eq 'TRANS';

  return $state;
}

sub _normalize_cmd_name {
  my $self = shift;
  my $cmd  = lc(shift);
  return $cmd;
}


#***********  Default command handlers  ***********#

sub quit {
  my $self = shift;

  $self->sendok($self->_get_server_data('goodbye'));

  $self->state('UPDATE');
  eval { $self->commit(@_) if $self->can('commit') };

  $self->close_client();
}

sub unknown {
  my $self = shift;

  $self->senderr("unknown ".$self->state()." state command");
}

sub unimplemented {
  my $self = shift;

  $self->senderr("command unimplemented");
}

# Allow the module to be run directly for debugging
__PACKAGE__->new()->run() unless caller;
1;

=head1 STATES

The server has four possible states: CONNECT, AUTHORIZATION,
TRANSACTION, UPDATE, and DISCONNECT.

When a client connects to the server, it begins in the CONNECT
state.  C<$obj->E<gt>connect()> is called, if implemented, and
the state is then switched to AUTHENTICATION.  When the user is
authenticated, the state should then move into the TRANSACTION
state.

If the user enters the QUIT command, the server will move into
the UPDATE state and call C<$obj-E<gt>commit()>, which you should
implement (see L<"COMMANDS">).  In this state, any changes (such
as deleting a message) should be committed.  Note that this state
can be skipped if the client disconnects without entering the
QUIT command, in which case any changes should be rolled back
during the DISCONNECT state.

After the client has disconnected, the server moves into the
DISCONNECT state and calls C<$obj-E<gt>disconnect()>, which you
may implement.  This state can be entered either from the
UPDATE state, or directly from the AUTHENTICATION or TRANSACTION
states.  In this state, any changes that were not previously
committed should be rolled back.

=head1 COMMANDS

Each line read from the user is split into two parts at the
first group of whitespace encountered.  The first part is
the command name, and the possible second part is the
parameter to the command.  Any case is accepted in the
command names, though the parameters to the commands may be
case sensitive.

Before a command is dispatched, it is checked against a list
of allowed commands.  If the command is not in this list, an
error is returned to the client and the command is not
dispatched.  This is for security reasons, as the command
supplied by the user is used directly to dispatch the
command.

A command is dispatched by looking for the similarly named
(but lower case) method of the object.  For example, when
dispatching the USER command, the method called is
C<$obj-E<gt>user()>.

The QUIT command is already implemented by this package.  It
changes the state to UPDATE, calls C<$obj-E<gt>commit(@_)>,
and then flags the client's connection to be closed by
calling C<$obj-E<gt>close_client()>.  In almost all cases,
this implementation of QUIT should be sufficient.

=head1 CAVEATS

=over 4

=item *

There are some issues with L<Net::Server::Fork|Net::Server::Fork>
on Win32.  The tests for L<Net::Server|Net::Server> are not
designed to work under Win32, though L<Net::Server|Net::Server>
itself does.  You should be able to skip the tests and it should
work.  However, see the next caveat.

=item *

If you are on Win32 and you don't specify the C<nonFork> import
option to use the non-forking personality of
L<Net::Server|Net::Server>, this module requires perl 5.8.  This
is because of a bug in the fork emulation of perl 5.6.1 that
causes perl to crash when forking is used in conjunction with
sockets.

=item *

I have had some issues with the forking personality of this
module causing my programs to leak memory on Win32.  I believe
this has something to do with the way C<fork> is emulated on
Win32 using threads, but I have not looked into it exhaustively.

I recommend you test the forking personality for memory leaks
before deploying your program, and you may need to fall back to
the nonforking personality.

=back

=cut

Comment on Net::Server::POP3::Skeleton
Download Code
Re: Net::Server::POP3::Skeleton
by jonadab (Parson) on Apr 06, 2004 at 13:45 UTC

    Interesting. Your interface takes an almost entirely different approach from mine, except that both create an object with the new constructor and then start the server with a method call. (Maybe we were both influenced to that because of the way the Net::Server interface works.)


    ;$;=sub{$/};@;=map{my($a,$b)=($_,$;);$;=sub{$a.$b->()}} split//,".rekcah lreP rehtona tsuJ";$\=$;[-1]->();print

      Ah, duplication of effort. :) I guess I should've tried to get mine on CPAN when I wrote it, so it might've saved you some work. Though maybe not, since my module seems quite a bit more basic than yours, as it doesn't support any of the extensions and leaves a lot more up to the user to implement.

      I'm curious, though, why you insist that your module is alpha. What necessesary features does it still lack?

      And, yes, I went with the new/start model to stay close to Net::Server's style as, I assume, did you.

      bbfu
      Black flowers blossom
      Fearless on my breath

        Though maybe not, since my module seems quite a bit more basic than yours, as it doesn't support any of the extensions and leaves a lot more up to the user to implement.

        I'd probably have based my module on yours, if I'd found yours on the CPAN when I was looking. That might have influenced my interface. It might also be that I wouldn't have been inspired then to put mine on the CPAN, if yours was there already. Dunno. I don't think I'll take mine down now, though, since as you point out it implements more.

        I'm curious, though, why you insist that your module is alpha. What necessesary features does it still lack?

        It's alpha because it's less than three months old, and I'm pretty much the only person working on it (though I did get a one-line fix sent to me from a person using the code once already). It's mostly complete now, and I should probably graduate it to beta status one of these releases. There are features it still lacks. stopserver and restartserver methods are lacking, and when I get those working I'd like to augment the sample proxy with a control script to start and stop it. APOP is not supported yet. I still need to recheck RFC 1939 to make sure I've implemented every MUST. It has been reported that on some perls on some platforms $EOL needs to be changed to "\r\n" to work correctly, but that breaks it on Mandrake Linux (my development platform) and I still need to figure out how to automatically detect which way to go.

        There are useful things that can be done without any of these features, of course. Currently my development is focusing mostly on the sample scripts and testing, so I guess with the next release I could mark it beta.


        ;$;=sub{$/};@;=map{my($a,$b)=($_,$;);$;=sub{$a.$b->()}} split//,".rekcah lreP rehtona tsuJ";$\=$;[-1]->();print

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://342754]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (7)
As of 2014-12-20 23:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (99 votes), past polls