#!/usr/bin/perl -w -T
# -*- cperl -*-
package Net::Server::POP3;
use strict;

BEGIN {
	use Exporter ();
	use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION     = 0.01;
	@ISA         = qw (Exporter);
	#Give a hoot don't pollute, do not export more than needed by default
	@EXPORT      = qw (startserver);
	@EXPORT_OK   = qw ();
	%EXPORT_TAGS = ();
}

sub nop {return}; # Used as default for optional callbacks.

my %op;
sub startserver {
    %op = @_;
    my %serveropts; %serveropts = %{$op{serveropts}} if exists $op{serveropts};
    $op{port}         ||= 110;
    $op{servertype}   ||= 'Fork';
    $op{authenticate} ||= \&nop; # Always return false: nobody is authorized.
    $op{delete}       ||= \&nop;
    $op{connect}      ||= \&nop;
    $op{disconnect}   ||= \&nop;
    $op{welcome}      ||= "Welcome to my Test Server.  Some stuff does not work yet.";

    # exists $op{list} or die "The list callback is required.";
    # exists $op{retrieve} or die "The retrieve callback is required.";

    use Net::Server::Fork; # We want to fix this to use $op{servertype}
    push @ISA, "Net::Server::Fork";
    Net::Server::POP3->run(port => $op{port}, %serveropts);
}

sub boxsize {
  my $totalsize = 0;
  for (@messages) {
    if ($op{size}) {
      $totalsize += $op{size}->($_);
    } else {
      $totalsize += length($op{retrieve}->($_));
    }
  }
  return $totalsize;
}

sub process_request {
    my $self = shift;
    my @messages;

    $op{connect}->();
    eval {
      print "+OK $op{welcome}\r\n";

      local $SIG{ALRM} = sub { die "Timed Out!\n" };
      my $timeout = 90; # give the user 90 seconds to type a line
      # My reading of RFC1939 is that this shouldn't be less than
      # ten minutes (at least, between commands), but I'll fix
      # that up after I get things working.

      my $previous_alarm = alarm($timeout);
      my $state = 0; # 0 = not authenticated.  1 = authenticated.
      my %user; # Used to store username/password info.
      while (<STDIN>) {
        s/\r?\n$//;
        if ($state) {
          # We _are_ authenticated.  Let user do stuff.
          if (/^STAT/i) {
            print "+OK ".(scalar @messages)." ".boxsize()."\r\n";
          } elsif (/^VERSION/i) {
            print "+OK Net::Server::POP3 $VERSION\r\n";
          } else {
            print STDERR "Client said \"$_\" (which I do not understand in the transaction state)$/";
            print "-ERR That must be something I have not implemented yet.\r\n";
          }
        } else {
          # We're not authenticated yet.  Try to authenticate.
          if (/^QUIT/i) {
            print "+OK Bye, closing connection...\r\n";
            $op{disconnect}->();
            return 0;
          } elsif (/^VERSION/i) {
            print "+OK Net::Server::POP3 $VERSION\r\n";
          } elsif (/^USER\s*(\S*)/i) {
            $user{name} = $1;  delete $user{pass};
            print "+OK $user{name} knows where his towel is; use PASS to authenticate\r\n";
          } elsif (/^PASS\s*(.*?)$/i) {
            $user{pass} = $1;
            if ($user{name}) {
              if ($op{authenticate}->(@user{'name','pass'})) { # TODO:  also pass IP addy
                $state = 1;
                @messages = $op{list}->($user{name});
                print "+OK $user{name}'s maildrop has ".@messages." messages (".boxsize()." octets)\r\n";
              } else {
                delete $user{name};
                print "-ERR Unable to lock maildrop at this time with that auth info\r\n";
              }
            } else {
              print "-ERR You can only use PASS right after USER\r\n";
            }
          } elsif (/^APOP/) {
            print "-ERR APOP/MD5 authentication not yet implemented, try USER/PASS\r\n";
          }
          else {
            print STDERR "Client said \"$_\" (which I do not understand in the unauthenticated state)$/";
            print "-ERR That must be something I have not implemented yet, or you need to authenticate.\r\n";
          }
        }
        alarm($timeout);
      }
      alarm($previous_alarm);

    };

      if ($@=~/timed out/i) {
      print STDOUT "-ERR Timed Out.\r\n";
      return;
    }
}

########################################### main pod documentation begin ##

=head1 NAME

Net::Server::POP3 - The Server Side of the POP3 Protocol

=head1 SYNOPSIS

  use Net::Server::POP3;
  startserver(
    severopts    => %options,
    authenticate => \&auth,
    list         => \&list,
    retrieve     => \&retrieve,
    delete       => \&delete,
  );

=head1 DESCRIPTION

This is alpha code.  That means it needs work and doesn't yet implement
everything it should.  Don't use it unless you don't mind fixing up the
parts that you find need fixing up.

It is strongly recommended to run with Taint checking enabled.

Stub documentation for this module was created by ExtUtils::ModuleMaker.
It looks like the author of the extension was negligent enough
to leave the stub mostly unedited.

Blah blah blah.


=head1 USAGE

This module is designed to be the server/daemon itself and so to
handle all of the communication to/from the client(s).  The actual
details of obtaining, storing, and keeping track of messages are left
to other modules or to the user's own code.

The main routine is startserver(), which starts the server.  The
following named arguments may be passed to startserver().  All
callbacks should be passed as coderefs.

=over

=item port

The port to listen on.  110 is the default.

=item servertype

A type of server implemented by Net::Server (q.v.)  The default is
'Fork', which is suitable for installations with a small number of
users.

=item serveropts

A hashref containing extra named arguments to pass to Net::Server.
Particularly recommended for security reasons are user, group, and
chroot.  See the docs for Net::Server for more information.

=item connect

An optional callback that, if supplied, will be called when a client
connects.  This is the recommended place to allocate resources such as
a database connection handle.

=item disconnect

This optional callback, if supplied, is called when the client
disconnects.  If there is any cleanup to do, this is the place to do
it.  Note that message deletion is not handled here, but in the delete
callback.

=item authenticate

The authenticate callback is passed a username, password, and IP
address.  If the username and password are valid and the user is
allowed to connect from that address and authenticate by the USER/PASS
method, then the callback should try to get a changelock on the
mailbox and return true if successful; it must return false if any of
that fails.

=item apop

Optional callback for handling APOP auth.  If the user attempts APOP
auth and this callback exists, it will be passed the username, the
digest sent by the user, and the server greeting.  If the user's
digest is indeed the MD5 digest of the concatenation of the server
greeting and the shared secret for, that user, then the callback
should attempt to lock the mailbox and return true if successful;
otherwise, return false.

=item list

The list callback, given a valid, authenticated username, must return
a list of message-ids of available messages.

=item retrieve

The retrieve callback must accept a valid, authenticated username and
a message-id (from the list returned by the list callback) and must
return the message as a string.

=item delete

This callback gets called with a valid, authenticated username and a
message-id that the user/client has asked to delete.  (This only
happens in cases where the POP3 protocol says the message should be
deleted.  If the connection terminates abnormally before entering the
UPDATE state, the callback is not called.)  It can do whatever it
wants, such as mark the message as deleted, actually delete it, mark
it as no longer to be given to this specific user, or whatever.

=back

=head1 BUGS

At this time, servertype is ignored, and Net::Server::Fork is always used.

=head1 SUPPORT



=head1 AUTHOR

	Jonadab the Unsightly One (Nathan Eady)
	jonadab@bright.net
	http://www.bright.net/~jonadab/

=head1 COPYRIGHT

This program is free software licensed under the terms of...

	The BSD License

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

perl(1).
Net::Server(1).

=cut

############################################# main pod documentation end ##


################################################ subroutine header begin ##

=head2 sample_function

 Usage     : How to use this function/method
 Purpose   : What it does
 Returns   : What it returns
 Argument  : What it wants to know
 Throws    : Exceptions and other anomolies
 Comments  : This is a sample subroutine header.
           : It is polite to include more pod and fewer comments.

See Also   : 

=cut

################################################## subroutine header end ##

# The following was inserted by ExtUtils::ModuleMaker, but I am not using
# it because this module is basically one big function and therefore does
# not present an object interface.  I keep the new sub definition here
# in comment in case I should want it later, if I change my mind about
# presenting an object interface.
#sub new
#{
#	my ($class, %parameters) = @_;
#
#	my $self = bless ({}, ref ($class) || $class);
#
#	return ($self);
#}


42; #this line is important and will help the module return a true value
__END__

