package Project::Net::FTP::Server;

use strict;

use DBI;

use Net::FTPServer;
use Project::Net::FTP::FileHandle;
use Project::Net::FTP::DirHandle;

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

use vars qw(@ISA);
@ISA = qw(Net::FTPServer);

# Cached statement handles.
use vars qw($sth1 $sth2 $sth3);

# This is called before configuration.

sub pre_configuration_hook
{
    my $self = shift;

    $self->{version_string} .= " Project::Net::FTP/$VERSION";

    # Custom SITE commands.
    $self->{site_command_table}{USAGE} = \&_SITE_USAGE_command;
}

# This is called just after accepting a new connection. We connect
# to the database here.

sub post_accept_hook
{
    my $self = shift;

    # Connect to the database.
    my $dbh = DBI->connect ("dbi:mysql(RaiseError=>1,AutoCommit=>1):dbname=TEST",
			    "username", "password")
      or die "cannot connect to database: ftp: $!";

    # Store the database handle.
    $self->{fs_dbh} = $dbh;
}

# This is called after executing every command. It commits the transaction
# into the database.

sub post_command_hook
{
    my $self = shift;
}

# Perform login against the database.

sub authentication_hook
{
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    my $user_is_anon = shift;

    # Disallow anonymous access.
    return -1 if $user_is_anon;

    # Verify access against the database.
    my $sql = "select password from USERS where username = ?";
    $sth1 ||= $self->{fs_dbh}->prepare ($sql);
    $sth1->execute ($user);

    my $row = $sth1->fetch or return -1; # No such user.

    # Check password.
    my $hashed_pass = $row->[0];
    return -1 unless crypt ($pass, $hashed_pass) eq $hashed_pass;

    # Successful login.
    return 0;
}

# Called just after user C<$user> has successfully logged in.

sub user_login_hook
{
    # Do nothing for now, but in future it would be a good
    # idea to change uid or chroot to a safe place.
}

#  Return an instance of Net::FTPServer::DBeg1::DirHandle
# corresponding to the root directory.

sub root_directory_hook
{
    my $self = shift;

    return new Project::Net::FTP::DirHandle ($self);
}

# The SITE USAGE command.

sub _SITE_USAGE_command
{
    my $self = shift;
    my $cmd = shift;
    my $rest = shift;

    # Count the number of files and directories used.
    my $sql = "select count(ID) from FILES";
    $sth2 ||= $self->{fs_dbh}->prepare ($sql);
    $sth2->execute;

    my $row = $sth2->fetch or die "no rows returned from count";

    my $nr_files = $row->[0];

    $sql = "select count(ID) from DIRECTORIES";
    $sth3 ||= $self->{fs_dbh}->prepare ($sql);
    $sth3->execute;

    $row = $sth3->fetch or die "no rows returned from count";

    my $nr_dirs = $row->[0];

    $self->reply (200,
		  "There are $nr_files files and $nr_dirs directories.");
}

1;

__END__


##</code><code>##

package Project::Net::FTP::DirHandle;

use strict;

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

use DBI;
use Carp qw(confess croak);

use Net::FTPServer::DirHandle;
use Project::IO::Blob;
use File::Temp qw/ :POSIX /;

use vars qw(@ISA);

@ISA = qw(Net::FTPServer::DirHandle);

# Cached statement handles.
use vars qw($sth1 $sth2 $sth3 $sth4 $sth5 $sth6 $sth7 $sth8 $sth9 $sth10 $sth11 $sth12 $sth13 $sth14 $sth15 $sth16 $sth17 $sth18 $sth19 $sth20);

# Return a new directory handle.

sub new
{
	my $class = shift;
	my $ftps = shift;		# FTP server object.
	my $pathname = shift || "/"; # (only used in internal calls)
	my $dir_id = shift;		# (only used in internal calls)

	# Create object.
	my $self = Net::FTPServer::DirHandle->new ($ftps, $pathname);
	bless $self, $class;

	if ($dir_id)
	{
		$self->{fs_dir_id} = $dir_id;
	}
	else
	{
		# Find the root directory ID.
		my $sql = "select ID from DIRECTORIES where parent_ID = 0";
		$sth6 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth6->execute;

		my $row = $sth6->fetch
			or die "no root directory in database (has the database been populated?): $!";

		$self->{fs_dir_id} = $row->[0];
	}
	return $self;
}

# Return a subdirectory handle or a file handle within this directory.

sub get
{
	my $self = shift;
	my $filename = shift;

	# None of these cases should ever happen.
	confess "no filename" unless defined($filename) && length($filename);
	confess "slash filename" if $filename =~ /\//;
	confess ".. filename"    if $filename eq "..";
	confess ". filename"     if $filename eq ".";

	# Search for the file first, since files are more common than dirs.
	my $sql = "select ID, data from FILES where directory_ID = ? and name = ?";
	$sth1 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth1->execute (int ($self->{fs_dir_id}), $filename);

	my $row = $sth1->fetch;

	if ($row)
	{
		# Found a file.
		return Project::Net::FTP::FileHandle->new(
			$self->{ftps},
			$self->pathname . $filename,
			$self->{fs_dir_id},
			$row->[0], $row->[1],
			$row->[2]
		);
	}

	# Search for a directory.
	$sql = "select ID from DIRECTORIES where parent_ID = ? and name = ?";
	$sth2 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth2->execute (int ($self->{fs_dir_id}), $filename);

	$row = $sth2->fetch;

	if ($row)
	{
		# Found a directory.
		return Project::Net::FTP::DirHandle->new(
			$self->{ftps},
			$self->pathname . $filename . "/",
			$row->[0]
		);
	}

	# Not found.
	return undef;
}

# Get parent of current directory.

sub parent
{
	my $self = shift;

	return $self if $self->is_root;

	# Get a new directory handle.
	my $dirh = $self->SUPER::parent;

	# Find directory ID of the parent directory.
	my $sql = "select parent_ID from DIRECTORIES where ID = ?";
	$sth3 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth3->execute (int ($self->{fs_dir_id}));

	my $row = $sth3->fetch
		or die "directory ID ", $self->{fs_dir_id}, " missing";

	$dirh->{fs_dir_id} = $row->[0];

	return bless $dirh, ref $self;
}

sub list
{
	my $self = shift;
	my $wildcard = shift;

	# Convert wildcard into a SQL LIKE pattern.
	if ($wildcard)
	{
		if ($wildcard ne "*")
		{
			$wildcard = $self->{ftps}->wildcard_to_sql_like ($wildcard);
		}
		else
		{
			# If wildcard is "*" then it defaults to undefined (for speed).
			$wildcard = undef;
		}
	}

	# Get subdirectories.
	my ($sql, $sth);
	if ($wildcard)
	{
		$sql = "select ID, name from directories
                 where parent_ID = ? and name like ?";
		$sth15 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth15->execute (int ($self->{fs_dir_id}), $wildcard);
		$sth = $sth15;
	}
	else
	{
		$sql = "select ID, name from DIRECTORIES where parent_ID = ?";
		$sth4 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth4->execute (int ($self->{fs_dir_id}));
		$sth = $sth4;
	}

	my @result = ();
	my $username = substr $self->{ftps}{user}, 0, 8;

	while (my $row = $sth->fetch)
	{
		my $dirh = Project::Net::FTP::DirHandle->new(
			$self->{ftps},
			$self->pathname . $row->[1] . "/",
			$row->[0]
		);

		push @result, [ $row->[1], $dirh ];
	}

	# Get files.
	if ($wildcard)
	{
		$sql = "select ID, name, data from FILES where directory_ID = ? and name like ?";
		$sth16 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth16->execute (int ($self->{fs_dir_id}), $wildcard);
		$sth = $sth16;
	}
	else
	{
		$sql = "select ID, name, data from FILES where directory_ID = ?";
		$sth5 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth5->execute (int ($self->{fs_dir_id}));
		$sth = $sth5;
	}

	while (my $row = $sth->fetch)
	{
		my $fileh = Project::Net::FTP::FileHandle->new(
			$self->{ftps},
			$self->pathname . $row->[1],
			$self->{fs_dir_id},
			$row->[0],
			$row->[2]
		);

		push @result, [ $row->[1], $fileh ];
	}

	return \@result;
}

sub list_status
{
	my $self = shift;
	my $wildcard = shift;

	# Convert wildcard into a SQL LIKE pattern.
	if ($wildcard)
	{
		if ($wildcard ne "*")
		{
			$wildcard = $self->{ftps}->wildcard_to_sql_like ($wildcard);
		}
		else
		{
			# If wildcard is "*" then it defaults to undefined (for speed).
			$wildcard = undef;
		}
	}

	# Get subdirectories.
	my ($sql, $sth);
	if ($wildcard)
	{
		$sql = "select ID, name from DIRECTORIES where parent_ID = ? and name like ?";
		$sth18 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth18->execute (int ($self->{fs_dir_id}), $wildcard);
		$sth = $sth18;
	}
	else
	{
		$sql = "select ID, name from DIRECTORIES where parent_ID = ?";
		$sth17 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth17->execute (int ($self->{fs_dir_id}));
		$sth = $sth17;
	}

	my @result = ();
	my $username = substr $self->{ftps}{user}, 0, 8;

	while (my $row = $sth->fetch)
	{
		my $dirh = Project::Net::FTP::DirHandle->new(
			$self->{ftps},
			$self->pathname . $row->[1] . "/",
			$row->[0]
		);

		my @status = $dirh->status;
		push @result, [ $row->[1], $dirh, \@status ];
	}

	# Get files.
	if ($wildcard)
	{
		$sql = "select ID, name, data from FILES where directory_ID = ? and name like ?";
		$sth20 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth20->execute (int ($self->{fs_dir_id}), $wildcard);
		$sth = $sth20;
	}
	else
	{
		$sql = "select ID, name, data from FILES where directory_ID = ?";
		$sth19 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth19->execute (int ($self->{fs_dir_id}));
		$sth = $sth19;
	}

	while (my $row = $sth->fetch)
	{
		my $fileh = Project::Net::FTP::FileHandle->new(
			$self->{ftps},
			$self->pathname . $row->[1],
			$self->{fs_dir_id},
			$row->[0],
			$row->[2]
		);

		my @status = $fileh->status;
		push @result, [ $row->[1], $fileh, \@status ];
	}

	return \@result;
}

# Return the status of this directory.

sub status
{
	my $self = shift;
	my $username = substr $self->{ftps}{user}, 0, 8;

	return ( 'd', 0755, 1, $username, "users", 1024, 0 );
}

# Move a directory to elsewhere.

sub move
{
	my $self = shift;
	my $dirh = shift;
	my $filename = shift;

	# You can't move the root directory. That would be bad :-)
	return -1 if $self->is_root;

	my $sql = "update DIRECTORIES set parent_ID = ?, name = ? where ID = ?";
	$sth12 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth12->execute (int ($dirh->{fs_dir_id}), $filename, int ($self->{fs_dir_id}));

	return 0;
}

# We should only be able to delete a directory if the directory
# is empty. We could use referential constraints. However, I'm using 
# MySQL.

sub delete
{
	my $self = shift;

	# Check referential constraints.
	my $sql = "select count(ID) from FILES where directory_ID = ?";
	$sth7 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth7->execute (int ($self->{fs_dir_id}));

	my $row = $sth7->fetch or die "no rows returned from count";

	my $nr_files = $row->[0];

	$sql = "select count(ID) from DIRECTORIES where parent_ID = ?";
	$sth8 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth8->execute (int ($self->{fs_dir_id}));

	$row = $sth8->fetch or die "no rows returned from count";

	my $nr_dirs = $row->[0];

	return -1 if $nr_files > 0 || $nr_dirs > 0;

	# Delete the directory.
	$sql = "delete from DIRECTORIES where ID = ?";
	$sth9 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth9->execute (int ($self->{fs_dir_id}));

	return 0;
}

# Create a subdirectory.

sub mkdir
{
	my $self = shift;
	my $dirname = shift;

	my $sql = "insert into DIRECTORIES (parent_ID, name) values (?, ?)";
	$sth10 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth10->execute (int ($self->{fs_dir_id}), $dirname);

	return 0;
}

# Open or create a file in this directory.

sub open
{
	my $self = shift;
	my $filename = shift;
	my $mode = shift;

	if($mode eq 'r')
	{
		# Read an existing file
		my $sql = 'select data,ID from FILES where directory_ID = ? and name =?';
		$sth11 ||= $self->{ftps}{fs_dbh}->prepare($sql);
		$sth11->execute(int ($self->{fs_dir_id}), $filename);

		# Fetch the data or return
		my $row = $sth11->fetch or return undef;

		return Project::IO::Blob->new({
			mode	=>	'r', 
			dbh	=>	$self->{ftps}{fs_dbh}, 
			data	=>	\$row->[0],
			ID		=>	$row->[1]
		});
	}
	elsif($mode eq 'w')
	{
		# Create a file entry (this also covers an overwrite apparently)
		my $dbh = $self->{ftps}{fs_dbh};

		my $check = "select data, ID from FILES where directory_ID = ? and name = ?";
		$sth13 ||= $self->{ftps}{fs_dbh}->prepare ($check);
		$sth13->execute (int ($self->{fs_dir_id}), $filename);

		my $row = $sth13->fetch;
		if($row)
		{
			return Project::IO::Blob->new({
				mode	=>	'a', 
				dbh	=>	$self->{ftps}{fs_dbh}, 
				data	=>	undef,
				ID		=>	$row->[1]
			});
		}

		my $sql = "insert into FILES (name, directory_ID) values (?, ?)";
		$sth14 ||= $dbh->prepare ($sql);
		$sth14->execute ($filename, int ($self->{fs_dir_id}));

		# Return an IO::Blob. This allows us to write to an internal scalar
		# flush it to the database on file closure.
		return Project::IO::Blob->new({
			mode	=>	'w', 
			dbh	=>	$self->{ftps}{fs_dbh},
			data	=>	undef,
			ID		=>	$dbh->{'mysql_insertid'}
		});
	}
	elsif($mode eq 'a')
	{
		# Append to an existing file - read the data from the blob, save to
		# a scalar, return an IO::* handle on that, every write will
		# save to the scalar and the close saves back to the db.
		my $sql = "select data, ID from FILES where directory_ID = ? and name = ?";
		$sth13 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
		$sth13->execute (int ($self->{fs_dir_id}), $filename);

		my $row = $sth13->fetch or return undef;

		return Project::IO::Blob->new({
			mode	=>	'a', 
			dbh	=>	$self->{ftps}{fs_dbh}, 
			data	=>	\$row->[0],
			ID		=>	$row->[1]
		});
	}
	else
	{
		croak "unknown file mode: $mode; use 'r', 'w' or 'a' instead";
	}
	return;

  }

1;

__END__

##</code><code>##

package Project::Net::FTP::FileHandle;

use strict;

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

use Carp qw(croak confess);

use Net::FTPServer::FileHandle;
use Project::Net::FTP::DirHandle;
use Project::IO::Blob;

use vars qw(@ISA);
@ISA = qw(Net::FTPServer::FileHandle);

use vars qw($sth1 $sth2 $sth3 $sth4 $sth13);

# Return a new file handle.

sub new
{
	my $class = shift;
	my $ftps = shift;
	my $pathname = shift;
	my $dir_id = shift;
	my $file_id = shift;
	my $content = shift;

	# Create object.
	my $self = Net::FTPServer::FileHandle->new ($ftps, $pathname);

	$self->{fs_dir_id} = $dir_id;
	$self->{fs_file_id} = $file_id;
	$self->{fs_content} = $content;

	return bless $self, $class;
}

# Return the directory handle for this file.

sub dir
{
	my $self = shift;

	return Project::Net::FTP::DirHandle->new (
		$self->{ftps},
		$self->dirname,
		$self->{fs_dir_id}
	);
}

# Open the file handle.

sub open
{
	my $self = shift;
	my $mode = shift;

	if ($mode eq "r")		# Open file for reading.
	{
		return Project::IO::Blob->new({
			mode	=>	'r', 
			dbh	=>	$self->{ftps}{fs_dbh}, 
			data	=>	\$self->{fs_content},
			ID		=>	undef
		});
	}
	elsif ($mode eq "w")	# Create/overwrite the file.
	{
		# Remove the existing large object and create a new one.
		my $dbh = $self->{ftps}{fs_dbh};

		my $sql = "update FILES set data = null where ID = ?";
		$sth4 ||= $dbh->prepare ($sql);
		$sth4->execute (int ($self->{fs_file_id}));

		return Project::IO::Blob->new({
			mode	=>	'w', 
			dbh	=>	$self->{ftps}{fs_dbh}, 
			data	=>	\$self->{fs_content}, 
			ID		=>	$self->{fs_file_id}
		});
	}
	elsif ($mode eq "a")	# Append to the file.
	{
		return Project::IO::Blob->new({
			mode	=>	'w', 
			dbh	=>	$self->{ftps}{fs_dbh}, 
			data	=>	\$self->{fs_content}, 
			ID		=>	$self->{fs_file_id}
		});
	}
	else
	{
		croak "unknown file mode: $mode; use 'r', 'w' or 'a' instead";
	}
}

sub status
{
	my $self = shift;
	my $dbh = $self->{ftps}{fs_dbh};
	my $username = substr $self->{ftps}{user}, 0, 8;

	my $blob_fd;
	my $sql = "select length(data) from FILES where ID = ?";
	$sth13 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth13->execute (int ($self->{fs_file_id}));

	my $row = $sth13->fetch or return undef;
	return ( 'f', 0644, 1, $username, "users", $row->[0], 0 );
}

# Move a file to elsewhere.

sub move
{
	my $self = shift;
	my $dirh = shift;
	my $filename = shift;

	my $sql = "update FILES set directory_ID = ?, name = ? where ID = ?";
	$sth2 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth2->execute (int ($dirh->{fs_dir_id}), $filename, int ($self->{fs_file_id}));

	return 0;
}

# Delete a file.

sub delete
{
	my $self = shift;

	my $sql = "delete from FILES where ID = ?";
	$sth1 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
	$sth1->execute (int ($self->{fs_file_id}));

	return 0;
}

1;

__END__



##</code><code>##

package Project::IO::Blob;

use strict;
use IO::Scalar;

use vars qw($VERSION $sth @ISA);
$VERSION = '0.1';

use DBI;
use Carp qw(confess croak);

@ISA  = qw(IO::Scalar);

sub new
{
	my $class = shift;
	my $opts = shift;
	my $mode = $opts->{'mode'};
	my $dbh = $opts->{'dbh'};
	my $data = $opts->{'data'};
	my $ID = $opts->{'ID'};

	# Bless you my child
	my $self = IO::Scalar->new ($data);
	bless $self, $class;


	*$self->{'io_blob_mode'} = $mode;
	*$self->{'io_blob_dbh'} = $dbh;
	*$self->{'io_blob_ID'}	=	$ID;

	return $self;
}

sub close
{
	my $self = shift;

	# Flush to db
	if (*$self->{'io_blob_dbh'} && defined(*$self->{'io_blob_ID'}))
	{
		my $sql = "update FILES set data = ? where ID = ?";
		$sth ||= *$self->{'io_blob_dbh'}->prepare ($sql);
		$sth->execute (${$self->sref}, *$self->{'io_blob_ID'});

		delete *$self->{'io_blob_dbh'};
	}

	return 1;
}

1;

__END__