moparisthebest/curl
1
0
Fork 0
mirror of https://github.com/moparisthebest/curl synced 2024-11-16 14:35:03 -05:00
Code Issues Releases Wiki Activity
78b284014b
curl/tests/ftpserver.pl
Daniel Stenberg be28825b2d restore executable bits on some files
2010-03-24 11:07:35 +01:00

1465 lines
40 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/env perl
#***************************************************************************
# _ _ ____ _
# Project ___| | | | _ \| |
# / __| | | | |_) | |
# | (__| |_| | _ <| |___
# \___|\___/|_| \_\_____|
#
# Copyright (C) 1998 - 2010, Daniel Stenberg, <daniel@haxx.se>, et al.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution. The terms
# are also available at http://curl.haxx.se/docs/copyright.html.
#
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
# copies of the Software, and permit persons to whom the Software is
# furnished to do so, under the terms of the COPYING file.
#
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
# KIND, either express or implied.
#
###########################################################################
# This is a server designed for the curl test suite.
#
# In December 2009 we started remaking the server to support more protocols
# that are similar in spirit. Like POP3, IMAP and SMTP in addition to the FTP
# it already supported since a long time. Note that it still only supports one
# protocol per invoke. You need to start mulitple servers to support multiple
# protocols simultaneously.
#
# It is meant to exercise curl, it is not meant to be a fully working
# or even very standard compliant server.
#
# You may optionally specify port on the command line, otherwise it'll
# default to port 8921.
#
# All socket/network/TCP related stuff is done by the 'sockfilt' program.
#
BEGIN {
@INC=(@INC, $ENV{'srcdir'}, '.');
# sub second timestamping needs Time::HiRes
eval {
no warnings "all";
require Time::HiRes;
import Time::HiRes qw( gettimeofday );
}
}
use strict;
use warnings;
use IPC::Open2;
require "getpart.pm";
require "ftp.pm";
use serverhelp qw(
servername_str
server_pidfilename
server_logfilename
mainsockf_pidfilename
mainsockf_logfilename
datasockf_pidfilename
datasockf_logfilename
);
#**********************************************************************
# global vars...
#
my $verbose = 0; # set to 1 for debugging
my $idstr = ""; # server instance string
my $idnum = 1; # server instance number
my $ipvnum = 4; # server IPv number (4 or 6)
my $proto = 'ftp'; # default server protocol
my $srcdir; # directory where ftpserver.pl is located
my $srvrname; # server name for presentation purposes
my $grok_eprt;
my $path = '.';
my $logdir = $path .'/log';
#**********************************************************************
# global vars used for server address and primary listener port
#
my $port = 8921; # default primary listener port
my $listenaddr = '127.0.0.1'; # default address for listener port
#**********************************************************************
# global vars used for file names
#
my $pidfile; # server pid file name
my $logfile; # server log file name
my $mainsockf_pidfile; # pid file for primary connection sockfilt process
my $mainsockf_logfile; # log file for primary connection sockfilt process
my $datasockf_pidfile; # pid file for secondary connection sockfilt process
my $datasockf_logfile; # log file for secondary connection sockfilt process
#**********************************************************************
# global vars used for server logs advisor read lock handling
#
my $SERVERLOGS_LOCK = 'log/serverlogs.lock';
my $serverlogslocked = 0;
#**********************************************************************
# global vars used for child processes PID tracking
#
my $sfpid; # PID for primary connection sockfilt process
my $slavepid; # PID for secondary connection sockfilt process
#**********************************************************************
# global typeglob filehandle vars to read/write from/to sockfilters
#
local *SFREAD; # used to read from primary connection
local *SFWRITE; # used to write to primary connection
local *DREAD; # used to read from secondary connection
local *DWRITE; # used to write to secondary connection
#**********************************************************************
# global vars which depend on server protocol selection
#
my %commandfunc; # protocol command specific function callbacks
my %displaytext; # text returned to client before callback runs
my @welcome; # text returned to client upon connection
#**********************************************************************
# global vars customized for each test from the server commands file
#
my $ctrldelay; # set if server should throttle ctrl stream
my $datadelay; # set if server should throttle data stream
my $retrweirdo; # set if ftp server should use RETRWEIRDO
my $retrnosize; # set if ftp server should use RETRNOSIZE
my $pasvbadip; # set if ftp server should use PASVBADIP
my $nosave; # set if ftp server should not save uploaded data
my %customreply; #
my %customcount; #
my %delayreply; #
#**********************************************************************
# global vars used for signal handling
#
my $got_exit_signal = 0; # set if program should finish execution ASAP
my $exit_signal; # first signal handled in exit_signal_handler
#**********************************************************************
# exit_signal_handler will be triggered to indicate that the program
# should finish its execution in a controlled way as soon as possible.
# For now, program will also terminate from within this handler.
#
sub exit_signal_handler {
my $signame = shift;
# For now, simply mimic old behavior.
killsockfilters($proto, $ipvnum, $idnum, $verbose);
unlink($pidfile);
if($serverlogslocked) {
$serverlogslocked = 0;
clear_advisor_read_lock($SERVERLOGS_LOCK);
}
exit;
}
#**********************************************************************
# logmsg is general message logging subroutine for our test servers.
#
sub logmsg {
my $now;
# sub second timestamping needs Time::HiRes
if($Time::HiRes::VERSION) {
my ($seconds, $usec) = gettimeofday();
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($seconds);
$now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec);
}
else {
my $seconds = time();
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($seconds);
$now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
}
if(open(LOGFILEFH, ">>$logfile")) {
print LOGFILEFH $now;
print LOGFILEFH @_;
close(LOGFILEFH);
}
}
sub ftpmsg {
# append to the server.input file
open(INPUT, ">>log/server$idstr.input") ||
logmsg "failed to open log/server$idstr.input\n";
print INPUT @_;
close(INPUT);
# use this, open->print->close system only to make the file
# open as little as possible, to make the test suite run
# better on windows/cygwin
}
sub sysread_or_die {
my $FH = shift;
my $scalar = shift;
my $length = shift;
my $fcaller;
my $lcaller;
my $result;
$result = sysread($$FH, $$scalar, $length);
if(not defined $result) {
($fcaller, $lcaller) = (caller)[1,2];
logmsg "Failed to read input\n";
logmsg "Error: $srvrname server, sysread error: $!\n";
logmsg "Exited from sysread_or_die() at $fcaller " .
"line $lcaller. $srvrname server, sysread error: $!\n";
killsockfilters($proto, $ipvnum, $idnum, $verbose);
unlink($pidfile);
if($serverlogslocked) {
$serverlogslocked = 0;
clear_advisor_read_lock($SERVERLOGS_LOCK);
}
exit;
}
elsif($result == 0) {
($fcaller, $lcaller) = (caller)[1,2];
logmsg "Failed to read input\n";
logmsg "Error: $srvrname server, read zero\n";
logmsg "Exited from sysread_or_die() at $fcaller " .
"line $lcaller. $srvrname server, read zero\n";
killsockfilters($proto, $ipvnum, $idnum, $verbose);
unlink($pidfile);
if($serverlogslocked) {
$serverlogslocked = 0;
clear_advisor_read_lock($SERVERLOGS_LOCK);
}
exit;
}
return $result;
}
sub startsf {
my $mainsockfcmd = "./server/sockfilt " .
"--ipv$ipvnum --port $port " .
"--pidfile \"$mainsockf_pidfile\" " .
"--logfile \"$mainsockf_logfile\"";
$sfpid = open2(*SFREAD, *SFWRITE, $mainsockfcmd);
print STDERR "$mainsockfcmd\n" if($verbose);
print SFWRITE "PING\n";
my $pong;
sysread_or_die(\*SFREAD, \$pong, 5);
if($pong !~ /^PONG/) {
logmsg "Failed sockfilt command: $mainsockfcmd\n";
killsockfilters($proto, $ipvnum, $idnum, $verbose);
unlink($pidfile);
if($serverlogslocked) {
$serverlogslocked = 0;
clear_advisor_read_lock($SERVERLOGS_LOCK);
}
die "Failed to start sockfilt!";
}
}
sub sockfilt {
my $l;
foreach $l (@_) {
printf SFWRITE "DATA\n%04x\n", length($l);
print SFWRITE $l;
}
}
sub sockfiltsecondary {
my $l;
foreach $l (@_) {
printf DWRITE "DATA\n%04x\n", length($l);
print DWRITE $l;
}
}
# Send data to the client on the control stream, which happens to be plain
# stdout.
sub sendcontrol {
if(!$ctrldelay) {
# spit it all out at once
sockfilt @_;
}
else {
my $a = join("", @_);
my @a = split("", $a);
for(@a) {
sockfilt $_;
select(undef, undef, undef, 0.01);
}
}
my $log;
foreach $log (@_) {
my $l = $log;
$l =~ s/[\r\n]//g;
logmsg "> \"$l\"\n";
}
}
# Send data to the client on the data stream
sub senddata {
my $l;
foreach $l (@_) {
if(!$datadelay) {
# spit it all out at once
sockfiltsecondary $l;
}
else {
# pause between each byte
for (split(//,$l)) {
sockfiltsecondary $_;
select(undef, undef, undef, 0.01);
}
}
}
}
#**********************************************************************
# protocolsetup initializes the 'displaytext' and 'commandfunc' hashes
# for the given protocol. References to protocol command callbacks are
# stored in 'commandfunc' hash, and text which will be returned to the
# client before the command callback runs is stored in 'displaytext'.
#
sub protocolsetup {
my $proto = $_[0];
if($proto eq 'ftp') {
%commandfunc = (
'PORT' => \&PORT_ftp,
'EPRT' => \&PORT_ftp,
'LIST' => \&LIST_ftp,
'NLST' => \&NLST_ftp,
'PASV' => \&PASV_ftp,
'EPSV' => \&PASV_ftp,
'RETR' => \&RETR_ftp,
'SIZE' => \&SIZE_ftp,
'REST' => \&REST_ftp,
'STOR' => \&STOR_ftp,
'APPE' => \&STOR_ftp, # append looks like upload
'MDTM' => \&MDTM_ftp,
);
%displaytext = (
'USER' => '331 We are happy you popped in!',
'PASS' => '230 Welcome you silly person',
'PORT' => '200 You said PORT - I say FINE',
'TYPE' => '200 I modify TYPE as you wanted',
'LIST' => '150 here comes a directory',
'NLST' => '150 here comes a directory',
'CWD' => '250 CWD command successful.',
'SYST' => '215 UNIX Type: L8', # just fake something
'QUIT' => '221 bye bye baby', # just reply something
'PWD' => '257 "/nowhere/anywhere" is current directory',
'MKD' => '257 Created your requested directory',
'REST' => '350 Yeah yeah we set it there for you',
'DELE' => '200 OK OK OK whatever you say',
'RNFR' => '350 Received your order. Please provide more',
'RNTO' => '250 Ok, thanks. File renaming completed.',
'NOOP' => '200 Yes, I\'m very good at doing nothing.',
'PBSZ' => '500 PBSZ not implemented',
'PROT' => '500 PROT not implemented',
);
@welcome = (
'220- _ _ ____ _ '."\r\n",
'220- ___| | | | _ \| | '."\r\n",
'220- / __| | | | |_) | | '."\r\n",
'220- | (__| |_| | _ <| |___ '."\r\n",
'220 \___|\___/|_| \_\_____|'."\r\n"
);
}
elsif($proto eq 'pop3') {
%commandfunc = (
'RETR' => \&RETR_pop3,
);
%displaytext = (
'USER' => '+OK We are happy you popped in!',
'PASS' => '+OK Access granted',
'QUIT' => '+OK byebye',
);
@welcome = (
' _ _ ____ _ '."\r\n",
' ___| | | | _ \| | '."\r\n",
' / __| | | | |_) | | '."\r\n",
' | (__| |_| | _ <| |___ '."\r\n",
' \___|\___/|_| \_\_____|'."\r\n",
'+OK cURL POP3 server ready to serve'."\r\n"
);
}
elsif($proto eq 'imap') {
%commandfunc = (
'FETCH' => \&FETCH_imap,
'SELECT' => \&SELECT_imap,
);
%displaytext = (
'LOGIN' => ' OK We are happy you popped in!',
'SELECT' => ' OK selection done',
'LOGOUT' => ' OK thanks for the fish',
);
@welcome = (
' _ _ ____ _ '."\r\n",
' ___| | | | _ \| | '."\r\n",
' / __| | | | |_) | | '."\r\n",
' | (__| |_| | _ <| |___ '."\r\n",
' \___|\___/|_| \_\_____|'."\r\n",
'* OK cURL IMAP server ready to serve'."\r\n"
);
}
elsif($proto eq 'smtp') {
%commandfunc = (
'DATA' => \&DATA_smtp,
'RCPT' => \&RCPT_smtp,
);
%displaytext = (
'EHLO' => '230 We are happy you popped in!',
'MAIL' => '200 Note taken',
'RCPT' => '200 Receivers accepted',
'QUIT' => '200 byebye',
);
@welcome = (
'220- _ _ ____ _ '."\r\n",
'220- ___| | | | _ \| | '."\r\n",
'220- / __| | | | |_) | | '."\r\n",
'220- | (__| |_| | _ <| |___ '."\r\n",
'220 \___|\___/|_| \_\_____|'."\r\n"
);
}
}
sub close_dataconn {
my ($closed)=@_; # non-zero if already disconnected
my $datapid = processexists($datasockf_pidfile);
if(!$closed) {
logmsg "* disconnect data connection\n";
if($datapid > 0) {
print DWRITE "DISC\n";
my $i;
sysread DREAD, $i, 5;
}
}
else {
logmsg "data connection already disconnected\n";
}
logmsg "=====> Closed data connection\n";
logmsg "* quit sockfilt for data (pid $datapid)\n";
if($datapid > 0) {
print DWRITE "QUIT\n";
waitpid($datapid, 0);
unlink($datasockf_pidfile) if(-f $datasockf_pidfile);
}
}
################
################ SMTP commands
################
# what set by "RCPT"
my $smtp_rcpt;
sub DATA_smtp {
my $testno;
if($smtp_rcpt =~ /^TO:(.*)/) {
$testno = $1;
}
else {
return; # failure
}
if($testno eq "<verifiedserver>") {
sendcontrol "554 WE ROOLZ: $$\r\n";
return 0; # don't wait for data now
}
else {
$testno =~ s/^([^0-9]*)([0-9]+).*/$2/;
sendcontrol "354 Show me the mail\r\n";
}
logmsg "===> rcpt $testno was $smtp_rcpt\n";
my $filename = "log/upload.$testno";
logmsg "Store test number $testno in $filename\n";
open(FILE, ">$filename") ||
return 0; # failed to open output
my $line;
my $ulsize=0;
my $disc=0;
my $raw;
while (5 == (sysread \*SFREAD, $line, 5)) {
if($line eq "DATA\n") {
my $i;
my $eob;
sysread \*SFREAD, $i, 5;
my $size = 0;
if($i =~ /^([0-9a-fA-F]{4})\n/) {
$size = hex($1);
}
sysread \*SFREAD, $line, $size;
$ulsize += $size;
print FILE $line if(!$nosave);
$raw .= $line;
if($raw =~ /\x0d\x0a\x2e\x0d\x0a/) {
# end of data marker!
$eob = 1;
}
logmsg "> Appending $size bytes to file\n";
if($eob) {
logmsg "Found SMTP EOB marker\n";
last;
}
}
elsif($line eq "DISC\n") {
# disconnect!
$disc=1;
last;
}
else {
logmsg "No support for: $line";
last;
}
}
if($nosave) {
print FILE "$ulsize bytes would've been stored here\n";
}
close(FILE);
sendcontrol "250 OK, data received!\r\n";
logmsg "received $ulsize bytes upload\n";
}
sub RCPT_smtp {
my ($args) = @_;
$smtp_rcpt = $args;
}
################
################ IMAP commands
################
# global to allow the command functions to read it
my $cmdid;
# what was picked by SELECT
my $selected;
sub SELECT_imap {
my ($testno) = @_;
my @data;
my $size;
logmsg "SELECT_imap got test $testno\n";
$selected = $testno;
return 0;
}
sub FETCH_imap {
my ($testno) = @_;
my @data;
my $size;
logmsg "FETCH_imap got test $testno\n";
$testno = $selected;
if($testno =~ /^verifiedserver$/) {
# this is the secret command that verifies that this actually is
# the curl test server
my $response = "WE ROOLZ: $$\r\n";
if($verbose) {
print STDERR "FTPD: We returned proof we are the test server\n";
}
$data[0] = $response;
logmsg "return proof we are we\n";
}
else {
logmsg "retrieve a mail\n";
$testno =~ s/^([^0-9]*)//;
my $testpart = "";
if ($testno > 10000) {
$testpart = $testno % 10000;
$testno = int($testno / 10000);
}
# send mail content
loadtest("$srcdir/data/test$testno");
@data = getpart("reply", "data$testpart");
}
for (@data) {
$size += length($_);
}
sendcontrol "* FETCH starts {$size}\r\n";
for my $d (@data) {
sendcontrol $d;
}
sendcontrol "$cmdid OK FETCH completed\r\n";
return 0;
}
################
################ POP3 commands
################
sub RETR_pop3 {
my ($testno) = @_;
my @data;
if($testno =~ /^verifiedserver$/) {
# this is the secret command that verifies that this actually is
# the curl test server
my $response = "WE ROOLZ: $$\r\n";
if($verbose) {
print STDERR "FTPD: We returned proof we are the test server\n";
}
$data[0] = $response;
logmsg "return proof we are we\n";
}
else {
logmsg "retrieve a mail\n";
$testno =~ s/^([^0-9]*)//;
my $testpart = "";
if ($testno > 10000) {
$testpart = $testno % 10000;
$testno = int($testno / 10000);
}
# send mail content
loadtest("$srcdir/data/test$testno");
@data = getpart("reply", "data$testpart");
}
sendcontrol "+OK Mail transfer starts\r\n";
for my $d (@data) {
sendcontrol $d;
}
# end with the magic 5-byte end of mail marker
sendcontrol "\r\n.\r\n";
return 0;
}
################
################ FTP commands
################
my $rest=0;
sub REST_ftp {
$rest = $_[0];
logmsg "Set REST position to $rest\n"
}
sub LIST_ftp {
# print "150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes)\r\n";
# this is a built-in fake-dir ;-)
my @ftpdir=("total 20\r\n",
"drwxr-xr-x 8 98 98 512 Oct 22 13:06 .\r\n",
"drwxr-xr-x 8 98 98 512 Oct 22 13:06 ..\r\n",
"drwxr-xr-x 2 98 98 512 May 2 1996 .NeXT\r\n",
"-r--r--r-- 1 0 1 35 Jul 16 1996 README\r\n",
"lrwxrwxrwx 1 0 1 7 Dec 9 1999 bin -> usr/bin\r\n",
"dr-xr-xr-x 2 0 1 512 Oct 1 1997 dev\r\n",
"drwxrwxrwx 2 98 98 512 May 29 16:04 download.html\r\n",
"dr-xr-xr-x 2 0 1 512 Nov 30 1995 etc\r\n",
"drwxrwxrwx 2 98 1 512 Oct 30 14:33 pub\r\n",
"dr-xr-xr-x 5 0 1 512 Oct 1 1997 usr\r\n");
logmsg "pass LIST data on data connection\n";
for(@ftpdir) {
senddata $_;
}
close_dataconn(0);
sendcontrol "226 ASCII transfer complete\r\n";
return 0;
}
sub NLST_ftp {
my @ftpdir=("file", "with space", "fake", "..", " ..", "funny", "README");
logmsg "pass NLST data on data connection\n";
for(@ftpdir) {
senddata "$_\r\n";
}
close_dataconn(0);
sendcontrol "226 ASCII transfer complete\r\n";
return 0;
}
sub MDTM_ftp {
my $testno = $_[0];
my $testpart = "";
if ($testno > 10000) {
$testpart = $testno % 10000;
$testno = int($testno / 10000);
}
loadtest("$srcdir/data/test$testno");
my @data = getpart("reply", "mdtm");
my $reply = $data[0];
chomp $reply if($reply);
if($reply && ($reply =~ /^[+-]?\d+$/) && ($reply < 0)) {
sendcontrol "550 $testno: no such file.\r\n";
}
elsif($reply) {
sendcontrol "$reply\r\n";
}
else {
sendcontrol "500 MDTM: no such command.\r\n";
}
return 0;
}
sub SIZE_ftp {
my $testno = $_[0];
if($testno =~ /^verifiedserver$/) {
my $response = "WE ROOLZ: $$\r\n";
my $size = length($response);
sendcontrol "213 $size\r\n";
return 0;
}
if($testno =~ /(\d+)\/?$/) {
$testno = $1;
}
else {
print STDERR "SIZE_ftp: invalid test number: $testno\n";
return 1;
}
my $testpart = "";
if($testno > 10000) {
$testpart = $testno % 10000;
$testno = int($testno / 10000);
}
loadtest("$srcdir/data/test$testno");
my @data = getpart("reply", "size");
my $size = $data[0];
if($size) {
if($size > -1) {
sendcontrol "213 $size\r\n";
}
else {
sendcontrol "550 $testno: No such file or directory.\r\n";
}
}
else {
$size=0;
@data = getpart("reply", "data$testpart");
for(@data) {
$size += length($_);
}
if($size) {
sendcontrol "213 $size\r\n";
}
else {
sendcontrol "550 $testno: No such file or directory.\r\n";
}
}
return 0;
}
sub RETR_ftp {
my ($testno) = @_;
if($testno =~ /^verifiedserver$/) {
# this is the secret command that verifies that this actually is
# the curl test server
my $response = "WE ROOLZ: $$\r\n";
my $len = length($response);
sendcontrol "150 Binary junk ($len bytes).\r\n";
senddata "WE ROOLZ: $$\r\n";
close_dataconn(0);
sendcontrol "226 File transfer complete\r\n";
if($verbose) {
print STDERR "FTPD: We returned proof we are the test server\n";
}
return 0;
}
$testno =~ s/^([^0-9]*)//;
my $testpart = "";
if ($testno > 10000) {
$testpart = $testno % 10000;
$testno = int($testno / 10000);
}
loadtest("$srcdir/data/test$testno");
my @data = getpart("reply", "data$testpart");
my $size=0;
for(@data) {
$size += length($_);
}
my %hash = getpartattr("reply", "data$testpart");
if($size || $hash{'sendzero'}) {
if($rest) {
# move read pointer forward
$size -= $rest;
logmsg "REST $rest was removed from size, makes $size left\n";
$rest = 0; # reset REST offset again
}
if($retrweirdo) {
sendcontrol "150 Binary data connection for $testno () ($size bytes).\r\n",
"226 File transfer complete\r\n";
for(@data) {
my $send = $_;
senddata $send;
}
close_dataconn(0);
$retrweirdo=0; # switch off the weirdo again!
}
else {
my $sz = "($size bytes)";
if($retrnosize) {
$sz = "size?";
}
sendcontrol "150 Binary data connection for $testno () $sz.\r\n";
for(@data) {
my $send = $_;
senddata $send;
}
close_dataconn(0);
sendcontrol "226 File transfer complete\r\n";
}
}
else {
sendcontrol "550 $testno: No such file or directory.\r\n";
}
return 0;
}
sub STOR_ftp {
my $testno=$_[0];
my $filename = "log/upload.$testno";
logmsg "STOR test number $testno in $filename\n";
sendcontrol "125 Gimme gimme gimme!\r\n";
open(FILE, ">$filename") ||
return 0; # failed to open output
my $line;
my $ulsize=0;
my $disc=0;
while (5 == (sysread DREAD, $line, 5)) {
if($line eq "DATA\n") {
my $i;
sysread DREAD, $i, 5;
my $size = 0;
if($i =~ /^([0-9a-fA-F]{4})\n/) {
$size = hex($1);
}
sysread DREAD, $line, $size;
#print STDERR " GOT: $size bytes\n";
$ulsize += $size;
print FILE $line if(!$nosave);
logmsg "> Appending $size bytes to file\n";
}
elsif($line eq "DISC\n") {
# disconnect!
$disc=1;
last;
}
else {
logmsg "No support for: $line";
last;
}
}
if($nosave) {
print FILE "$ulsize bytes would've been stored here\n";
}
close(FILE);
close_dataconn($disc);
logmsg "received $ulsize bytes upload\n";
sendcontrol "226 File transfer complete\r\n";
return 0;
}
sub PASV_ftp {
my ($arg, $cmd)=@_;
my $pasvport;
# kill previous data connection sockfilt when alive
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
# We fire up a new sockfilt to do the data transfer for us.
my $datasockfcmd = "./server/sockfilt " .
"--ipv$ipvnum --port 0 " .
"--pidfile \"$datasockf_pidfile\" " .
"--logfile \"$datasockf_logfile\"";
$slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
print DWRITE "PING\n";
my $pong;
sysread_or_die(\*DREAD, \$pong, 5);
if($pong !~ /^PONG/) {
logmsg "failed to run sockfilt for data connection\n";
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
sendcontrol "500 no free ports!\r\n";
return 0;
}
logmsg "Run sockfilt for data on pid $slavepid\n";
# Find out what port we listen on
my $i;
print DWRITE "PORT\n";
# READ the response code
sysread_or_die(\*DREAD, \$i, 5);
# READ the response size
sysread_or_die(\*DREAD, \$i, 5);
my $size = 0;
if($i =~ /^([0-9a-fA-F]{4})\n/) {
$size = hex($1);
}
# READ the response data
sysread_or_die(\*DREAD, \$i, $size);
# The data is in the format
# IPvX/NNN
if($i =~ /IPv(\d)\/(\d+)/) {
# FIX: deal with IP protocol version
$pasvport = $2;
}
if($cmd ne "EPSV") {
# PASV reply
my $p=$listenaddr;
$p =~ s/\./,/g;
if($pasvbadip) {
$p="1,2,3,4";
}
sendcontrol sprintf("227 Entering Passive Mode ($p,%d,%d)\n",
($pasvport/256), ($pasvport%256));
}
else {
# EPSV reply
sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
}
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
# assume swift operations unless explicitly slow
alarm ($datadelay?20:10);
# Wait for 'CNCT'
my $input;
while(sysread(DREAD, $input, 5)) {
if($input !~ /^CNCT/) {
# we wait for a connected client
logmsg "Odd, we got $input from client\n";
next;
}
logmsg "====> Client DATA connect\n";
last;
}
alarm 0;
};
if ($@) {
# timed out
logmsg "$srvrname server timed out awaiting data connection ".
"on port $pasvport\n";
logmsg "accept failed or connection not even attempted\n";
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
return;
}
else {
logmsg "data connection setup on port $pasvport\n";
}
return;
}
# Support both PORT and EPRT here. Consider LPRT too.
sub PORT_ftp {
my ($arg, $cmd) = @_;
my $port;
my $addr;
# We always ignore the given IP and use localhost.
if($cmd eq "PORT") {
if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
logmsg "bad PORT-line: $arg\n";
sendcontrol "500 silly you, go away\r\n";
return 0;
}
$port = ($5<<8)+$6;
$addr = "$1.$2.$3.$4";
}
# EPRT |2|::1|49706|
elsif(($cmd eq "EPRT") && ($grok_eprt)) {
if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
sendcontrol "500 silly you, go away\r\n";
return 0;
}
sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
$port = $3;
$addr = $2;
}
else {
sendcontrol "500 we don't like $cmd now\r\n";
return 0;
}
if(!$port || $port > 65535) {
print STDERR "very illegal PORT number: $port\n";
return 1;
}
# We fire up a new sockfilt to do the data transfer for us.
my $datasockfcmd = "./server/sockfilt " .
"--ipv$ipvnum --connect $port --addr \"$addr\" " .
"--pidfile \"$datasockf_pidfile\" " .
"--logfile \"$datasockf_logfile\"";
$slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
print STDERR "$datasockfcmd\n" if($verbose);
print DWRITE "PING\n";
my $pong;
sysread_or_die(\*DREAD, \$pong, 5);
if($pong !~ /^PONG/) {
logmsg "Failed sockfilt for data connection\n";
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
}
logmsg "====> Client DATA connect to port $port\n";
return;
}
#**********************************************************************
# customize configures test server operation for each curl test, reading
# configuration commands/parameters from server commands file each time
# a new client control connection is established with the test server.
# On success returns 1, otherwise zero.
#
sub customize {
$ctrldelay = 0; # default is no throttling of the ctrl stream
$datadelay = 0; # default is no throttling of the data stream
$retrweirdo = 0; # default is no use of RETRWEIRDO
$retrnosize = 0; # default is no use of RETRNOSIZE
$pasvbadip = 0; # default is no use of PASVBADIP
$nosave = 0; # default is to actually save uploaded data to file
%customreply = (); #
%customcount = (); #
%delayreply = (); #
open(CUSTOM, "<log/ftpserver.cmd") ||
return 1;
logmsg "FTPD: Getting commands from log/ftpserver.cmd\n";
while(<CUSTOM>) {
if($_ =~ /REPLY ([A-Z]+) (.*)/) {
$customreply{$1}=eval "qq{$2}";
logmsg "FTPD: set custom reply for $1\n";
}
if($_ =~ /COUNT ([A-Z]+) (.*)/) {
# we blank the customreply for this command when having
# been used this number of times
$customcount{$1}=$2;
logmsg "FTPD: blank custom reply for $1 after $2 uses\n";
}
elsif($_ =~ /DELAY ([A-Z]+) (\d*)/) {
$delayreply{$1}=$2;
logmsg "FTPD: delay reply for $1 with $2 seconds\n";
}
elsif($_ =~ /SLOWDOWN/) {
$ctrldelay=1;
$datadelay=1;
logmsg "FTPD: send response with 0.01 sec delay between each byte\n";
}
elsif($_ =~ /RETRWEIRDO/) {
logmsg "FTPD: instructed to use RETRWEIRDO\n";
$retrweirdo=1;
}
elsif($_ =~ /RETRNOSIZE/) {
logmsg "FTPD: instructed to use RETRNOSIZE\n";
$retrnosize=1;
}
elsif($_ =~ /PASVBADIP/) {
logmsg "FTPD: instructed to use PASVBADIP\n";
$pasvbadip=1;
}
elsif($_ =~ /NOSAVE/) {
# don't actually store the file we upload - to be used when
# uploading insanely huge amounts
$nosave = 1;
logmsg "FTPD: NOSAVE prevents saving of uploaded data\n";
}
}
close(CUSTOM);
}
#----------------------------------------------------------------------
#----------------------------------------------------------------------
#--------------------------- END OF SUBS ----------------------------
#----------------------------------------------------------------------
#----------------------------------------------------------------------
#**********************************************************************
# Parse command line options
#
# Options:
#
# --verbose # verbose
# --srcdir # source directory
# --id # server instance number
# --proto # server protocol
# --pidfile # server pid file
# --logfile # server log file
# --ipv4 # server IP version 4
# --ipv6 # server IP version 6
# --port # server listener port
# --addr # server address for listener port binding
#
while(@ARGV) {
if($ARGV[0] eq '--verbose') {
$verbose = 1;
}
elsif($ARGV[0] eq '--srcdir') {
if($ARGV[1]) {
$srcdir = $ARGV[1];
shift @ARGV;
}
}
elsif($ARGV[0] eq '--id') {
if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
$idnum = $1 if($1 > 0);
shift @ARGV;
}
}
elsif($ARGV[0] eq '--proto') {
if($ARGV[1] && ($ARGV[1] =~ /^(ftp|imap|pop3|smtp)$/)) {
$proto = $1;
shift @ARGV;
}
else {
die "unsupported protocol $ARGV[1]";
}
}
elsif($ARGV[0] eq '--pidfile') {
if($ARGV[1]) {
$pidfile = $ARGV[1];
shift @ARGV;
}
}
elsif($ARGV[0] eq '--logfile') {
if($ARGV[1]) {
$logfile = $ARGV[1];
shift @ARGV;
}
}
elsif($ARGV[0] eq '--ipv4') {
$ipvnum = 4;
$listenaddr = '127.0.0.1' if($listenaddr eq '::1');
$grok_eprt = 0;
}
elsif($ARGV[0] eq '--ipv6') {
$ipvnum = 6;
$listenaddr = '::1' if($listenaddr eq '127.0.0.1');
$grok_eprt = 1;
}
elsif($ARGV[0] eq '--port') {
if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
$port = $1 if($1 > 1024);
shift @ARGV;
}
}
elsif($ARGV[0] eq '--addr') {
if($ARGV[1]) {
my $tmpstr = $ARGV[1];
if($tmpstr =~ /^(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)$/) {
$listenaddr = "$1.$2.$3.$4" if($ipvnum == 4);
}
elsif($ipvnum == 6) {
$listenaddr = $tmpstr;
$listenaddr =~ s/^\[(.*)\]$/$1/;
}
shift @ARGV;
}
}
else {
print STDERR "\nWarning: ftpserver.pl unknown parameter: $ARGV[0]\n";
}
shift @ARGV;
}
#***************************************************************************
# Initialize command line option dependant variables
#
if(!$srcdir) {
$srcdir = $ENV{'srcdir'} || '.';
}
if(!$pidfile) {
$pidfile = "$path/". server_pidfilename($proto, $ipvnum, $idnum);
}
if(!$logfile) {
$logfile = server_logfilename($logdir, $proto, $ipvnum, $idnum);
}
$mainsockf_pidfile = "$path/".
mainsockf_pidfilename($proto, $ipvnum, $idnum);
$mainsockf_logfile =
mainsockf_logfilename($logdir, $proto, $ipvnum, $idnum);
if($proto eq 'ftp') {
$datasockf_pidfile = "$path/".
datasockf_pidfilename($proto, $ipvnum, $idnum);
$datasockf_logfile =
datasockf_logfilename($logdir, $proto, $ipvnum, $idnum);
}
$srvrname = servername_str($proto, $ipvnum, $idnum);
$idstr = "$idnum" if($idnum > 1);
protocolsetup($proto);
$SIG{INT} = \&exit_signal_handler;
$SIG{TERM} = \&exit_signal_handler;
startsf();
logmsg sprintf("%s server listens on port IPv${ipvnum}/${port}\n", uc($proto));
open(PID, ">$pidfile");
print PID $$."\n";
close(PID);
logmsg("logged pid $$ in $pidfile\n");
while(1) {
#
# We read 'sockfilt' commands.
#
my $input;
logmsg "Awaiting input\n";
sysread_or_die(\*SFREAD, \$input, 5);
if($input !~ /^CNCT/) {
# we wait for a connected client
logmsg "sockfilt said: $input";
next;
}
logmsg "====> Client connect\n";
set_advisor_read_lock($SERVERLOGS_LOCK);
$serverlogslocked = 1;
# flush data:
$| = 1;
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
&customize(); # read test control instructions
sendcontrol @welcome;
if($verbose) {
for(@welcome) {
print STDERR "OUT: $_";
}
}
while(1) {
my $i;
# Now we expect to read DATA\n[hex size]\n[prot], where the [prot]
# part only is FTP lingo.
# COMMAND
sysread_or_die(\*SFREAD, \$i, 5);
if($i !~ /^DATA/) {
logmsg "sockfilt said $i";
if($i =~ /^DISC/) {
# disconnect
last;
}
next;
}
# SIZE of data
sysread_or_die(\*SFREAD, \$i, 5);
my $size = 0;
if($i =~ /^([0-9a-fA-F]{4})\n/) {
$size = hex($1);
}
# data
sysread SFREAD, $_, $size;
ftpmsg $_;
# Remove trailing CRLF.
s/[\n\r]+$//;
my $FTPCMD;
my $FTPARG;
my $full=$_;
if($proto eq "imap") {
# IMAP is different with its identifier first on the command line
unless (m/^([^ ]+) ([^ ]+) (.*)/ ||
m/^([^ ]+) ([^ ]+)/) {
sendcontrol "$1 '$_': command not understood.\r\n";
last;
}
$cmdid=$1; # set the global variable
$FTPCMD=$2;
$FTPARG=$3;
}
else {
unless (m/^([A-Z]{3,4})\s?(.*)/i) {
sendcontrol "500 '$_': command not understood.\r\n";
last;
}
$FTPCMD=$1;
$FTPARG=$2;
}
logmsg "< \"$full\"\n";
if($verbose) {
print STDERR "IN: $full\n";
}
my $delay = $delayreply{$FTPCMD};
if($delay) {
# just go sleep this many seconds!
logmsg("Sleep for $delay seconds\n");
my $twentieths = $delay * 20;
while($twentieths--) {
select(undef, undef, undef, 0.05) unless($got_exit_signal);
}
}
my $text;
$text = $customreply{$FTPCMD};
my $fake = $text;
if($text && ($text ne "")) {
if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
# used enough number of times, now blank the customreply
$customreply{$FTPCMD}="";
}
}
else {
$text = $displaytext{$FTPCMD};
}
my $check;
if($text && ($text ne "")) {
if($cmdid && ($cmdid ne "")) {
sendcontrol "$cmdid$text\r\n";
}
else {
sendcontrol "$text\r\n";
}
}
else {
$check=1; # no response yet
}
unless($fake && ($fake ne "")) {
# only perform this if we're not faking a reply
my $func = $commandfunc{$FTPCMD};
if($func) {
&$func($FTPARG, $FTPCMD);
$check=0; # taken care of
}
}
if($check) {
logmsg "$FTPCMD wasn't handled!\n";
sendcontrol "500 $FTPCMD is not dealt with!\r\n";
}
} # while(1)
logmsg "====> Client disconnected\n";
if($serverlogslocked) {
$serverlogslocked = 0;
clear_advisor_read_lock($SERVERLOGS_LOCK);
}
}
killsockfilters($proto, $ipvnum, $idnum, $verbose);
unlink($pidfile);
if($serverlogslocked) {
$serverlogslocked = 0;
clear_advisor_read_lock($SERVERLOGS_LOCK);
}
exit;
Reference in New Issue View Git Blame Copy Permalink