mirror of
https://github.com/moparisthebest/curl
synced 2024-11-10 11:35:07 -05:00
39cc424e81
be contributing 90 additional seconds to the total time some autobuilds now need to make a full test-run.
1148 lines
30 KiB
Perl
1148 lines
30 KiB
Perl
#!/usr/bin/env perl
|
|
#***************************************************************************
|
|
# _ _ ____ _
|
|
# Project ___| | | | _ \| |
|
|
# / __| | | | |_) | |
|
|
# | (__| |_| | _ <| |___
|
|
# \___|\___/|_| \_\_____|
|
|
#
|
|
# Copyright (C) 1998 - 2009, 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.
|
|
#
|
|
# $Id$
|
|
###########################################################################
|
|
|
|
# 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.
|
|
#
|
|
# 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.
|
|
#
|
|
|
|
use strict;
|
|
use IPC::Open2;
|
|
|
|
require "getpart.pm";
|
|
require "ftp.pm";
|
|
|
|
#BEGIN {
|
|
# if($] > 5.006) {
|
|
# use Time::HiRes qw( gettimeofday );
|
|
# }
|
|
#}
|
|
|
|
my $ftpdnum="";
|
|
|
|
my $logfilename = 'log/logfile.log'; # Override this for each test server
|
|
|
|
#######################################################################
|
|
# getlogfilename returns a log file name depending on given arguments.
|
|
#
|
|
sub getlogfilename {
|
|
my ($proto, $ipversion, $ssl, $instance, $sockfilter) = @_;
|
|
my $filename;
|
|
|
|
# For now, simply mimic old behavior.
|
|
$filename = "log/ftpd$ftpdnum.log";
|
|
|
|
return $filename;
|
|
}
|
|
|
|
#######################################################################
|
|
# logmsg is general message logging subroutine for our test servers.
|
|
#
|
|
sub logmsg {
|
|
my $now;
|
|
# if($] > 5.006) {
|
|
# 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, ">>$logfilename")) {
|
|
print LOGFILEFH $now;
|
|
print LOGFILEFH @_;
|
|
close(LOGFILEFH);
|
|
}
|
|
}
|
|
|
|
sub ftpmsg {
|
|
# append to the server.input file
|
|
open(INPUT, ">>log/server$ftpdnum.input") ||
|
|
logmsg "failed to open log/server$ftpdnum.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
|
|
}
|
|
|
|
my $verbose=0; # set to 1 for debugging
|
|
my $pasvbadip=0;
|
|
my $retrweirdo=0;
|
|
my $retrnosize=0;
|
|
my $srcdir=".";
|
|
my $nosave=0;
|
|
my $controldelay=0; # set to 1 to delay the control connect data sending to
|
|
# test that curl deals with that nicely
|
|
my $slavepid; # for the DATA connection sockfilt slave process
|
|
my $ipv6;
|
|
my $ext; # append to log/pid file names
|
|
my $grok_eprt;
|
|
my $port = 8921; # just a default
|
|
my $listenaddr = "127.0.0.1"; # just a default
|
|
my $pidfile = ".ftpd.pid"; # a default, use --pidfile
|
|
|
|
my $SERVERLOGS_LOCK="log/serverlogs.lock"; # server logs advisor read lock
|
|
my $serverlogslocked=0;
|
|
|
|
my $proto="ftp";
|
|
|
|
do {
|
|
if($ARGV[0] eq "-v") {
|
|
$verbose=1;
|
|
}
|
|
elsif($ARGV[0] eq "-s") {
|
|
$srcdir=$ARGV[1];
|
|
shift @ARGV;
|
|
}
|
|
elsif($ARGV[0] eq "--id") {
|
|
$ftpdnum=$ARGV[1];
|
|
shift @ARGV;
|
|
}
|
|
elsif($ARGV[0] eq "--proto") {
|
|
# ftp pop3 imap smtp
|
|
$proto=$ARGV[1];
|
|
shift @ARGV;
|
|
}
|
|
elsif($ARGV[0] eq "--pidfile") {
|
|
$pidfile=$ARGV[1];
|
|
shift @ARGV;
|
|
}
|
|
elsif($ARGV[0] eq "--ipv6") {
|
|
$ipv6="--ipv6";
|
|
$ext="ipv6";
|
|
$grok_eprt = 1;
|
|
}
|
|
elsif($ARGV[0] eq "--port") {
|
|
$port = $ARGV[1];
|
|
shift @ARGV;
|
|
}
|
|
elsif($ARGV[0] eq "--addr") {
|
|
$listenaddr = $ARGV[1];
|
|
$listenaddr =~ s/^\[(.*)\]$/$1/;
|
|
shift @ARGV;
|
|
}
|
|
} while(shift @ARGV);
|
|
|
|
# a dedicated protocol has been selected, check that it's a fine one
|
|
if($proto !~ /^(ftp|imap|pop3|smtp)\z/) {
|
|
die "unsupported protocol selected";
|
|
}
|
|
|
|
sub catch_zap {
|
|
my $signame = shift;
|
|
ftpkillslaves($verbose);
|
|
unlink($pidfile);
|
|
if($serverlogslocked) {
|
|
$serverlogslocked = 0;
|
|
clear_advisor_read_lock($SERVERLOGS_LOCK);
|
|
}
|
|
exit;
|
|
}
|
|
$SIG{INT} = \&catch_zap;
|
|
$SIG{TERM} = \&catch_zap;
|
|
|
|
my $sfpid;
|
|
|
|
local(*SFREAD, *SFWRITE);
|
|
|
|
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: ftp$ftpdnum$ext sysread error: $!\n";
|
|
killpid($verbose, $sfpid);
|
|
logmsg "Exited from sysread_or_die() at $fcaller " .
|
|
"line $lcaller. ftp$ftpdnum$ext sysread error: $!\n";
|
|
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: ftp$ftpdnum$ext read zero\n";
|
|
killpid($verbose, $sfpid);
|
|
logmsg "Exited from sysread_or_die() at $fcaller " .
|
|
"line $lcaller. ftp$ftpdnum$ext read zero\n";
|
|
unlink($pidfile);
|
|
if($serverlogslocked) {
|
|
$serverlogslocked = 0;
|
|
clear_advisor_read_lock($SERVERLOGS_LOCK);
|
|
}
|
|
exit;
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
|
|
sub startsf {
|
|
my $cmd="./server/sockfilt --port $port --logfile log/sockctrl$ftpdnum$ext.log --pidfile .sockfilt$ftpdnum$ext.pid $ipv6";
|
|
$sfpid = open2(*SFREAD, *SFWRITE, $cmd);
|
|
|
|
print STDERR "$cmd\n" if($verbose);
|
|
|
|
print SFWRITE "PING\n";
|
|
my $pong;
|
|
sysread SFREAD, $pong, 5;
|
|
|
|
if($pong !~ /^PONG/) {
|
|
logmsg "Failed sockfilt command: $cmd\n";
|
|
killpid($verbose, $sfpid);
|
|
unlink($pidfile);
|
|
if($serverlogslocked) {
|
|
$serverlogslocked = 0;
|
|
clear_advisor_read_lock($SERVERLOGS_LOCK);
|
|
}
|
|
die "Failed to start sockfilt!";
|
|
}
|
|
}
|
|
|
|
$logfilename = getlogfilename();
|
|
|
|
startsf();
|
|
|
|
logmsg sprintf("%s server listens on port IPv%d/$port\n", uc($proto),
|
|
$ipv6?6:4);
|
|
open(PID, ">$pidfile");
|
|
print PID $$."\n";
|
|
close(PID);
|
|
|
|
logmsg("logged pid $$ in $pidfile\n");
|
|
|
|
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(!$controldelay) {
|
|
# 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(!$controldelay) {
|
|
# spit it all out at once
|
|
sockfiltsecondary $l;
|
|
}
|
|
else {
|
|
# pause between each byte
|
|
for (split(//,$l)) {
|
|
sockfiltsecondary $_;
|
|
select(undef, undef, undef, 0.01);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
my %displaytext;
|
|
my %commandfunc;
|
|
|
|
# callback functions for certain commands
|
|
# and text shown before the function specified below is run
|
|
|
|
if($proto eq "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',
|
|
);
|
|
|
|
%commandfunc = ( 'PORT' => \&PORT_command,
|
|
'EPRT' => \&PORT_command,
|
|
'LIST' => \&LIST_command,
|
|
'NLST' => \&NLST_command,
|
|
'PASV' => \&PASV_command,
|
|
'EPSV' => \&PASV_command,
|
|
'RETR' => \&RETR_command,
|
|
'SIZE' => \&SIZE_command,
|
|
'REST' => \&REST_command,
|
|
'STOR' => \&STOR_command,
|
|
'APPE' => \&STOR_command, # append looks like upload
|
|
'MDTM' => \&MDTM_command,
|
|
);
|
|
}
|
|
elsif($proto eq "pop3") {
|
|
%commandfunc = ('RETR' => \&RETR_pop3,
|
|
);
|
|
|
|
%displaytext = ('USER' => '+OK We are happy you popped in!',
|
|
'PASS' => '+OK Access granted',
|
|
'QUIT' => '+OK byebye',
|
|
);
|
|
|
|
}
|
|
elsif($proto eq "imap") {
|
|
%commandfunc = ('FETCH' => \&FETCH_imap,
|
|
);
|
|
|
|
%displaytext = ('LOGIN' => ' OK We are happy you popped in!',
|
|
'SELECT' => ' OK selection done',
|
|
);
|
|
|
|
}
|
|
|
|
|
|
sub close_dataconn {
|
|
my ($closed)=@_; # non-zero if already disconnected
|
|
|
|
if(!$closed) {
|
|
logmsg "* disconnect data connection\n";
|
|
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 $slavepid)\n";
|
|
print DWRITE "QUIT\n";
|
|
waitpid $slavepid, 0;
|
|
$slavepid=0;
|
|
}
|
|
|
|
################
|
|
################ IMAP commands
|
|
################
|
|
|
|
sub FETCH_imap {
|
|
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;
|
|
}
|
|
|
|
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_command {
|
|
$rest = $_[0];
|
|
logmsg "Set REST position to $rest\n"
|
|
}
|
|
|
|
sub LIST_command {
|
|
# 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_command {
|
|
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_command {
|
|
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 <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_command {
|
|
my $testno = $_[0];
|
|
my $testpart = "";
|
|
if ($testno > 10000) {
|
|
$testpart = $testno % 10000;
|
|
$testno = int($testno / 10000);
|
|
}
|
|
|
|
loadtest("$srcdir/data/test$testno");
|
|
|
|
if($testno eq "verifiedserver") {
|
|
my $response = "WE ROOLZ: $$\r\n";
|
|
my $size = length($response);
|
|
sendcontrol "213 $size\r\n";
|
|
return 0;
|
|
}
|
|
|
|
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_command {
|
|
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_command {
|
|
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;
|
|
|
|
#print STDERR " GOT: $i";
|
|
|
|
my $size = hex($i);
|
|
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_command {
|
|
my ($arg, $cmd)=@_;
|
|
my $pasvport;
|
|
my $pidf=".sockdata$ftpdnum$ext.pid";
|
|
|
|
my $prev = processexists($pidf);
|
|
if($prev > 0) {
|
|
print "kill existing server: $prev\n" if($verbose);
|
|
killpid($verbose, $prev);
|
|
}
|
|
|
|
# We fire up a new sockfilt to do the data transfer for us.
|
|
$slavepid = open2(\*DREAD, \*DWRITE,
|
|
"./server/sockfilt --port 0 --logfile log/sockdata$ftpdnum$ext.log --pidfile $pidf $ipv6");
|
|
|
|
print DWRITE "PING\n";
|
|
my $pong;
|
|
|
|
sysread_or_die(\*DREAD, \$pong, 5);
|
|
|
|
if($pong !~ /^PONG/) {
|
|
killpid($verbose, $slavepid);
|
|
sendcontrol "500 no free ports!\r\n";
|
|
logmsg "failed to run sockfilt for data connection\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 = hex($i);
|
|
|
|
# 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 ($controldelay?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
|
|
|
|
print DWRITE "QUIT\n";
|
|
waitpid $slavepid, 0;
|
|
logmsg "accept failed\n";
|
|
$slavepid=0;
|
|
return;
|
|
}
|
|
else {
|
|
logmsg "data connection setup on port $pasvport\n";
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# Support both PORT and EPRT here. Consider LPRT too.
|
|
|
|
sub PORT_command {
|
|
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.
|
|
# FIX: make it use IPv6 if need be
|
|
my $filtcmd="./server/sockfilt --connect $port --addr $addr --logfile log/sockdata$ftpdnum$ext.log --pidfile .sockdata$ftpdnum$ext.pid $ipv6";
|
|
$slavepid = open2(\*DREAD, \*DWRITE, $filtcmd);
|
|
|
|
print STDERR "$filtcmd\n" if($verbose);
|
|
|
|
print DWRITE "PING\n";
|
|
my $pong;
|
|
sysread DREAD, $pong, 5;
|
|
|
|
if($pong !~ /^PONG/) {
|
|
logmsg "Failed sockfilt for data connection\n";
|
|
killpid($verbose, $slavepid);
|
|
}
|
|
|
|
logmsg "====> Client DATA connect to port $port\n";
|
|
|
|
return;
|
|
}
|
|
|
|
my %customreply;
|
|
my %customcount;
|
|
my %delayreply;
|
|
sub customize {
|
|
$nosave = 0; # default is to save as normal
|
|
$controldelay = 0; # default is no delaying the responses
|
|
$retrweirdo = 0;
|
|
$retrnosize = 0;
|
|
$pasvbadip = 0;
|
|
$nosave = 0;
|
|
%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/) {
|
|
$controldelay=1;
|
|
logmsg "FTPD: send response with 0.1 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);
|
|
}
|
|
|
|
my @welcome;
|
|
|
|
if($proto eq "ftp") {
|
|
@welcome=(
|
|
'220- _ _ ____ _ '."\r\n",
|
|
'220- ___| | | | _ \| | '."\r\n",
|
|
'220- / __| | | | |_) | | '."\r\n",
|
|
'220- | (__| |_| | _ <| |___ '."\r\n",
|
|
'220 \___|\___/|_| \_\_____|'."\r\n");
|
|
}
|
|
elsif($proto eq "pop3") {
|
|
@welcome=(
|
|
' _ _ ____ _ '."\r\n",
|
|
' ___| | | | _ \| | '."\r\n",
|
|
' / __| | | | |_) | | '."\r\n",
|
|
' | (__| |_| | _ <| |___ '."\r\n",
|
|
' \___|\___/|_| \_\_____|'."\r\n",
|
|
'+OK cURL POP3 server ready to serve'."\r\n");
|
|
}
|
|
elsif($proto eq "imap") {
|
|
@welcome=(
|
|
' _ _ ____ _ '."\r\n",
|
|
' ___| | | | _ \| | '."\r\n",
|
|
' / __| | | | |_) | | '."\r\n",
|
|
' | (__| |_| | _ <| |___ '."\r\n",
|
|
' \___|\___/|_| \_\_____|'."\r\n",
|
|
'* OK cURL IMAP server ready to serve'."\r\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;
|
|
|
|
killpid($verbose, $slavepid);
|
|
$slavepid=0;
|
|
|
|
&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 = hex($i);
|
|
|
|
# data
|
|
sysread SFREAD, $_, $size;
|
|
|
|
ftpmsg $_;
|
|
|
|
# Remove trailing CRLF.
|
|
s/[\n\r]+$//;
|
|
|
|
my $cmdid;
|
|
my $FTPCMD;
|
|
my $FTPARG;
|
|
my $full=$_;
|
|
if($proto eq "imap") {
|
|
# IMAP is different with its identifier first on the command line
|
|
unless (m/^([^ ]+) ([^ ]+) (.*)/i) {
|
|
sendcontrol "500 '$_': command not understood.\r\n";
|
|
last;
|
|
}
|
|
$cmdid=$1;
|
|
$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");
|
|
sleep($delay);
|
|
}
|
|
|
|
my $text;
|
|
$text = $customreply{$FTPCMD};
|
|
my $fake = $text;
|
|
if($text eq "") {
|
|
$text = $displaytext{$FTPCMD};
|
|
}
|
|
else {
|
|
if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
|
|
# used enough number of times, now blank the customreply
|
|
$customreply{$FTPCMD}="";
|
|
}
|
|
}
|
|
my $check;
|
|
if($text) {
|
|
sendcontrol "$cmdid$text\r\n";
|
|
}
|
|
else {
|
|
$check=1; # no response yet
|
|
}
|
|
|
|
if($fake eq "") {
|
|
# 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);
|
|
}
|
|
}
|
|
|
|
print SFWRITE "QUIT\n";
|
|
waitpid $sfpid, 0;
|
|
|
|
unlink($pidfile);
|
|
|
|
if($serverlogslocked) {
|
|
$serverlogslocked = 0;
|
|
clear_advisor_read_lock($SERVERLOGS_LOCK);
|
|
}
|
|
|
|
exit;
|