miniserver.pm

本文件为Web-FTP的实现源代码 是cgi编程 使用perl为主 本软件适用于linux下

package MiniServer;

use Carp;
use IO::Socket;
use strict;
use POSIX;

my $CRLF = "\015\012";

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};

    unless(@_ == 5) {
        confess
            "usage: MiniServer->new(peer, DenyStrRef, Servername, FileHandler, conf)";
    }

    $self->{PEER} = shift;
    $self->{DENYSTRREF} = shift;

    my $Servername = shift;
    $self->{WANT_COOKIE} = 0;

    $self->{FILEHANDLER} = shift;
    $self->{conf} = shift;

    $self->{COOKIE} = undef;
    $self->{SERVER} = undef;
    $self->{CLIENT} = undef;

    bless($self, $class);
    return $self;
}

sub WANT_COOKIE { $_[0]->{WANT_COOKIE} = $_[1]; }

 ########
# Server #
##########
sub startServer {
    my $self = shift;
    
    unless(-d $self->{conf}{socketdir}) {
	my($dir);
	for (split '/', $self->{conf}{socketdir}) {
	    $dir .= '/'.$_;
	    next if -d $dir;
	    unless(mkdir($dir, 0700)) {
		$self->sendResponse($self->{DENYSTRREF}->errorPage("Could not create the socket directory $self->{conf}{socketdir}"));
		exit(0);
	    }
	}
    }
    
    $self->{SERVER} = new IO::Socket::UNIX('Local' => sprintf("$self->{conf}{socketdir}/%05d",$$),
                                           'Listen' => 5,
                                           );

    unless($self->{SERVER}) {
        $self->sendResponse($self->{DENYSTRREF}->errorPage('Could not become a web server'));
        confess "Could not become a web server: $!";
        exit(0);
    }
}

sub Server {
    my $self = shift;
    return $self->{SERVER};
}

sub Client {
    my $self = shift;
    return $self->{CLIENT};
}

sub awaitConnection {
    my $self = shift;
    my $SERVER = $self->Server;

    my $CLIENT = $SERVER->accept();

    $self->{CLIENT} = $CLIENT;
}

sub handleQueryHeaders {
    my $self = shift;
    my $CLIENT = $self->Client;
    my(%queryHash, $Cookie);
    my $end_env = 0;
    while(<$CLIENT>) {
        if(/form-data; boundary=(\S+)/i) { $queryHash{BOUNDARY} = $1; }
        elsif(/^REQUEST_METHOD=(\S+)/i) { $queryHash{REQUEST_METHOD} = $1; }
        elsif(/^SCRIPT_NAME=(\S*)/i) { $self->{conf}{SCRIPT_NAME} = $1; }
        elsif(/^PATH_INFO=(\S*)/) { $queryHash{PATH} = $1  }
        elsif(/^QUERY_STRING=(\S*)/) { $queryHash{QUERY_STRING} = $1  }
        elsif(/^Content_Length=(\S+)/i) { $queryHash{CONTENT_LENGTH} = $1; }
        elsif(/^__END_ENV__$/) {
	    $self->{conf}{SCRIPT} = "$self->{conf}{HTTP}$self->{conf}{SERVERNAME}$self->{conf}{SCRIPT_NAME}";
	    $queryHash{PATH} =~ s|^/*(\d*)/+||;
	    $Cookie = $1;
            if($self->{COOKIE}) {   # COOKIE will only be defined if WANT_COOKIE is
		unless(defined($Cookie) && $Cookie eq $self->{COOKIE}) {
		    $self->sendResponse($self->{DENYSTRREF}->permissionFailure());
		    $CLIENT->close;
		    
		    return undef;
		}
            }
            
            if($queryHash{REQUEST_METHOD} eq 'POST') {
                $self->handleStupidMime(\%queryHash);
            }
            last;
        }
    }
    $queryHash{PATH} .= "?$queryHash{QUERY_STRING}" if $queryHash{QUERY_STRING};
#    close TEST;
    return \%queryHash;
}

sub genCookie {
    my($self) = shift;
    $self->{COOKIE_VAL} = sprintf("%05d",$$);    
    $self->{COOKIE_VAL} .= join('',(split //, rand())[-7..-1]);
    $self->{COOKIE} = "$self->{COOKIE_VAL}";
    $self->{conf}{COOKIE} = "/$self->{COOKIE}";
}

sub sendResponse {
    my($self, $pageref) = @_;
    my $CLIENT = $self->Client || \*STDOUT;

    eval {
	if($self->{conf}{specialheader}) {
	    print $CLIENT $self->{conf}{specialheader};
	    delete $self->{conf}{specialheader};
	} else {
	    print $CLIENT "Connection: close\n",
	    "Pragma: no-cache\n",
	    "Cache-Control: no-cache\n",
	    "Content-type: text/html\n\n";
	}
	print $CLIENT $$pageref;
    };
    confess $@ if $@;
}

sub sendRedirect {
    my($self, $URL) = @_;
    my $CLIENT = $self->Client || \*STDOUT;

    print $CLIENT "Status: 302 Moved Temporarily$CRLF" .
        "Location: $URL$CRLF" .
            "URI: $URL$CRLF" .
                "Connection: close$CRLF" .
                    "Content-type: text/html$CRLF$CRLF";
}

sub closeConnection {
    my $self = shift;
    my $CLIENT = $self->Client;

    if($CLIENT && ($CLIENT != \*STDOUT)) { $CLIENT->close(); }
}

sub closeServer {
    my $self = shift;
    $self->closeConnection();
    my(@files,$t);
    my $SERVER = $self->Server;
    
    push @files, "$self->{conf}{socketdir}/$$";
    
    if($SERVER && ($SERVER != \*STDOUT)) { $SERVER->close(); }
    opendir(D, $self->{conf}{socketdir});
    while($_ = readdir(D)) {
	next unless /^\d+$/;
	$t = -A "$self->{conf}{socketdir}/$_";
	if(($t*72000) > ($self->{conf}{timeout} * 1.25)) {
	    push @files, "$self->{conf}{socketdir}/$_";	    
	}
    }
    unlink @files;
    exit(0);
}

###################################
# Multipart/MIME POST query handler #
#####################################

#
# All of this has been brazenly stolen from CGI.pm
#

sub handleStupidMime {
    my($self, $queryHashRef) = @_;

    my $BUFFER = MultipartBuffer->new($queryHashRef->{BOUNDARY},
                                      $queryHashRef->{CONTENT_LENGTH},
                                      $self->{CLIENT});
    return unless $BUFFER;

    my(%Header, $Body);
    while(!$BUFFER->eof()) {
        %Header = $BUFFER->readHeader();
        die "Malformed multipart POST\n" unless %Header;
        my $key = $Header{'Content-disposition'} ? 'Content-disposition' :
            'Content-Disposition';
        my($param) = $Header{$key} =~ / name="([^\"]*)"/;
        my($filename) = $Header{$key} =~ / filename="(.*)"$/;

        unless ($filename) {
            my($value) = $BUFFER->readBody;
            push(@{$queryHashRef->{$param}}, $value);
            next;
        }

        &{$self->{FILEHANDLER}}('NEW', $filename);
        while (my $buff = $BUFFER->do_read) { 
	    &{$self->{FILEHANDLER}}('PUT', $buff);
	    alarm($self->{conf}{timeout});
	}
        &{$self->{FILEHANDLER}}('CLOSE');
    }
}

##
## Behold: a new package!
##

# Globals and stubs for other packages that we use
package MultipartBuffer;

# how many bytes to read at a time.  We use
# a 5K buffer by default.
my $FILLUNIT = 1024 * 5;
my $TIMEOUT = 10*60;       # 10 minute timeout
my $SPIN_LOOP_MAX = 1000;  # bug fix for some Netscape servers
#my $CRLF = "\015\012";

use Carp;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    unless(@_ == 3) {
        confess "usage: MultipartBuffer->new(boundary, length, filehandle)";
    }
    my($boundary,$length,$IN) = @_;

    # Under the MIME spec, the boundary consists of the 
    # characters "--" PLUS the Boundary string
    $boundary = "--$boundary";
    # Read the topmost (boundary) line plus the CRLF
    my($null) = '';
    $length -= read($IN,$null,length($boundary)+2,0);

    my $self = {LENGTH=>$length,
                BOUNDARY=>$boundary,
                IN=>$IN,
                BUFFER=>'',
            };

    $FILLUNIT = length($boundary) if length($boundary) > $FILLUNIT;

    bless($self, $class);
    return $self;
}

sub readHeader {
    my($self) = @_;
    my($end);
    my($ok) = 0;
    my($bad) = 0;
    do {
        $self->fillBuffer($FILLUNIT);
        $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
        $ok++ if $self->{BUFFER} eq '';
        $bad++ if !$ok && $self->{LENGTH} <= 0;
        $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; 
    } until $ok || $bad;
    return () if $bad;

    my($header) = substr($self->{BUFFER},0,$end+2);
    substr($self->{BUFFER},0,$end+4) = '';
    my %return;
    while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
        $return{$1}=$2;
    }
    return %return;
}

sub readBody {
    my($self) = @_;
    my($data);
    my($returnval)='';
    while (defined($data = $self->do_read)) {
        $returnval .= $data;
    }
    return $returnval;
}

sub do_read {
    my($self,$bytes) = @_;

    # default number of bytes to read
    $bytes = $bytes || $FILLUNIT;       

    # Fill up our internal buffer in such a way that the boundary
    # is never split between reads.
    $self->fillBuffer($bytes);

    # Find the boundary in the buffer (it may not be there).
    my $start = index($self->{BUFFER},$self->{BOUNDARY});
    # protect against malformed multipart POST operations
    die "Malformed multipart POST\n"
        unless ($start >= 0) || ($self->{LENGTH} > 0);

    # If the boundary begins the data, then skip past it
    # and return undef.  The +2 here is a fiendish plot to
    # remove the CR/LF pair at the end of the boundary.
    if ($start == 0) {

        # clear us out completely if we've hit the last boundary.
        if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
            $self->{BUFFER}='';
            $self->{LENGTH}=0;
            return undef;
        }

        # just remove the boundary.
        substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
        return undef;
    }

    my $bytesToReturn;    
    if ($start > 0) {           # read up to the boundary
        $bytesToReturn = $start > $bytes ? $bytes : $start;
    } else {    # read the requested number of bytes
        # leave enough bytes in the buffer to allow us to read
        # the boundary.  Thanks to Kevin Hendrick for finding
        # this one.
        $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
    }

    my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
    substr($self->{BUFFER},0,$bytesToReturn)='';
    
    # If we hit the boundary, remove the CRLF from the end.
    return ($start > 0) ? substr($returnval,0,-2) : $returnval;
}

sub fillBuffer {
    my($self,$bytes) = @_;
    return unless $self->{LENGTH};

    my($boundaryLength) = length($self->{BOUNDARY});
    my($bufferLength) = length($self->{BUFFER});
    my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
    $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;

    # Try to read some data.  We may hang here if the browser is screwed up.  
    my $bytesRead = read($self->{IN},
                         $self->{BUFFER},
                         $bytesToRead,
                         $bufferLength);

    # An apparent bug in the Apache server causes the read()
    # to return zero bytes repeatedly without blocking if the
    # remote user aborts during a file transfer.  I don't know how
    # they manage this, but the workaround is to abort if we get
    # more than SPIN_LOOP_MAX consecutive zero reads.
    if ($bytesRead == 0) {
        die "Socket closed during multipart read!\n"
            if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
    } else {
        $self->{ZERO_LOOP_COUNTER}=0;
    }

    $self->{LENGTH} -= $bytesRead;
}

sub eof {
    my($self) = @_;
    return 1 if (length($self->{BUFFER}) == 0)
        && ($self->{LENGTH} <= 0);
    undef;
}