LWP::Conn::FTP

package LWP::Conn::FTP;

# $Id: FTP.pm,v 1.17 1998/07/05 22:20:51 aas Exp $

# Copyright 1997-1998 Gisle Aas.
#
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use IO::Socket ();
use LWP::MainLoop qw(mainloop);
use strict;

use vars qw($DEBUG @ISA);
@ISA=qw(IO::Socket::INET);

sub new
{
    my($class, %cnf) = @_;

    my $mgr = delete $cnf{ManagedBy} ||
      Carp::croak("'ManagedBy' is mandatory");
    my $host =   delete $cnf{Host} || delete $cnf{PeerAddr} ||
      Carp::croak("'Host' is mandatory for FTP");

    my $port;
    $port = $1 if $host =~ s/:(\d+)//;
    $port = delete $cnf{Port} || delete $cnf{PeerPort} || $port || 21;

    my $timeout = delete $cnf{Timeout} || 5*60;
    my $idle_timeout = delete $cnf{IdleTimeout} || $timeout;
    my $conn_timeout = delete $cnf{ConnTimeout} || $timeout;
    my $req_limit = delete $cnf{ReqLimit} || 4;

    if (%cnf && $^W) {
	for (keys %cnf) {
	    warn "Unknown LWP::Conn::FTP->new attribute '$_' ignored\n";
	}
    }

    return LWP::Conn::_Connect->new($host, $port, $conn_timeout,
				   "LWP::Conn::FTP::Start",
				    [$mgr, $req_limit, $timeout, $idle_timeout]
				   );
}

sub state
{
    my($self, $state) = @_;
    print "STATE: $state\n" if $DEBUG && $DEBUG > 1;
    my $class = "LWP::Conn::FTP::$state";
    bless $self, $class;
}

sub inactive
{
    my $self = shift;
    $self->_error("Timeout");
}


sub error
{
    my($self, $msg) = @_;
    $self->_error("$msg: " . $self->message);
}

sub _error
{
    my($self, $msg) = @_;
    chomp($msg);
    print STDERR "ERROR: $msg\n";
    mainloop->forget($self);
    $self->close;
    if (my $data = delete *$self->{'lwp_data'}) {
	$data->close;
    }
    *$self->{'lwp_mgr'}->connection_closed($self);
    if (my $req = delete *$self->{'lwp_req'}) {
	$req->give_response(590, $msg);
    }
}

sub readable
{
    my $self = shift;
    my $buf = \ *$self->{'lwp_rbuf'};
    my $n = sysread($self, $$buf, 2048, length($$buf));
    if (!defined($n)) {
	$self->_error("Bad read: $!");
    } elsif ($n == 0) {
	$self->_error("EOF");
    } else {
	$self->check_rbuf;
    }
}

sub check_rbuf
{
    my $self = shift;
    my $buf = \ *$self->{'lwp_rbuf'};
    if (length $$buf) {
	my @lines = split(/\015?\012/, $$buf);
	if (substr($$buf, -1, 1) ne "\012") {
	    # the last line was not complete
	    *$self->{'lwp_rbuf'} = pop @lines;
	} else {
	    *$self->{'lwp_rbuf'} = "";
	}
	push(@{*$self->{'lwp_lines'}}, @lines);
    }
    $self->parse_response;
}

sub parse_response
{
    my $self = shift;
    my($code, $more, @res);
    while (@{*$self->{'lwp_lines'}}) {
	my $line = shift @{*$self->{'lwp_lines'}};
	if ($line =~ /^(\d\d\d)([\-\s])/) {
	    $more = $2 eq "-";
	    if ($code) {
                $more++ if $code ne $1;
	    } else {
		$code = $1;
	    }
	} elsif (!$code) {
	    push(@res, $line);
	    return $self->reponse_error(join("\n", @res));
	}
	push(@res, $line);
	last unless $more;
    }
    if ($more) {
	unshift(@{*$self->{'lwp_lines'}}, @res);
    } elsif ($code) {
	*$self->{'lwp_response_code'} = $code;
	*$self->{'lwp_response_mess'} = \@res;
	print STDERR "   <===\t", join("\n\t", @res), "\n" if $DEBUG;
	$self->response(substr($code, 0, 1), $code);
	$self->parse_response;
    }
}

sub response_error
{
    my($self, $bad_response) = @_;
    print STDERR "FTP: Bad server response '$bad_response' ignored\n";
}

sub code
{
    my $self = shift;
    *$self->{'lwp_response_code'} || "000";
}

sub message
{
    my $self = shift;
    wantarray ? @{*$self->{'lwp_response_mess'}}
              : join("\n", @{*$self->{'lwp_response_mess'}}, "");
}

sub response
{
    my($self, $r, $code, $mess) = @_;
    print STDERR "Response $code ignored\n";
}

sub send_cmd
{
    my($self, $cmd, $next_state) = @_;
    if ($DEBUG) {
	my $out = $cmd;
	$out =~ s/^(PASS\s+)(.+)/$1 . "*" x length($2)/e;
	print STDERR "===>\t$out\n";
    }
    $cmd .= "\015\012";
    # XXX should really wait for the socket to become writable, but
    # it is very unlikely that it should not be that.
    my $n = $self->syswrite($cmd, length($cmd));
    $self->_error("Can't syswrite ($n)") if !$n || $n != length($cmd);
    $self->state($next_state) if $next_state;
}

sub activate
{
}

sub stop
{
    my $self = shift;
    $self->_error("STOP");
}

sub login_info
{
    my($self, $req) = @_;
    my $url = $req->url;
    my($user,$pass) = $req->authorization_basic;
    $user ||= $url->user || "anonymous";
    $pass ||= $url->password || "nobody@";
    my $acct = $req->header("Account") || "home";
    ($user, $pass, $acct);
}

sub give_response
{
    my($self, $code, $mess, $more) = @_;
    my $req = delete *$self->{'lwp_req'};
    if (ref($more) || !defined($more)) {
	$more->{Server} = *$self->{'lwp_server_product'};
    }
    $req->give_response($code, $mess, $more);
    $self->activate;
}


package LWP::Conn::FTP::Start;
use base 'LWP::Conn::FTP';
use LWP::MainLoop qw(mainloop);

sub connected
{
    my($self, $param) = @_;
    @{*$self}{'lwp_mgr', 'lwp_rlim',
              'lwp_timeout', 'lwp_idle_timeout'} = @$param;
    *$self->{'lwp_type'} = "";
    *$self->{'lwp_rbuf'} = "";
    mainloop->readable($self);
    mainloop->timeout($self, *$self->{'lwp_idle_timeout'});
    $self->activate;
}

sub connect_failed
{
    my($self, $msg, $param) = @_;
    my $mgr = shift @$param;
    while (my $req = $mgr->get_request($self)) {
	$req->give_response(590, $msg);
    }
    $mgr->connection_closed($self);
}

sub response
{
    my($self, $r) = @_;
    $self->error("Bad welcome") unless $r eq "2";
    my $mess = $self->message;
    *$self->{'lwp_greeting'} = $mess;
    # Try to make it into a HTTP product token
    $mess =~ s/^\d+\s+//;
    $mess =~ s/^[\w\.]+\s+//;  # host name
    $mess =~ s/\s+ready\.?\s+$//;
    $mess =~ s/\s+\(Version\s+/\// && $mess =~ s/\)$//;
    *$self->{'lwp_server_product'} = $mess;
    $self->send_cmd("SYST" => "Syst");
}


package LWP::Conn::FTP::Syst;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r) = @_;
    if ($r eq "2") {
	chomp(my $mess = $self->message);
	*$self->{'lwp_syst'} = $mess;
	$mess =~ s/^\d+\s+//;
	*$self->{'lwp_unix'}++ if $mess =~ /\bUNIX\b/i;
	*$self->{'lwp_server_product'} .= " ($mess)";
    }
    *$self->{'lwp_idle'}++;
    $self->state("Outlogged");
    $self->activate;
}


package LWP::Conn::FTP::Outlogged;
use base 'LWP::Conn::FTP';

sub activate
{
    my $self = shift;
    my $req = *$self->{'lwp_mgr'}->get_request;
    if (!$req) {
	*$self->{'lwp_idle'}++;
	*$self->{'lwp_mgr'}->connection_idle($self);
	return;
    } elsif (*$self->{'lwp_idle'}) {
	*$self->{'lwp_idle'} = 0;
	*$self->{'lwp_mgr'}->connection_active($self);
    }
    *$self->{'lwp_req'} = $req;
    (*$self->{'lwp_user'}, *$self->{'lwp_pass'}, *$self->{'lwp_acct'})
	= $self->login_info($req);
    $self->send_cmd("USER " . *$self->{'lwp_user'} => "User");
}


package LWP::Conn::FTP::User;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r) = @_;
    if ($r eq "3") {
	my $pass = *$self->{'lwp_pass'};
	$self->send_cmd("PASS $pass" => "Pass");
    } elsif ($r eq "2") {
	$self->login_complete;
    } else {
	$self->cant_login;
    }
}

sub login_complete
{
    my $self = shift;
    $self->state("Ready");
    $self->activate;
}

sub cant_login
{
    my $self = shift;
    my $mess = $self->message;
    $mess =~ s/^\d+\s+//;
    chomp($mess);
    $self->state("Outlogged");
    $self->give_response(401, $mess,
			{"WWW-Authenticate" => 'Basic realm="FTP"',
			});
    $self->activate;
}


package LWP::Conn::FTP::Pass;
use base 'LWP::Conn::FTP::User';
sub response
{
    my($self, $r) = @_;
    if ($r eq "3") {
	my $acct = *$self->{'lwp_acct'};
	$self->send_cmd("ACCT $acct" => "Acct");
    } elsif ($r eq "2") {
	$self->login_complete;
    } else {
	$self->cant_login;
    }
}


package LWP::Conn::FTP::Acct;
use base 'LWP::Conn::FTP::User';
sub response
{
    my($self, $r) = @_;
    if ($r eq "2") {
	$self->login_complete;
    } else {
	$self->cant_login;
    }
}


package LWP::Conn::FTP::Rein;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r) = @_;
    if ($r eq "2") {
	$self->send_cmd("USER " . *$self->{'lwp_user'} => "User");
    } else {
	if (my $req = delete *$self->{'lwp_req'}) {
	    *$self->{'lwp_mgr'}->pushback_request($self, $req);
	}
	$self->error("Can't reinitialize");
    }
}


package LWP::Conn::FTP::Type;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r) = @_;
    if ($r eq "2") {
	$self->state("Ready");
	$self->activate;
    } else {
	$self->error("Can't set TYPE");
    }
}


package LWP::Conn::FTP::Ready;
use base 'LWP::Conn::FTP';
use LWP::MainLoop qw(mainloop);


sub type
{
    my($self, $type) = @_;
    return 1 if *$self->{'lwp_type'} eq $type;
    *$self->{'lwp_type'} = $type;
    $self->send_cmd("TYPE $type" => "Type");
    0;
}

sub activate
{
    my $self = shift;

    my $req = *$self->{'lwp_req'};
    unless ($req) {
	$req = *$self->{'lwp_mgr'}->get_request;
	if (!$req) {
	    *$self->{'lwp_idle'}++;
	    *$self->{'lwp_mgr'}->connection_idle($self);
	    return;
	} 
	elsif (*$self->{'lwp_idle'}) {
	    *$self->{'lwp_idle'} = 0;
	    *$self->{'lwp_mgr'}->connection_active($self);
	}
	*$self->{'lwp_req'} = $req;
	my($user, $pass, $acct) = $self->login_info($req);
	if ($user ne *$self->{'lwp_user'}) {
	    (*$self->{'lwp_user'}, *$self->{'lwp_pass'}, *$self->{'lwp_acct'})
		= ($user, $pass, $acct);
	    $self->send_cmd("REIN" => "Rein");
	    return;
	}
    }

    # We now have a request to perform and is logged in as the correct
    # user.
    my $method = uc($req->method);
    my $file = $req->url->path;
    if ($method =~ /^(GET|HEAD|PUT)$/) {
	# It would be nice to also support APPEND, PUT-UNIQUE
	return unless $self->type("I");  # we always use binary transfer mode

	$self->file_trans($method, $file);
	return;

	my @cwd = qw();
	if (@cwd) {
	    @{*$self->{'lwp_cwd'}} = @cwd;
	    $self->state("Cwd");
	    $self->cwd;
	    return;
	} else {
	    $self->cwd_done;
	}

    } elsif ($method eq "DELETE") {
	$self->send_cmd("DELE $file" => "Dele");

    } elsif ($method eq "RENAME") {
	$self->give_response(501, "RENAME not implemented yet");

    } elsif ($method eq "TRACE") {
	my $req = delete *$self->{'lwp_req'};
	my $res = $req->new_response(200, "OK");
	$res->date(time);
	$res->server(*$self->{'lwp_server_product'});
	$res->content_type("message/http");
	$res->content($req->as_string);
	$req->response_done($res);
	$self->activate;

    } else {
	$self->give_response(501, "Method not implemented");
    }
}

sub cwd_done
{
    # now we want to actually try to fetch the file
    # we could start by running SIZE, MDTM and such to get header
    # information and also to check if the file is there.
    my $self = shift;

}

sub file_trans
{
    my($self, $method, $file) = @_;
    *$self->{'lwp_meth'} = $method;
    *$self->{'lwp_file'} = $file;

    my $res = *$self->{'lwp_req'}->new_response(200, "OK");
    $res->date(time);
    $res->server(*$self->{'lwp_server_product'});
    # XXX we should guess content_type and such here
    *$self->{'lwp_res'} = $res;

    if ($method eq "PUT") {
	$self->port("W");
    } else {
	unless (*$self->{'lwp_noSIZE'}) {
	    $self->send_cmd("SIZE $file" => "Size");
	    return;
	}
	unless (*$self->{'lwp_noMDTM'}) {
	    $self->send_cmd("MDTM $file" => "Mdtm");
	    return;
	}
	$self->port(0);
    }
}

sub port
{
    my($self, $write) = @_;
    my $data = IO::Socket::INET->new(Listen => 1,
				     LocalAddr => $self->sockhost,
                                    );
    *$self->{'lwp_done'} = 0;
    if ($data) {
	my $port = $data->sockport;
	$port = ($port >> 8) . "," . ($port & 0xFF);
	$port = join(",", split(/\./, $data->sockhost)) . ",$port";
	$self->send_cmd("PORT $port" => "Port");
	bless $data, "LWP::Conn::FTP::Data::Listen";  # 4 level name - whow!!
	mainloop->readable($data);
	*$data->{'lwp_write'} = *$self->{'lwp_req'}->content_ref if $write;
	# A little circular reference makes life more interesting...
	*$data->{'lwp_ftp'} = $self;
	*$self->{'lwp_data'} = $data;
    } else {
	$self->_error("Can't create passive data socket");
    }
}

use Socket qw(MSG_OOB);

sub abort
{
    my $self = shift;
    send($self, "\377\364", 0);        # TELNET: IAC, IP
    send($self, "\377\362", MSG_OOB);  # TELNET: IAC, DM
    $self->send_cmd("ABOR");
    if (my $data = delete *$self->{'lwp_data'}) {
	$data->close;
    }
}

package LWP::Conn::FTP::Size;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r, $code) = @_;
    my $skip_mdtm = *$self->{'lwp_noMDTM'};
    if ($r eq "2") {
	if ($self->message =~ /^\d+\s+(\d+)$/) {
	    *$self->{'lwp_res'}->content_length($1);
	}
    } elsif ($code eq "550") {
	# Unluckily, we get the same answer for a file that does not
	# exists and a file that happens to be a directory, so we must
	# continue (but we can skip MDTM)
	$skip_mdtm++
    } else {
	*$self->{'lwp_noSIZE'}++;
    }

    if ($skip_mdtm) {
	$self->state("Ready");
	$self->port();
    } else {
	my $file = *$self->{'lwp_file'};
	$self->send_cmd("MDTM $file" => "Mdtm");
    }
}


package LWP::Conn::FTP::Mdtm;
use base 'LWP::Conn::FTP';
use HTTP::Date qw(str2time);

sub response
{
    my($self, $r, $code) = @_;
    if ($r eq "2") {
	if ($self->message =~ /^\d+\s+(\d{8})(\d{6})?$/) {
	    my $t = str2time($2 ? "$1T$2" : $1);
	    *$self->{'lwp_res'}->last_modified($t);
	    # XXX  This is also the place to implement If-Modified-Since
	}
    } elsif ($code ne "550") {
	*$self->{'lwp_noMDTM'}++;
    }
    $self->state("Ready");
    $self->port();
}


package LWP::Conn::FTP::Dele;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r, $code) = @_;
    $self->state("Ready");
    my $mess = $self->message;
    $mess =~ s/^\d+\s+//;
    chomp($mess);
    if ($r eq "2") {
	$self->give_response(204, $mess);
    } elsif ($code eq "550") {
	$self->give_response(404, $mess);
    } else {
	$self->give_response(400, $mess);
    }
}

package LWP::Conn::FTP::Port;
use base 'LWP::Conn::FTP';

sub response
{
    my($self, $r) = @_;
    if ($r eq "2") {
	my $cmd = *$self->{'lwp_meth'} eq "PUT" ? "STOR" : "RETR";
	my $file = *$self->{'lwp_file'};
	$self->send_cmd("$cmd $file" => "Trans");
    } else {
	$self->_error("PORT failed");
    }
}

package LWP::Conn::FTP::Trans;
use base 'LWP::Conn::FTP::Ready';

sub activate
{
    # ignore
}

sub response
{
    my($self, $r, $code) = @_;
    if ($r eq "1") {
	# info message only, we know that the response will succeed
	# and if method is "HEAD" we might want to send a ABRT at
	# this time...
	my $res = *$self->{'lwp_res'};
	if ($self->message =~ /\((\d+)\s+bytes\)/) {
	    # If it is already set, should we compare it with the
	    # previous value??
	    $res->content_length($1);
	}
	*$self->{'lwp_req'}->response_data("", $res);
	# XXX catch except
	$self->abort if *$self->{'lwp_meth'} eq "HEAD";
    } elsif ($r eq "2") {
	# we are done.  Must sync with closing of data connection
	$self->data_done($code);
    } elsif ($code eq "426") {  # transfer aborted
	*$self->{'lwp_res'}->header("Abort" => $self->message);
	$self->data_done($code);
    } elsif ($code eq "550") {  # no such file
	if (lc($self->message) =~ /or directory/) {
	    delete(*$self->{'lwp_data'})->close;
	    $self->state("Ready");
	    $self->give_response(404);
	} else {
	    # It might still be a directory, try to list it
	    my $file = *$self->{'lwp_file'};
	    $self->send_cmd("LIST $file" => "List");
	    my $res = *$self->{'lwp_res'};
	    $res->content_type("text/ftp-dir-listing");
	    $res->remove_header("Content-Encoding");
	}
    } else {
	$self->error("Trans");
    }
}

sub data
{
    my $self = shift;
    #return if *$self->{'lwp_meth'} eq "HEAD";

    eval {
	*$self->{'lwp_req'}->response_data($_[0], *$self->{'lwp_res'});
    };
    if ($@) {
	# Initiate ABRT
	$self->abort
    }
}

sub data_really_done
{
    my $self = shift;
    my $req = delete *$self->{'lwp_req'};
    my $res = delete *$self->{'lwp_res'};
    $req->response_done($res);

    # Start with next request
    $self->state("Ready");
    $self->activate;
}

sub data_done
{
    my($self, $code) = @_;
    if ($code && $code eq "426") {
	$self->data_really_done;
    } else {
	$self->state("TransWait");
    }
}

package LWP::Conn::FTP::TransWait;
use base 'LWP::Conn::FTP::Trans';

sub activate {}

sub data_done
{
    my $self = shift;
    $self->data_really_done;
}

sub response
{
    my $self = shift;
    my($r, $code) = @_;
    if ($code eq "225" || $code eq "226") {
	# ABOR command successful ignored
	$self->data_really_done;
	return;
    }
    $self->SUPER::response(@_);
}


package LWP::Conn::FTP::List;
use base 'LWP::Conn::FTP::Trans';

sub response
{
    my($self, $r, $code) = @_;
    if ($r eq "1") {
	# info message, ignore
	*$self->{'lwp_req'}->response_data("", *$self->{'lwp_res'});
	# XXX catch except
    } elsif ($r eq "2") {
	# we are done.  Must sync with data_done callback
	$self->data_done($self->message);
    } elsif ($code eq "550") {
	delete(*$self->{'lwp_data'})->close;
	$self->state("Ready");
	$self->give_response(404);
    } else {
	$self->error("LIST");
    }
}



package LWP::Conn::FTP::Cwd;
use base 'LWP::Conn::FTP';

sub cwd
{
    my $self = shift;
    my $dir = shift @{*$self->{'lwp_cwd'}};
    if ($dir) {
	if ($dir eq "..") {
	    $self->send_cmd("CDUP");
	} else {
	    $self->send_cmd("CWD $dir");
	}
    } else {
	$self->state("Ready");
	$self->cwd_done;
    }
}

sub response
{
    my($self, $r) = @_;
    if ($r eq "2") {
	$self->cwd;
    } else {
	$self->error("Can't CWD");
    }
}


package LWP::Conn::FTP::Data::Listen;
use base 'IO::Socket::INET';

use LWP::MainLoop qw(mainloop);

sub readable
{
    my $self = shift;
    if (my $data = $self->accept) {
	print "FTP DATA ACCEPT\n" if $LWP::Conn::FTP::DEBUG &&
	                             $LWP::Conn::FTP::DEBUG > 2;
	mainloop->readable($data);
	bless $data, "LWP::Conn::FTP::Data";
	if (my $w = *$self->{'lwp_write'}) {
	    *$data->{'lwp_write'} = $w;
	    *$data->{'lwp_wbuf'}  = '';
	    mainloop->writable($data);
	}
	my $ftp = *$self->{'lwp_ftp'};
	*$data->{'lwp_ftp'} = $ftp;
	*$ftp->{'lwp_data'} = $data;
    } else {
	*$self->{'lwp_ftp'}->_error("Can't accept");
    }
    mainloop->forget($self);
    $self->close;
}

sub close
{
    my $self = shift;
    mainloop->forget($self);
    $self->SUPER::close;
}

package LWP::Conn::FTP::Data;
use base 'LWP::Conn::FTP::Data::Listen';

use LWP::MainLoop qw(mainloop);

sub readable
{
    my $self = shift;
    my $buf = "";
    mainloop->activity(*$self->{'lwp_ftp'});
    my $n = sysread($self, $buf, 2048);
    if ($n) {
	print "FTP DATA READ $n bytes\n" if $LWP::Conn::FTP::DEBUG &&
	                                    $LWP::Conn::FTP::DEBUG > 2;
	*$self->{'lwp_ftp'}->data($buf);
    } else {
	if (defined $n) {
	    *$self->{'lwp_ftp'}->data_done();
	} else {
	    *$self->{'lwp_ftp'}->_error("Data connection error: $!");
	}
	$self->close;
    }
}

sub writable
{
    my $self = shift;
    #print "Writeable\n";
    mainloop->activity(*$self->{'lwp_ftp'});
    my $buf = \*$self->{'lwp_wbuf'};
    unless (defined $$buf and length $$buf) {
	my $w = *$self->{'lwp_write'};
	unless ($w) {
	    *$self->{'lwp_ftp'}->data_done();
	    $self->close;
	    return;
	}
	$w = $$w if ref($$w);
	if (ref($w) eq "CODE") {
	    $$buf = &$w();
	    unless (defined $$buf and length $$buf) {
		delete *$self->{'lwp_write'};
		return;
	    }
	} else {
	    $$buf = $$w;
	    delete *$self->{'lwp_write'};
	}
	return unless length $$buf;
    }
    my $len = length($$buf);
    $len = 2048 if $len > 2048;
    my $n = syswrite($self, $$buf, $len);
    if ($n) {
	print "FTP DATA WRITE $n bytes\n" if $LWP::Conn::FTP::DEBUG &&
	                                     $LWP::Conn::FTP::DEBUG > 2;
	substr($$buf, 0, $n) = '';
    } else {
	*$self->{'lwp_ftp'}->_error("Data connection error: $!");
	$self->close;
    }
}

1;