# $Revision: 1.4 $
# $Date: 2003/03/05 09:29:12 $
package Net::IMAP::Server;

use strict;
use warnings;

use Unicode::IMAPUtf7;
use Tie::Persistent;
use IO::Socket::INET;

our $debug		= 0;
our $DELIMITER	= '>';

################################################################################

sub new {
	my $proto	= shift;
	my $class	= ref($proto) || $proto;
	
	my $store	= shift;
	my $port	= shift;
	my $sock = IO::Socket::INET->new(
			Listen		=> 5,
			LocalAddr	=> 'localhost',
			LocalPort	=> $port || 1143,
			Proto		=> 'tcp',
			ReusePort	=> 1,
			ReuseAddr	=> 1
		) or die "Cannot open socket on port $port: $!";
	
	my %data;
	tie %data, 'Tie::Persistent', '/tmp/imap.db', 'rw';
	(tied %data)->autosync(1);
	
	my $self	= bless(
		{
			sock	=> $sock,
			data	=> \%data
		},
		$class
	);
	
	$self->{ 'store' }	= $store->new( $self );
	return $self;
}

sub DESTROY {
	my $self	= shift;
	untie (%{ $self->data });
	$self->{ 'store' }	= undef;
}

sub run {
	my $self	= shift;
	my @pids;
	warn "running...\n";
	while (my $client = $self->sock->accept()) {
		# THE poor man's forking server. Currently, nothing is done with the
		# list of the server's children processes... I suppose we could try
		# to limit the number of them or something...
		if (my $pid = fork) {
			push(@pids, $pid);
		} else {
			print "[$$] >> new clinet\n";
			
			$self->{ 'client' }	= $client;
			$self->send( '* OK mangalavid-imap ready' );
			while (my $line = <$client>) {
				warn "[$$] C: $line" if ($debug);
				$line	=~ s/\r\n$//;
				my ($tag,$command,$args)	= split(/ /, $line, 3);
				
				$self->{ 'tag' }	= $tag;
				$command	= "cmd_" . lc($command);
				$self->$command( Unicode::IMAPUtf7::imap_utf7_decode($args) );
				
				(tied %{ $self->data })->sync();
				if ($command eq 'cmd_logout') {
					delete $self->{ 'client' };
				}
			}
			delete $self->{ _user };
			exit;
		}
	}
}

################################################################################


sub cmd_capability {
	my $self	= shift;
	my $args	= shift;
	$self->send( '* CAPABILITY IMAP4rev1' );
	$self->send_ok( 'CAPABILITY completed' );
}

sub cmd_close {
	my $self	= shift;
	my $args	= shift;
	$self->send_ok( 'CLOSE completed' );
}

sub cmd_copy {
	my $self	= shift;
	my $args	= shift;
	$self->send_no( 'Not implemented' );
}

sub cmd_create {
	my $self	= shift;
	my $args	= shift;
	if ($args =~ m{(http:.*)$}) {
		my $url	= $1;
		$url	=~ s{$DELIMITER}{/}g;
		$url	=~ s{^http:/+}{http://};
		$url	=~ s{&AH4-}{~}g;
		if ($self->store->subscribe( $url )) {
			$self->send_ok( 'CREATE completed' );
		} else {
			$self->send_no( 'Something went wrong.' );
		}
	} else {
		$self->send_no( "Doesn't look like a feed URL. Try http://.../" );
	}
}

sub cmd_delete {
	my $self	= shift;
	my $args	= shift;
	$self->send_ok( 'DELETE completed' );
}

sub cmd_fetch {
	my $self	= shift;
	my $args	= shift;
	my ($num, $fields)	= split(/ /, $args, 2);
	my ($from, $to)		= (index($num,':') >= 0) ? split(/:/, $num) : ($num,$num);
	
	my @fields;
	my $header_list	= '';
	
	my $fieldlist	= ($fields =~ m{^\((.*)\)}) ? $1 : $fields;
	my $header		= 0;
	for ($fieldlist) {
		push(@fields, $1) if /(ENVELOPE)/;
		push(@fields, $1) if /(FLAGS)/;
		push(@fields, $1) if /(INTERNALDATE)/;
		push(@fields, 'UID') if (/(UID)/ or $self->{ _by_uid });
#			push(@fields, $1) if /(BODY(?:STRUCTURE)?)(?!\[)/;
		push(@fields, $1) if /(RFC822(?:\.(HEADER|SIZE|TEXT))?)/;
		if (/(BODY)(?:\.(PEEK))?\s*\[(.*)\]/) {
			my @data	= defined($2) ? ($1,$2) : ($1);
			my $section_text	= $3;
			if ($section_text =~ /^\s*HEADER/) {
				push(@data, 'HEADER');
				$header	= 1;
			}
			($header_list)		= $section_text =~ m{\((.*)\)};
			my @header_fields       = (defined($header_list)) ? split(/[ "]+/, $header_list) : ();
			push(@fields, [ @data, \@header_fields ]);
		}
	}
	
	my $messages	= $self->store->fetch( $self->mailbox, $from, $to, \@fields, $self->{ _by_uid } );
	foreach my $data (@{ $messages }) {
		my $getting_body	= ($fieldlist =~ /BODY/);
		my $number	= $data->{ '_number' };
		my $bodylength	= $getting_body ? length($data->{ _body }) : 0;
		
		my @headers			= ($getting_body and defined($header_list)) ? split(/ /, $header_list) : ();
		my $quoted_header_list	= join(' ', map { qq("$_") } @headers);
		my $msg	= qq|* ${number} FETCH (|
				. join(
						' ',
						map {
							join(
								' ',
								$_,
								$data->{$_}
							)
						} (grep
								{ !ref($_) and ! /^_|BODY/ }
								sort { index($fieldlist, $a) <=> index($fieldlist, $b) } @fields)
					);
		if ($getting_body) {
			$msg	.= ($header
						? ($quoted_header_list
							? qq| BODY[HEADER.FIELDS (${quoted_header_list})] |
							: qq| BODY[HEADER] |)
						: qq| BODY[] |)
					. ($bodylength ? "{${bodylength}}" : '"")');
			$self->send( $msg );
			$self->send( $data->{ _body } . ")" );
			# $self->send( ")" );
		} else {
			$msg	.= qq|)|;
			$self->send( $msg );
		}
	}
	$self->send_ok( 'FETCH completed' );
}

sub cmd_list {
	my $self	= shift;
	my $args	= shift;
	
	my @args	= $args =~ m{
						"(.*?)"
						(?:
							\s*
							"(.*?)"
						)?
					}x;
	
	if (!$1 and !$2) {
		$self->send( qq(* LIST (\\Noselect) "${DELIMITER}" "") );
	} else {
		my @list	= $self->store->list();
		$args[1]	=~ s/\*/.*/g;
		$args[1]	=~ s/%/"[^${DELIMITER}]"/eg;
		foreach my $item (grep { $args[1] ? ($_ =~ /$args[1]/) : 1 } @list) {
			$self->send( qq(* LIST (\\Marked \\HasChildren) "${DELIMITER}" "${item}") );
		}
	}
	$self->send_ok( 'LIST completed' );
}

sub cmd_login {
	my $self	= shift;
	my $args	= shift;
	my($user,$pass)	= split(/ /, $args, 2);
	for ($user, $pass) {
		$_	= substr($_,1,length($_)-2) if /^".*"$/;
	}
	
	if ($self->store->auth( $user, $pass )) {
		$self->{ _user }	= $user;
		$self->{ user }		= $self->data->{ 'users' }{ $user };
		$self->send_ok( 'LOGIN completed' );
	} else {
		$self->send_no( 'LOGIN failed' );
	}
}

sub cmd_logout {
	my $self	= shift;
	my $args	= shift;
	
	delete $self->{ _user };
	$self->send( '* BYE mangalavid-imap' );
	$self->send_ok( 'LOGOUT completed' );
	$self->client->close;
}

sub cmd_noop {
	my $self	= shift;
	my $args	= shift;
	$self->send_ok( 'NOOP completed' );
}

sub cmd_select {
	my $self	= shift;
	my $args	= shift;
	my($mailbox)	= ($args =~ m{"(.*?)"}) ? $1 : $args;
	my @list	= $self->store->list();
	
	if (grep { $mailbox eq $_ or $mailbox eq "${_}${DELIMITER}" } @list) {
		$self->{ 'mailbox' }	= $mailbox;
		
		my $status	= $self->store->status( $mailbox );
		my $count	= $status->{ MESSAGES };
		my $recent	= $status->{ RECENT };
		my $uidv	= $status->{ UIDVALIDITY };
		
		$self->send( qq(* ${count} EXISTS) );
		$self->send( qq(* ${recent} RECENT) ); 
		$self->send( qq(* OK [UIDVALIDITY ${uidv}]) );
		$self->send(  q(* FLAGS (\Deleted \Seen)) ); 
#		$self->send(  q(* OK [PERMANENTFLAGS (\Deleted \Seen \*)] Limited) ); 
		$self->send_ok( 'SELECT completed' );
	} else {
		$self->send_no( 'Invalid Mailbox' );
	}
}

sub cmd_status {
	my $self	= shift;
	my $args	= shift;
	my($mailbox)	= ($args =~ m{"(.*?)"}) ? $1 : ($args =~ /^(\S+)/)[0];
	my $status	= $self->store->status( $mailbox );
	
	my @stats;
	foreach my $key (keys %{ $status }) {
		my $val	= $status->{ $key };
		push( @stats, "${key} ${val}" );
	}
	my $msg	= qq|* STATUS "${mailbox}" (| . join(' ', @stats) . q|)|;
	
	$self->send( $msg );
	$self->send_ok( 'STATUS completed' );
}

sub cmd_store {
	my $self	= shift;
	my $args	= shift;
	$self->send_ok( 'STORE completed' );
}

sub cmd_subscribe {
	my $self	= shift;
	my $args	= shift;
	if ($args =~ m{(http:.*)$}) {
		my $url	= $1;
		$url	=~ s{$DELIMITER}{/}g;
		$url	=~ s{^http:/+}{http://};
		$url	=~ s{&AH4-}{~}g;
		$self->send_ok( 'SUBSCRIBE completed' );
	}
}

sub cmd_uid {
	my $self	= shift;
	my $args	= shift;
	my ($cmd,$stuff)	= split(/ /, $args, 2);
	my $command	= 'cmd_' . lc($cmd);
	$self->{_by_uid}	= 1;
	$self->$command($stuff);
	delete $self->{_by_uid};
}

sub cmd_unsubscribe {
	my $self	= shift;
	my $args	= shift;
	my $url		= $args =~ m{"(.*)"} ? $1 : $args;
	$self->store->unsubscribe( $url );
	$self->send_ok( 'UNSUBSCRIBE completed' );
}

################################################################################

sub send_ok {
	my $self	= shift;
	my $msg		= shift;
	my $tag		= $self->tag();
	
	$self->send( "${tag} OK $msg" );
}

sub send_no {
	my $self	= shift;
	my $msg		= shift;
	my $tag		= $self->tag();
	
	$self->send( "${tag} NO $msg" );
}

sub send_bad {
	my $self	= shift;
	my $msg		= shift;
	my $tag		= $self->tag();
	
	$self->send( "${tag} BAD $msg" );
}

sub send {
	my $self	= shift;
	my $msg		= shift;
	warn "[$$] S: $msg\n" if ($debug);
	print { $self->client } $msg . "\r\n";
}

sub AUTOLOAD {
	our $AUTOLOAD;
	my $self	= shift;
	my $name	= substr($AUTOLOAD,rindex($AUTOLOAD,':')+1);
	return if ($name eq 'DESTROY');
	if (scalar(@_)) {
		$self->{ $name }	= shift;
	} else {
		return $self->{ $name };
	}
}

1;

__END__

 $Log: Server.pm,v $
 Revision 1.4  2003/03/05 09:29:12  greg
 tiny code cleanup

 Revision 1.3  2003/03/03 14:48:12  greg
 - indented Log tags for (future) perldoc handling

 Revision 1.2  2003/03/03 14:10:14  greg
 - added PREREQ_PM to makefile
 - command tag is now an instance variable
 - command tag is no longer passed to cmd_* and send_* functions
 - rid code of unused Switch references
 - added CVS Revision, Date, and Log tags