mirror of
https://github.com/moparisthebest/curl
synced 2024-11-17 06:55:02 -05:00
acefed139f
Extended the regex to include other valid characters such as those used in the reply text of Test 836.
3243 lines
86 KiB
Perl
Executable File
3243 lines
86 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
#***************************************************************************
|
|
# _ _ ____ _
|
|
# Project ___| | | | _ \| |
|
|
# / __| | | | |_) | |
|
|
# | (__| |_| | _ <| |___
|
|
# \___|\___/|_| \_\_____|
|
|
#
|
|
# Copyright (C) 1998 - 2014, 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 multiple 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 {
|
|
push(@INC, $ENV{'srcdir'}) if(defined $ENV{'srcdir'});
|
|
push(@INC, ".");
|
|
# 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;
|
|
use Digest::MD5;
|
|
|
|
require "getpart.pm";
|
|
require "ftp.pm";
|
|
require "directories.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 $cwd_testno; # test case numbers extracted from CWD command
|
|
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
|
|
|
|
my $sockfilt_timeout = 5; # default timeout for sockfilter eXsysreads
|
|
|
|
#**********************************************************************
|
|
# global vars which depend on server protocol selection
|
|
#
|
|
my %commandfunc; # protocol command specific function callbacks
|
|
my %displaytext; # text returned to client before callback runs
|
|
|
|
#**********************************************************************
|
|
# 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 $nodataconn; # set if ftp srvr doesn't establish or accepts data channel
|
|
my $nodataconn425; # set if ftp srvr doesn't establish data ch and replies 425
|
|
my $nodataconn421; # set if ftp srvr doesn't establish data ch and replies 421
|
|
my $nodataconn150; # set if ftp srvr doesn't establish data ch and replies 150
|
|
my @capabilities; # set if server supports capability commands
|
|
my @auth_mechs; # set if server supports authentication commands
|
|
my %fulltextreply; #
|
|
my %commandreply; #
|
|
my %customcount; #
|
|
my %delayreply; #
|
|
|
|
#**********************************************************************
|
|
# global variables for to test ftp wildcardmatching or other test that
|
|
# need flexible LIST responses.. and corresponding files.
|
|
# $ftptargetdir is keeping the fake "name" of LIST directory.
|
|
#
|
|
my $ftplistparserstate;
|
|
my $ftptargetdir="";
|
|
|
|
#**********************************************************************
|
|
# global variables used when running a ftp server to keep state info
|
|
# relative to the secondary or data sockfilt process. Values of these
|
|
# variables should only be modified using datasockf_state() sub, given
|
|
# that they are closely related and relationship is a bit awkward.
|
|
#
|
|
my $datasockf_state = 'STOPPED'; # see datasockf_state() sub
|
|
my $datasockf_mode = 'none'; # ['none','active','passive']
|
|
my $datasockf_runs = 'no'; # ['no','yes']
|
|
my $datasockf_conn = 'no'; # ['no','yes']
|
|
|
|
#**********************************************************************
|
|
# 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
|
|
|
|
#**********************************************************************
|
|
# Mail related definitions
|
|
#
|
|
my $TEXT_USERNAME = "user";
|
|
my $TEXT_PASSWORD = "secret";
|
|
my $POP3_TIMESTAMP = "<1972.987654321\@curl>";
|
|
|
|
#**********************************************************************
|
|
# 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
|
|
}
|
|
|
|
#**********************************************************************
|
|
# eXsysread is a wrapper around perl's sysread() function. This will
|
|
# repeat the call to sysread() until it has actually read the complete
|
|
# number of requested bytes or an unrecoverable condition occurs.
|
|
# On success returns a positive value, the number of bytes requested.
|
|
# On failure or timeout returns zero.
|
|
#
|
|
sub eXsysread {
|
|
my $FH = shift;
|
|
my $scalar = shift;
|
|
my $nbytes = shift;
|
|
my $timeout = shift; # A zero timeout disables eXsysread() time limit
|
|
#
|
|
my $time_limited = 0;
|
|
my $timeout_rest = 0;
|
|
my $start_time = 0;
|
|
my $nread = 0;
|
|
my $rc;
|
|
|
|
$$scalar = "";
|
|
|
|
if((not defined $nbytes) || ($nbytes < 1)) {
|
|
logmsg "Error: eXsysread() failure: " .
|
|
"length argument must be positive\n";
|
|
return 0;
|
|
}
|
|
if((not defined $timeout) || ($timeout < 0)) {
|
|
logmsg "Error: eXsysread() failure: " .
|
|
"timeout argument must be zero or positive\n";
|
|
return 0;
|
|
}
|
|
if($timeout > 0) {
|
|
# caller sets eXsysread() time limit
|
|
$time_limited = 1;
|
|
$timeout_rest = $timeout;
|
|
$start_time = int(time());
|
|
}
|
|
|
|
while($nread < $nbytes) {
|
|
if($time_limited) {
|
|
eval {
|
|
local $SIG{ALRM} = sub { die "alarm\n"; };
|
|
alarm $timeout_rest;
|
|
$rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
|
|
alarm 0;
|
|
};
|
|
$timeout_rest = $timeout - (int(time()) - $start_time);
|
|
if($timeout_rest < 1) {
|
|
logmsg "Error: eXsysread() failure: timed out\n";
|
|
return 0;
|
|
}
|
|
}
|
|
else {
|
|
$rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
|
|
}
|
|
if($got_exit_signal) {
|
|
logmsg "Error: eXsysread() failure: signalled to die\n";
|
|
return 0;
|
|
}
|
|
if(not defined $rc) {
|
|
if($!{EINTR}) {
|
|
logmsg "Warning: retrying sysread() interrupted system call\n";
|
|
next;
|
|
}
|
|
if($!{EAGAIN}) {
|
|
logmsg "Warning: retrying sysread() due to EAGAIN\n";
|
|
next;
|
|
}
|
|
if($!{EWOULDBLOCK}) {
|
|
logmsg "Warning: retrying sysread() due to EWOULDBLOCK\n";
|
|
next;
|
|
}
|
|
logmsg "Error: sysread() failure: $!\n";
|
|
return 0;
|
|
}
|
|
if($rc < 0) {
|
|
logmsg "Error: sysread() failure: returned negative value $rc\n";
|
|
return 0;
|
|
}
|
|
if($rc == 0) {
|
|
logmsg "Error: sysread() failure: read zero bytes\n";
|
|
return 0;
|
|
}
|
|
$nread += $rc;
|
|
}
|
|
return $nread;
|
|
}
|
|
|
|
#**********************************************************************
|
|
# read_mainsockf attempts to read the given amount of output from the
|
|
# sockfilter which is in use for the main or primary connection. This
|
|
# reads untranslated sockfilt lingo which may hold data read from the
|
|
# main or primary socket. On success returns 1, otherwise zero.
|
|
#
|
|
sub read_mainsockf {
|
|
my $scalar = shift;
|
|
my $nbytes = shift;
|
|
my $timeout = shift; # Optional argument, if zero blocks indefinitively
|
|
my $FH = \*SFREAD;
|
|
|
|
if(not defined $timeout) {
|
|
$timeout = $sockfilt_timeout + ($nbytes >> 12);
|
|
}
|
|
if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
|
|
my ($fcaller, $lcaller) = (caller)[1,2];
|
|
logmsg "Error: read_mainsockf() failure at $fcaller " .
|
|
"line $lcaller. Due to eXsysread() failure\n";
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
#**********************************************************************
|
|
# read_datasockf attempts to read the given amount of output from the
|
|
# sockfilter which is in use for the data or secondary connection. This
|
|
# reads untranslated sockfilt lingo which may hold data read from the
|
|
# data or secondary socket. On success returns 1, otherwise zero.
|
|
#
|
|
sub read_datasockf {
|
|
my $scalar = shift;
|
|
my $nbytes = shift;
|
|
my $timeout = shift; # Optional argument, if zero blocks indefinitively
|
|
my $FH = \*DREAD;
|
|
|
|
if(not defined $timeout) {
|
|
$timeout = $sockfilt_timeout + ($nbytes >> 12);
|
|
}
|
|
if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
|
|
my ($fcaller, $lcaller) = (caller)[1,2];
|
|
logmsg "Error: read_datasockf() failure at $fcaller " .
|
|
"line $lcaller. Due to eXsysread() failure\n";
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
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!";
|
|
}
|
|
}
|
|
|
|
#**********************************************************************
|
|
# Returns the given test's reply data
|
|
#
|
|
sub getreplydata {
|
|
my ($testno) = @_;
|
|
my $testpart = "";
|
|
|
|
$testno =~ s/^([^0-9]*)//;
|
|
if($testno > 10000) {
|
|
$testpart = $testno % 10000;
|
|
$testno = int($testno / 10000);
|
|
}
|
|
|
|
loadtest("$srcdir/data/test$testno");
|
|
|
|
my @data = getpart("reply", "data$testpart");
|
|
if((!@data) && ($testpart ne "")) {
|
|
@data = getpart("reply", "data");
|
|
}
|
|
|
|
return @data;
|
|
}
|
|
|
|
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/[CR]/g;
|
|
$l =~ s/\n/[LF]/g;
|
|
logmsg "> \"$l\"\n";
|
|
}
|
|
}
|
|
|
|
#**********************************************************************
|
|
# Send data to the FTP client on the data stream when data connection
|
|
# is actually established. Given that this sub should only be called
|
|
# when a data connection is supposed to be established, calling this
|
|
# without a data connection is an indication of weak logic somewhere.
|
|
#
|
|
sub senddata {
|
|
my $l;
|
|
if($datasockf_conn eq 'no') {
|
|
logmsg "WARNING: Detected data sending attempt without DATA channel\n";
|
|
foreach $l (@_) {
|
|
logmsg "WARNING: Data swallowed: $l\n"
|
|
}
|
|
return;
|
|
}
|
|
|
|
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,
|
|
'CWD' => \&CWD_ftp,
|
|
'PWD' => \&PWD_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
|
|
'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' => join("",
|
|
'220- _ _ ____ _ '."\r\n",
|
|
'220- ___| | | | _ \| | '."\r\n",
|
|
'220- / __| | | | |_) | | '."\r\n",
|
|
'220- | (__| |_| | _ {| |___ '."\r\n",
|
|
'220 \___|\___/|_| \_\_____|'."\r\n")
|
|
);
|
|
}
|
|
elsif($proto eq 'pop3') {
|
|
%commandfunc = (
|
|
'APOP' => \&APOP_pop3,
|
|
'AUTH' => \&AUTH_pop3,
|
|
'CAPA' => \&CAPA_pop3,
|
|
'DELE' => \&DELE_pop3,
|
|
'LIST' => \&LIST_pop3,
|
|
'NOOP' => \&NOOP_pop3,
|
|
'PASS' => \&PASS_pop3,
|
|
'QUIT' => \&QUIT_pop3,
|
|
'RETR' => \&RETR_pop3,
|
|
'RSET' => \&RSET_pop3,
|
|
'STAT' => \&STAT_pop3,
|
|
'TOP' => \&TOP_pop3,
|
|
'UIDL' => \&UIDL_pop3,
|
|
'USER' => \&USER_pop3,
|
|
);
|
|
%displaytext = (
|
|
'welcome' => join("",
|
|
' _ _ ____ _ '."\r\n",
|
|
' ___| | | | _ \| | '."\r\n",
|
|
' / __| | | | |_) | | '."\r\n",
|
|
' | (__| |_| | _ {| |___ '."\r\n",
|
|
' \___|\___/|_| \_\_____|'."\r\n",
|
|
'+OK cURL POP3 server ready to serve '."\r\n")
|
|
);
|
|
}
|
|
elsif($proto eq 'imap') {
|
|
%commandfunc = (
|
|
'APPEND' => \&APPEND_imap,
|
|
'CAPABILITY' => \&CAPABILITY_imap,
|
|
'CHECK' => \&CHECK_imap,
|
|
'CLOSE' => \&CLOSE_imap,
|
|
'COPY' => \©_imap,
|
|
'CREATE' => \&CREATE_imap,
|
|
'DELETE' => \&DELETE_imap,
|
|
'EXAMINE' => \&EXAMINE_imap,
|
|
'EXPUNGE' => \&EXPUNGE_imap,
|
|
'FETCH' => \&FETCH_imap,
|
|
'LIST' => \&LIST_imap,
|
|
'LSUB' => \&LSUB_imap,
|
|
'LOGIN' => \&LOGIN_imap,
|
|
'LOGOUT' => \&LOGOUT_imap,
|
|
'NOOP' => \&NOOP_imap,
|
|
'RENAME' => \&RENAME_imap,
|
|
'SEARCH' => \&SEARCH_imap,
|
|
'SELECT' => \&SELECT_imap,
|
|
'STATUS' => \&STATUS_imap,
|
|
'STORE' => \&STORE_imap,
|
|
'UID' => \&UID_imap,
|
|
);
|
|
%displaytext = (
|
|
'welcome' => join("",
|
|
' _ _ ____ _ '."\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,
|
|
'EHLO' => \&EHLO_smtp,
|
|
'EXPN' => \&EXPN_smtp,
|
|
'HELO' => \&HELO_smtp,
|
|
'HELP' => \&HELP_smtp,
|
|
'MAIL' => \&MAIL_smtp,
|
|
'NOOP' => \&NOOP_smtp,
|
|
'RSET' => \&RSET_smtp,
|
|
'RCPT' => \&RCPT_smtp,
|
|
'VRFY' => \&VRFY_smtp,
|
|
'QUIT' => \&QUIT_smtp,
|
|
);
|
|
%displaytext = (
|
|
'welcome' => join("",
|
|
'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);
|
|
|
|
logmsg "=====> Closing $datasockf_mode DATA connection...\n";
|
|
|
|
if(!$closed) {
|
|
if($datapid > 0) {
|
|
logmsg "Server disconnects $datasockf_mode DATA connection\n";
|
|
print DWRITE "DISC\n";
|
|
my $i;
|
|
sysread DREAD, $i, 5;
|
|
}
|
|
else {
|
|
logmsg "Server finds $datasockf_mode DATA connection already ".
|
|
"disconnected\n";
|
|
}
|
|
}
|
|
else {
|
|
logmsg "Server knows $datasockf_mode DATA connection is already ".
|
|
"disconnected\n";
|
|
}
|
|
|
|
if($datapid > 0) {
|
|
print DWRITE "QUIT\n";
|
|
waitpid($datapid, 0);
|
|
unlink($datasockf_pidfile) if(-f $datasockf_pidfile);
|
|
logmsg "DATA sockfilt for $datasockf_mode data channel quits ".
|
|
"(pid $datapid)\n";
|
|
}
|
|
else {
|
|
logmsg "DATA sockfilt for $datasockf_mode data channel already ".
|
|
"dead\n";
|
|
}
|
|
|
|
logmsg "=====> Closed $datasockf_mode DATA connection\n";
|
|
|
|
datasockf_state('STOPPED');
|
|
}
|
|
|
|
################
|
|
################ SMTP commands
|
|
################
|
|
|
|
# The type of server (SMTP or ESMTP)
|
|
my $smtp_type;
|
|
|
|
# The client (which normally contains the test number)
|
|
my $smtp_client;
|
|
|
|
sub EHLO_smtp {
|
|
my ($client) = @_;
|
|
my @data;
|
|
|
|
# TODO: Get the IP address of the client connection to use in the
|
|
# EHLO response when the client doesn't specify one but for now use
|
|
# 127.0.0.1
|
|
if(!$client) {
|
|
$client = "[127.0.0.1]";
|
|
}
|
|
|
|
# Set the server type to ESMTP
|
|
$smtp_type = "ESMTP";
|
|
|
|
# Calculate the EHLO response
|
|
push @data, "$smtp_type pingpong test server Hello $client";
|
|
|
|
if((@capabilities) || (@auth_mechs)) {
|
|
my $mechs;
|
|
|
|
for my $c (@capabilities) {
|
|
push @data, $c;
|
|
}
|
|
|
|
for my $am (@auth_mechs) {
|
|
if(!$mechs) {
|
|
$mechs = "$am";
|
|
}
|
|
else {
|
|
$mechs .= " $am";
|
|
}
|
|
}
|
|
|
|
if($mechs) {
|
|
push @data, "AUTH $mechs";
|
|
}
|
|
}
|
|
|
|
# Send the EHLO response
|
|
for(my $i = 0; $i < @data; $i++) {
|
|
my $d = $data[$i];
|
|
|
|
if($i < @data - 1) {
|
|
sendcontrol "250-$d\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "250 $d\r\n";
|
|
}
|
|
}
|
|
|
|
# Store the client (as it may contain the test number)
|
|
$smtp_client = $client;
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub HELO_smtp {
|
|
my ($client) = @_;
|
|
|
|
# TODO: Get the IP address of the client connection to use in the HELO
|
|
# response when the client doesn't specify one but for now use 127.0.0.1
|
|
if(!$client) {
|
|
$client = "[127.0.0.1]";
|
|
}
|
|
|
|
# Set the server type to SMTP
|
|
$smtp_type = "SMTP";
|
|
|
|
# Send the HELO response
|
|
sendcontrol "250 $smtp_type pingpong test server Hello $client\r\n";
|
|
|
|
# Store the client (as it may contain the test number)
|
|
$smtp_client = $client;
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub MAIL_smtp {
|
|
my ($args) = @_;
|
|
|
|
logmsg "MAIL_smtp got $args\n";
|
|
|
|
if (!$args) {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
else {
|
|
my $from;
|
|
my $size;
|
|
my @elements = split(/ /, $args);
|
|
|
|
# Get the FROM and SIZE parameters
|
|
for my $e (@elements) {
|
|
if($e =~ /^FROM:(.*)$/) {
|
|
$from = $1;
|
|
}
|
|
elsif($e =~ /^SIZE=(\d+)$/) {
|
|
$size = $1;
|
|
}
|
|
}
|
|
|
|
# Validate the from address (only <> and a valid email address inside
|
|
# <> are allowed, such as <user@example.com>)
|
|
if ((!$from) || (($from ne "<>") && ($from !~
|
|
/^<([a-zA-Z0-9._%+-]+)\@([a-zA-Z0-9.-]+).([a-zA-Z]{2,4})>$/))) {
|
|
sendcontrol "501 Invalid address\r\n";
|
|
}
|
|
else {
|
|
my @found;
|
|
my $valid = 1;
|
|
|
|
# Check the capabilities for SIZE and if the specified size is
|
|
# greater than the message size then reject it
|
|
if (@found = grep /^SIZE (\d+)$/, @capabilities) {
|
|
if ($found[0] =~ /^SIZE (\d+)$/) {
|
|
if ($size > $1) {
|
|
$valid = 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
if(!$valid) {
|
|
sendcontrol "552 Message size too large\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "250 Sender OK\r\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub RCPT_smtp {
|
|
my ($args) = @_;
|
|
|
|
logmsg "RCPT_smtp got $args\n";
|
|
|
|
# Get the TO parameter
|
|
if($args !~ /^TO:(.*)/) {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
else {
|
|
my $to = $1;
|
|
|
|
# Validate the to address (only a valid email address inside <> is
|
|
# allowed, such as <user@example.com>)
|
|
if ($to !~
|
|
/^<([a-zA-Z0-9._%+-]+)\@([a-zA-Z0-9.-]+).([a-zA-Z]{2,4})>$/) {
|
|
sendcontrol "501 Invalid address\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "250 Recipient OK\r\n";
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub DATA_smtp {
|
|
my ($args) = @_;
|
|
|
|
if ($args) {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
elsif ($smtp_client !~ /^(\d*)$/) {
|
|
sendcontrol "501 Invalid arguments\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "354 Show me the mail\r\n";
|
|
|
|
my $testno = $smtp_client;
|
|
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);
|
|
}
|
|
|
|
read_mainsockf(\$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);
|
|
|
|
logmsg "received $ulsize bytes upload\n";
|
|
|
|
sendcontrol "250 OK, data received!\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub NOOP_smtp {
|
|
my ($args) = @_;
|
|
|
|
if($args) {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "250 OK\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub RSET_smtp {
|
|
my ($args) = @_;
|
|
|
|
if($args) {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "250 Resetting\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub HELP_smtp {
|
|
my ($args) = @_;
|
|
|
|
# One argument is optional
|
|
if($args) {
|
|
logmsg "HELP_smtp got $args\n";
|
|
}
|
|
|
|
if($smtp_client eq "verifiedserver") {
|
|
# This is the secret command that verifies that this actually is
|
|
# the curl test server
|
|
sendcontrol "214 WE ROOLZ: $$\r\n";
|
|
|
|
if($verbose) {
|
|
print STDERR "FTPD: We returned proof we are the test server\n";
|
|
}
|
|
|
|
logmsg "return proof we are we\n";
|
|
}
|
|
else {
|
|
sendcontrol "214-This server supports the following commands:\r\n";
|
|
|
|
if(@auth_mechs) {
|
|
sendcontrol "214 HELO EHLO RCPT DATA RSET MAIL VRFY EXPN QUIT HELP AUTH\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "214 HELO EHLO RCPT DATA RSET MAIL VRFY EXPN QUIT HELP\r\n";
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub VRFY_smtp {
|
|
my ($args) = @_;
|
|
my ($username, $address) = split(/ /, $args, 2);
|
|
|
|
logmsg "VRFY_smtp got $args\n";
|
|
|
|
if($username eq "") {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($smtp_client);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub EXPN_smtp {
|
|
my ($list_name) = @_;
|
|
|
|
logmsg "EXPN_smtp got $list_name\n";
|
|
|
|
if(!$list_name) {
|
|
sendcontrol "501 Unrecognized parameter\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($smtp_client);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub QUIT_smtp {
|
|
sendcontrol "221 cURL $smtp_type server signing off\r\n";
|
|
|
|
return 0;
|
|
}
|
|
|
|
# What was deleted by IMAP STORE / POP3 DELE commands
|
|
my @deleted;
|
|
|
|
################
|
|
################ IMAP commands
|
|
################
|
|
|
|
# global to allow the command functions to read it
|
|
my $cmdid;
|
|
|
|
# what was picked by SELECT
|
|
my $selected;
|
|
|
|
# Any IMAP parameter can come in escaped and in double quotes.
|
|
# This function is dumb (so far) and just removes the quotes if present.
|
|
sub fix_imap_params {
|
|
foreach (@_) {
|
|
$_ = $1 if /^"(.*)"$/;
|
|
}
|
|
}
|
|
|
|
sub CAPABILITY_imap {
|
|
if((!@capabilities) && (!@auth_mechs)) {
|
|
sendcontrol "$cmdid BAD Command\r\n";
|
|
}
|
|
else {
|
|
my $data;
|
|
|
|
# Calculate the CAPABILITY response
|
|
$data = "* CAPABILITY IMAP4";
|
|
|
|
for my $c (@capabilities) {
|
|
$data .= " $c";
|
|
}
|
|
|
|
for my $am (@auth_mechs) {
|
|
$data .= " AUTH=$am";
|
|
}
|
|
|
|
$data .= " pingpong test server\r\n";
|
|
|
|
# Send the CAPABILITY response
|
|
sendcontrol $data;
|
|
sendcontrol "$cmdid OK CAPABILITY completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub LOGIN_imap {
|
|
my ($args) = @_;
|
|
my ($user, $password) = split(/ /, $args, 2);
|
|
fix_imap_params($user, $password);
|
|
|
|
logmsg "LOGIN_imap got $args\n";
|
|
|
|
if ($user eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
elsif (($user ne $TEXT_USERNAME) || ($password ne $TEXT_PASSWORD)) {
|
|
sendcontrol "$cmdid NO LOGIN failed\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK LOGIN completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub SELECT_imap {
|
|
my ($mailbox) = @_;
|
|
fix_imap_params($mailbox);
|
|
|
|
logmsg "SELECT_imap got test $mailbox\n";
|
|
|
|
if($mailbox eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
# Example from RFC 3501, 6.3.1. SELECT Command
|
|
sendcontrol "* 172 EXISTS\r\n";
|
|
sendcontrol "* 1 RECENT\r\n";
|
|
sendcontrol "* OK [UNSEEN 12] Message 12 is first unseen\r\n";
|
|
sendcontrol "* OK [UIDVALIDITY 3857529045] UIDs valid\r\n";
|
|
sendcontrol "* OK [UIDNEXT 4392] Predicted next UID\r\n";
|
|
sendcontrol "* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n";
|
|
sendcontrol "* OK [PERMANENTFLAGS (\\Deleted \\Seen \\*)] Limited\r\n";
|
|
sendcontrol "$cmdid OK [READ-WRITE] SELECT completed\r\n";
|
|
|
|
$selected = $mailbox;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub FETCH_imap {
|
|
my ($args) = @_;
|
|
my ($uid, $how) = split(/ /, $args, 2);
|
|
fix_imap_params($uid, $how);
|
|
|
|
logmsg "FETCH_imap got $args\n";
|
|
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
else {
|
|
my @data;
|
|
my $size;
|
|
|
|
if($selected eq "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 {
|
|
# send mail content
|
|
logmsg "retrieve a mail\n";
|
|
|
|
@data = getreplydata($selected);
|
|
}
|
|
|
|
for (@data) {
|
|
$size += length($_);
|
|
}
|
|
|
|
sendcontrol "* $uid FETCH ($how {$size}\r\n";
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol ")\r\n";
|
|
sendcontrol "$cmdid OK FETCH completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub APPEND_imap {
|
|
my ($args) = @_;
|
|
|
|
logmsg "APPEND_imap got $args\r\n";
|
|
|
|
$args =~ /^([^ ]+) [^{]*\{(\d+)\}$/;
|
|
my ($mailbox, $size) = ($1, $2);
|
|
fix_imap_params($mailbox);
|
|
|
|
if($mailbox eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "+ Ready for literal data\r\n";
|
|
|
|
my $testno = $mailbox;
|
|
my $filename = "log/upload.$testno";
|
|
|
|
logmsg "Store test number $testno in $filename\n";
|
|
|
|
open(FILE, ">$filename") ||
|
|
return 0; # failed to open output
|
|
|
|
my $received = 0;
|
|
my $line;
|
|
while(5 == (sysread \*SFREAD, $line, 5)) {
|
|
if($line eq "DATA\n") {
|
|
sysread \*SFREAD, $line, 5;
|
|
|
|
my $chunksize = 0;
|
|
if($line =~ /^([0-9a-fA-F]{4})\n/) {
|
|
$chunksize = hex($1);
|
|
}
|
|
|
|
read_mainsockf(\$line, $chunksize);
|
|
|
|
my $left = $size - $received;
|
|
my $datasize = ($left > $chunksize) ? $chunksize : $left;
|
|
|
|
if($datasize > 0) {
|
|
logmsg "> Appending $datasize bytes to file\n";
|
|
print FILE substr($line, 0, $datasize) if(!$nosave);
|
|
$line = substr($line, $datasize);
|
|
|
|
$received += $datasize;
|
|
if($received == $size) {
|
|
logmsg "Received all data, waiting for final CRLF.\n";
|
|
}
|
|
}
|
|
|
|
if($received == $size && $line eq "\r\n") {
|
|
last;
|
|
}
|
|
}
|
|
elsif($line eq "DISC\n") {
|
|
logmsg "Unexpected disconnect!\n";
|
|
last;
|
|
}
|
|
else {
|
|
logmsg "No support for: $line";
|
|
last;
|
|
}
|
|
}
|
|
|
|
if($nosave) {
|
|
print FILE "$size bytes would've been stored here\n";
|
|
}
|
|
|
|
close(FILE);
|
|
|
|
logmsg "received $size bytes upload\n";
|
|
|
|
sendcontrol "$cmdid OK APPEND completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub STORE_imap {
|
|
my ($args) = @_;
|
|
my ($uid, $what, $value) = split(/ /, $args, 3);
|
|
fix_imap_params($uid);
|
|
|
|
logmsg "STORE_imap got $args\n";
|
|
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
elsif (($uid eq "") || ($what ne "+Flags") || ($value eq "")) {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
if($value eq "\\Deleted") {
|
|
push(@deleted, $uid);
|
|
}
|
|
|
|
sendcontrol "* $uid FETCH (FLAGS (\\Seen $value))\r\n";
|
|
sendcontrol "$cmdid OK STORE completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub LIST_imap {
|
|
my ($args) = @_;
|
|
my ($reference, $mailbox) = split(/ /, $args, 2);
|
|
fix_imap_params($reference, $mailbox);
|
|
|
|
logmsg "LIST_imap got $args\n";
|
|
|
|
if ($reference eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
elsif ($reference eq "verifiedserver") {
|
|
# this is the secret command that verifies that this actually is
|
|
# the curl test server
|
|
sendcontrol "* LIST () \"/\" \"WE ROOLZ: $$\"\r\n";
|
|
sendcontrol "$cmdid OK LIST Completed\r\n";
|
|
|
|
if($verbose) {
|
|
print STDERR "FTPD: We returned proof we are the test server\n";
|
|
}
|
|
|
|
logmsg "return proof we are we\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($reference);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK LIST Completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub LSUB_imap {
|
|
my ($args) = @_;
|
|
my ($reference, $mailbox) = split(/ /, $args, 2);
|
|
fix_imap_params($reference, $mailbox);
|
|
|
|
logmsg "LSUB_imap got $args\n";
|
|
|
|
if ($reference eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($reference);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK LSUB Completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub EXAMINE_imap {
|
|
my ($mailbox) = @_;
|
|
fix_imap_params($mailbox);
|
|
|
|
logmsg "EXAMINE_imap got $mailbox\n";
|
|
|
|
if ($mailbox eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($mailbox);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK [READ-ONLY] EXAMINE completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub STATUS_imap {
|
|
my ($args) = @_;
|
|
my ($mailbox, $what) = split(/ /, $args, 2);
|
|
fix_imap_params($mailbox);
|
|
|
|
logmsg "STATUS_imap got $args\n";
|
|
|
|
if ($mailbox eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($mailbox);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK STATUS completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub SEARCH_imap {
|
|
my ($what) = @_;
|
|
fix_imap_params($what);
|
|
|
|
logmsg "SEARCH_imap got $what\n";
|
|
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
elsif ($what eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($selected);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK SEARCH completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub CREATE_imap {
|
|
my ($args) = @_;
|
|
fix_imap_params($args);
|
|
|
|
logmsg "CREATE_imap got $args\n";
|
|
|
|
if ($args eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK CREATE completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub DELETE_imap {
|
|
my ($args) = @_;
|
|
fix_imap_params($args);
|
|
|
|
logmsg "DELETE_imap got $args\n";
|
|
|
|
if ($args eq "") {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK DELETE completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub RENAME_imap {
|
|
my ($args) = @_;
|
|
my ($from_mailbox, $to_mailbox) = split(/ /, $args, 2);
|
|
fix_imap_params($from_mailbox, $to_mailbox);
|
|
|
|
logmsg "RENAME_imap got $args\n";
|
|
|
|
if (($from_mailbox eq "") || ($to_mailbox eq "")) {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK RENAME completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub CHECK_imap {
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK CHECK completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub CLOSE_imap {
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
elsif (!@deleted) {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK CLOSE completed\r\n";
|
|
|
|
@deleted = ();
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub EXPUNGE_imap {
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
else {
|
|
if (!@deleted) {
|
|
# Report the number of existing messages as per the SELECT
|
|
# command
|
|
sendcontrol "* 172 EXISTS\r\n";
|
|
}
|
|
else {
|
|
# Report the message UIDs being deleted
|
|
for my $d (@deleted) {
|
|
sendcontrol "* $d EXPUNGE\r\n";
|
|
}
|
|
|
|
@deleted = ();
|
|
}
|
|
|
|
sendcontrol "$cmdid OK EXPUNGE completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub COPY_imap {
|
|
my ($args) = @_;
|
|
my ($uid, $mailbox) = split(/ /, $args, 2);
|
|
fix_imap_params($uid, $mailbox);
|
|
|
|
logmsg "COPY_imap got $args\n";
|
|
|
|
if (($uid eq "") || ($mailbox eq "")) {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$cmdid OK COPY completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub UID_imap {
|
|
my ($args) = @_;
|
|
my ($command) = split(/ /, $args, 1);
|
|
fix_imap_params($command);
|
|
|
|
logmsg "UID_imap got $args\n";
|
|
|
|
if ($selected eq "") {
|
|
sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
|
|
}
|
|
elsif (($command ne "COPY") && ($command ne "FETCH") &&
|
|
($command ne "STORE") && ($command ne "SEARCH")) {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
my @data = getreplydata($selected);
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK $command completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub NOOP_imap {
|
|
my ($args) = @_;
|
|
my @data = (
|
|
"* 22 EXPUNGE\r\n",
|
|
"* 23 EXISTS\r\n",
|
|
"* 3 RECENT\r\n",
|
|
"* 14 FETCH (FLAGS (\\Seen \\Deleted))\r\n",
|
|
);
|
|
|
|
if ($args) {
|
|
sendcontrol "$cmdid BAD Command Argument\r\n";
|
|
}
|
|
else {
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
sendcontrol "$cmdid OK NOOP completed\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub LOGOUT_imap {
|
|
sendcontrol "* BYE cURL IMAP server signing off\r\n";
|
|
sendcontrol "$cmdid OK LOGOUT completed\r\n";
|
|
|
|
return 0;
|
|
}
|
|
|
|
################
|
|
################ POP3 commands
|
|
################
|
|
|
|
# Who is attempting to log in
|
|
my $username;
|
|
|
|
sub CAPA_pop3 {
|
|
my @list = ();
|
|
my $mechs;
|
|
|
|
# Calculate the capability list based on the specified capabilities
|
|
# (except APOP) and any authentication mechanisms
|
|
for my $c (@capabilities) {
|
|
push @list, "$c\r\n" unless $c eq "APOP";
|
|
}
|
|
|
|
for my $am (@auth_mechs) {
|
|
if(!$mechs) {
|
|
$mechs = "$am";
|
|
}
|
|
else {
|
|
$mechs .= " $am";
|
|
}
|
|
}
|
|
|
|
if($mechs) {
|
|
push @list, "SASL $mechs\r\n";
|
|
}
|
|
|
|
if(!@list) {
|
|
sendcontrol "-ERR Unrecognized command\r\n";
|
|
}
|
|
else {
|
|
my @data = ();
|
|
|
|
# Calculate the CAPA response
|
|
push @data, "+OK List of capabilities follows\r\n";
|
|
|
|
for my $l (@list) {
|
|
push @data, "$l\r\n";
|
|
}
|
|
|
|
push @data, "IMPLEMENTATION POP3 pingpong test server\r\n";
|
|
|
|
# Send the CAPA response
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
# End with the magic 3-byte end of listing marker
|
|
sendcontrol ".\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub APOP_pop3 {
|
|
my ($args) = @_;
|
|
my ($user, $secret) = split(/ /, $args, 2);
|
|
|
|
if (!grep /^APOP$/, @capabilities) {
|
|
sendcontrol "-ERR Unrecognized command\r\n";
|
|
}
|
|
elsif (($user eq "") || ($secret eq "")) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
my $digest = Digest::MD5::md5_hex($POP3_TIMESTAMP, $TEXT_PASSWORD);
|
|
|
|
if (($user ne $TEXT_USERNAME) || ($secret ne $digest)) {
|
|
sendcontrol "-ERR Login failure\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "+OK Login successful\r\n";
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub AUTH_pop3 {
|
|
if(!@auth_mechs) {
|
|
sendcontrol "-ERR Unrecognized command\r\n";
|
|
}
|
|
else {
|
|
my @data = ();
|
|
|
|
# Calculate the AUTH response
|
|
push @data, "+OK List of supported mechanisms follows\r\n";
|
|
|
|
for my $am (@auth_mechs) {
|
|
push @data, "$am\r\n";
|
|
}
|
|
|
|
# Send the AUTH response
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
# End with the magic 3-byte end of listing marker
|
|
sendcontrol ".\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub USER_pop3 {
|
|
my ($user) = @_;
|
|
|
|
logmsg "USER_pop3 got $user\n";
|
|
|
|
if (!$user) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
$username = $user;
|
|
|
|
sendcontrol "+OK\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub PASS_pop3 {
|
|
my ($password) = @_;
|
|
|
|
logmsg "PASS_pop3 got $password\n";
|
|
|
|
if (($username ne $TEXT_USERNAME) || ($password ne $TEXT_PASSWORD)) {
|
|
sendcontrol "-ERR Login failure\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "+OK Login successful\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub RETR_pop3 {
|
|
my ($msgid) = @_;
|
|
my @data;
|
|
|
|
if($msgid =~ /^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 {
|
|
# send mail content
|
|
logmsg "retrieve a mail\n";
|
|
|
|
@data = getreplydata($msgid);
|
|
}
|
|
|
|
sendcontrol "+OK Mail transfer starts\r\n";
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
# end with the magic 3-byte end of mail marker, assumes that the
|
|
# mail body ends with a CRLF!
|
|
sendcontrol ".\r\n";
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub LIST_pop3 {
|
|
# This is a built-in fake-message list
|
|
my @data = (
|
|
"1 100\r\n",
|
|
"2 4294967400\r\n", # > 4 GB
|
|
"3 200\r\n",
|
|
);
|
|
|
|
logmsg "retrieve a message list\n";
|
|
|
|
sendcontrol "+OK Listing starts\r\n";
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
# End with the magic 3-byte end of listing marker
|
|
sendcontrol ".\r\n";
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub DELE_pop3 {
|
|
my ($msgid) = @_;
|
|
|
|
logmsg "DELE_pop3 got $msgid\n";
|
|
|
|
if (!$msgid) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
push (@deleted, $msgid);
|
|
|
|
sendcontrol "+OK\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub STAT_pop3 {
|
|
my ($args) = @_;
|
|
|
|
if ($args) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
# Send statistics for the built-in fake message list as
|
|
# detailed in the LIST_pop3 function above
|
|
sendcontrol "+OK 3 4294967800\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub NOOP_pop3 {
|
|
my ($args) = @_;
|
|
|
|
if ($args) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "+OK\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub UIDL_pop3 {
|
|
# This is a built-in fake-message UID list
|
|
my @data = (
|
|
"1 1\r\n",
|
|
"2 2\r\n",
|
|
"3 4\r\n", # Note that UID 3 is a simulated "deleted" message
|
|
);
|
|
|
|
if (!grep /^UIDL$/, @capabilities) {
|
|
sendcontrol "-ERR Unrecognized command\r\n";
|
|
}
|
|
else {
|
|
logmsg "retrieve a message UID list\n";
|
|
|
|
sendcontrol "+OK Listing starts\r\n";
|
|
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
# End with the magic 3-byte end of listing marker
|
|
sendcontrol ".\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub TOP_pop3 {
|
|
my ($args) = @_;
|
|
my ($msgid, $lines) = split(/ /, $args, 2);
|
|
|
|
logmsg "TOP_pop3 got $args\n";
|
|
|
|
if (!grep /^TOP$/, @capabilities) {
|
|
sendcontrol "-ERR Unrecognized command\r\n";
|
|
}
|
|
elsif (($msgid eq "") || ($lines eq "")) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
if ($lines == "0") {
|
|
logmsg "retrieve header of mail\n";
|
|
}
|
|
else {
|
|
logmsg "retrieve top $lines lines of mail\n";
|
|
}
|
|
|
|
my @data = getreplydata($msgid);
|
|
|
|
sendcontrol "+OK Mail transfer starts\r\n";
|
|
|
|
# Send mail content
|
|
for my $d (@data) {
|
|
sendcontrol $d;
|
|
}
|
|
|
|
# End with the magic 3-byte end of mail marker, assumes that the
|
|
# mail body ends with a CRLF!
|
|
sendcontrol ".\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub RSET_pop3 {
|
|
my ($args) = @_;
|
|
|
|
if ($args) {
|
|
sendcontrol "-ERR Protocol error\r\n";
|
|
}
|
|
else {
|
|
if (@deleted) {
|
|
logmsg "resetting @deleted message(s)\n";
|
|
|
|
@deleted = ();
|
|
}
|
|
|
|
sendcontrol "+OK\r\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub QUIT_pop3 {
|
|
if(@deleted) {
|
|
logmsg "deleting @deleted message(s)\n";
|
|
|
|
@deleted = ();
|
|
}
|
|
|
|
sendcontrol "+OK cURL POP3 server signing off\r\n";
|
|
|
|
return 0;
|
|
}
|
|
|
|
################
|
|
################ FTP commands
|
|
################
|
|
my $rest=0;
|
|
sub REST_ftp {
|
|
$rest = $_[0];
|
|
logmsg "Set REST position to $rest\n"
|
|
}
|
|
|
|
sub switch_directory_goto {
|
|
my $target_dir = $_;
|
|
|
|
if(!$ftptargetdir) {
|
|
$ftptargetdir = "/";
|
|
}
|
|
|
|
if($target_dir eq "") {
|
|
$ftptargetdir = "/";
|
|
}
|
|
elsif($target_dir eq "..") {
|
|
if($ftptargetdir eq "/") {
|
|
$ftptargetdir = "/";
|
|
}
|
|
else {
|
|
$ftptargetdir =~ s/[[:alnum:]]+\/$//;
|
|
}
|
|
}
|
|
else {
|
|
$ftptargetdir .= $target_dir . "/";
|
|
}
|
|
}
|
|
|
|
sub switch_directory {
|
|
my $target_dir = $_[0];
|
|
|
|
if($target_dir =~ /^test-(\d+)/) {
|
|
$cwd_testno = $1;
|
|
}
|
|
elsif($target_dir eq "/") {
|
|
$ftptargetdir = "/";
|
|
}
|
|
else {
|
|
my @dirs = split("/", $target_dir);
|
|
for(@dirs) {
|
|
switch_directory_goto($_);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub CWD_ftp {
|
|
my ($folder, $fullcommand) = $_[0];
|
|
switch_directory($folder);
|
|
if($ftptargetdir =~ /^\/fully_simulated/) {
|
|
$ftplistparserstate = "enabled";
|
|
}
|
|
else {
|
|
undef $ftplistparserstate;
|
|
}
|
|
}
|
|
|
|
sub PWD_ftp {
|
|
my $mydir;
|
|
$mydir = $ftptargetdir ? $ftptargetdir : "/";
|
|
|
|
if($mydir ne "/") {
|
|
$mydir =~ s/\/$//;
|
|
}
|
|
sendcontrol "257 \"$mydir\" is current directory\r\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");
|
|
|
|
if($datasockf_conn eq 'no') {
|
|
if($nodataconn425) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "425 Can't open data connection\r\n";
|
|
}
|
|
elsif($nodataconn421) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "421 Connection timed out\r\n";
|
|
}
|
|
elsif($nodataconn150) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
# client shall timeout
|
|
}
|
|
else {
|
|
# client shall timeout
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
if($ftplistparserstate) {
|
|
@ftpdir = ftp_contentlist($ftptargetdir);
|
|
}
|
|
|
|
logmsg "pass LIST data on data connection\n";
|
|
|
|
if($cwd_testno) {
|
|
loadtest("$srcdir/data/test$cwd_testno");
|
|
|
|
my @data = getpart("reply", "data");
|
|
for(@data) {
|
|
my $send = $_;
|
|
# convert all \n to \r\n for ASCII transfer
|
|
$send =~ s/\r\n/\n/g;
|
|
$send =~ s/\n/\r\n/g;
|
|
logmsg "send $send as data\n";
|
|
senddata $send;
|
|
}
|
|
$cwd_testno = 0; # forget it again
|
|
}
|
|
else {
|
|
# old hard-coded style
|
|
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");
|
|
|
|
if($datasockf_conn eq 'no') {
|
|
if($nodataconn425) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "425 Can't open data connection\r\n";
|
|
}
|
|
elsif($nodataconn421) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "421 Connection timed out\r\n";
|
|
}
|
|
elsif($nodataconn150) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
# client shall timeout
|
|
}
|
|
else {
|
|
# client shall timeout
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
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($ftplistparserstate) {
|
|
my $size = wildcard_filesize($ftptargetdir, $testno);
|
|
if($size == -1) {
|
|
sendcontrol "550 $testno: No such file or directory.\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "213 $size\r\n";
|
|
}
|
|
return 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($datasockf_conn eq 'no') {
|
|
if($nodataconn425) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "425 Can't open data connection\r\n";
|
|
}
|
|
elsif($nodataconn421) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "421 Connection timed out\r\n";
|
|
}
|
|
elsif($nodataconn150) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
# client shall timeout
|
|
}
|
|
else {
|
|
# client shall timeout
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
if($ftplistparserstate) {
|
|
my @content = wildcard_getfile($ftptargetdir, $testno);
|
|
if($content[0] == -1) {
|
|
#file not found
|
|
}
|
|
else {
|
|
my $size = length $content[1];
|
|
sendcontrol "150 Binary data connection for $testno ($size bytes).\r\n",
|
|
senddata $content[1];
|
|
close_dataconn(0);
|
|
sendcontrol "226 File transfer complete\r\n";
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
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";
|
|
|
|
if($datasockf_conn eq 'no') {
|
|
if($nodataconn425) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "425 Can't open data connection\r\n";
|
|
}
|
|
elsif($nodataconn421) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
sendcontrol "421 Connection timed out\r\n";
|
|
}
|
|
elsif($nodataconn150) {
|
|
sendcontrol "150 Opening data connection\r\n";
|
|
# client shall timeout
|
|
}
|
|
else {
|
|
# client shall timeout
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
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);
|
|
}
|
|
|
|
read_datasockf(\$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;
|
|
my $bindonly = ($nodataconn) ? '--bindonly' : '';
|
|
|
|
# kill previous data connection sockfilt when alive
|
|
if($datasockf_runs eq 'yes') {
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
|
|
}
|
|
datasockf_state('STOPPED');
|
|
|
|
logmsg "====> Passive DATA channel requested by client\n";
|
|
|
|
logmsg "DATA sockfilt for passive data channel starting...\n";
|
|
|
|
# We fire up a new sockfilt to do the data transfer for us.
|
|
my $datasockfcmd = "./server/sockfilt " .
|
|
"--ipv$ipvnum $bindonly --port 0 " .
|
|
"--pidfile \"$datasockf_pidfile\" " .
|
|
"--logfile \"$datasockf_logfile\"";
|
|
$slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
|
|
|
|
if($nodataconn) {
|
|
datasockf_state('PASSIVE_NODATACONN');
|
|
}
|
|
else {
|
|
datasockf_state('PASSIVE');
|
|
}
|
|
|
|
print STDERR "$datasockfcmd\n" if($verbose);
|
|
|
|
print DWRITE "PING\n";
|
|
my $pong;
|
|
sysread_or_die(\*DREAD, \$pong, 5);
|
|
|
|
if($pong =~ /^FAIL/) {
|
|
logmsg "DATA sockfilt said: FAIL\n";
|
|
logmsg "DATA sockfilt for passive data channel failed\n";
|
|
logmsg "DATA sockfilt not running\n";
|
|
datasockf_state('STOPPED');
|
|
sendcontrol "500 no free ports!\r\n";
|
|
return;
|
|
}
|
|
elsif($pong !~ /^PONG/) {
|
|
logmsg "DATA sockfilt unexpected response: $pong\n";
|
|
logmsg "DATA sockfilt for passive data channel failed\n";
|
|
logmsg "DATA sockfilt killed now\n";
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt not running\n";
|
|
datasockf_state('STOPPED');
|
|
sendcontrol "500 no free ports!\r\n";
|
|
return;
|
|
}
|
|
|
|
logmsg "DATA sockfilt for passive data channel started (pid $slavepid)\n";
|
|
|
|
# Find out on what port we listen on or have bound
|
|
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
|
|
read_datasockf(\$i, $size);
|
|
|
|
# The data is in the format
|
|
# IPvX/NNN
|
|
|
|
if($i =~ /IPv(\d)\/(\d+)/) {
|
|
# FIX: deal with IP protocol version
|
|
$pasvport = $2;
|
|
}
|
|
|
|
if(!$pasvport) {
|
|
logmsg "DATA sockfilt unknown listener port\n";
|
|
logmsg "DATA sockfilt for passive data channel failed\n";
|
|
logmsg "DATA sockfilt killed now\n";
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt not running\n";
|
|
datasockf_state('STOPPED');
|
|
sendcontrol "500 no free ports!\r\n";
|
|
return;
|
|
}
|
|
|
|
if($nodataconn) {
|
|
my $str = nodataconn_str();
|
|
logmsg "DATA sockfilt for passive data channel ($str) bound on port ".
|
|
"$pasvport\n";
|
|
}
|
|
else {
|
|
logmsg "DATA sockfilt for passive data channel listens on port ".
|
|
"$pasvport\n";
|
|
}
|
|
|
|
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",
|
|
int($pasvport/256), int($pasvport%256));
|
|
}
|
|
else {
|
|
# EPSV reply
|
|
sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
|
|
}
|
|
|
|
logmsg "Client has been notified that DATA conn ".
|
|
"will be accepted on port $pasvport\n";
|
|
|
|
if($nodataconn) {
|
|
my $str = nodataconn_str();
|
|
logmsg "====> Client fooled ($str)\n";
|
|
return;
|
|
}
|
|
|
|
eval {
|
|
local $SIG{ALRM} = sub { die "alarm\n" };
|
|
|
|
# assume swift operations unless explicitly slow
|
|
alarm ($datadelay?20:10);
|
|
|
|
# Wait for 'CNCT'
|
|
my $input;
|
|
|
|
# FIX: Monitor ctrl conn for disconnect
|
|
|
|
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 connects to port $pasvport\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";
|
|
logmsg "DATA sockfilt killed now\n";
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt not running\n";
|
|
datasockf_state('STOPPED');
|
|
return;
|
|
}
|
|
else {
|
|
logmsg "====> Client established passive DATA connection ".
|
|
"on port $pasvport\n";
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
#
|
|
# Support both PORT and EPRT here.
|
|
#
|
|
|
|
sub PORT_ftp {
|
|
my ($arg, $cmd) = @_;
|
|
my $port;
|
|
my $addr;
|
|
|
|
# kill previous data connection sockfilt when alive
|
|
if($datasockf_runs eq 'yes') {
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
|
|
}
|
|
datasockf_state('STOPPED');
|
|
|
|
logmsg "====> Active DATA channel requested by client\n";
|
|
|
|
# We always ignore the given IP and use localhost.
|
|
|
|
if($cmd eq "PORT") {
|
|
if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
|
|
logmsg "DATA sockfilt for active data channel not started ".
|
|
"(bad PORT-line: $arg)\n";
|
|
sendcontrol "500 silly you, go away\r\n";
|
|
return;
|
|
}
|
|
$port = ($5<<8)+$6;
|
|
$addr = "$1.$2.$3.$4";
|
|
}
|
|
# EPRT |2|::1|49706|
|
|
elsif($cmd eq "EPRT") {
|
|
if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
|
|
logmsg "DATA sockfilt for active data channel not started ".
|
|
"(bad EPRT-line: $arg)\n";
|
|
sendcontrol "500 silly you, go away\r\n";
|
|
return;
|
|
}
|
|
sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
|
|
$port = $3;
|
|
$addr = $2;
|
|
}
|
|
else {
|
|
logmsg "DATA sockfilt for active data channel not started ".
|
|
"(invalid command: $cmd)\n";
|
|
sendcontrol "500 we don't like $cmd now\r\n";
|
|
return;
|
|
}
|
|
|
|
if(!$port || $port > 65535) {
|
|
logmsg "DATA sockfilt for active data channel not started ".
|
|
"(illegal PORT number: $port)\n";
|
|
return;
|
|
}
|
|
|
|
if($nodataconn) {
|
|
my $str = nodataconn_str();
|
|
logmsg "DATA sockfilt for active data channel not started ($str)\n";
|
|
datasockf_state('ACTIVE_NODATACONN');
|
|
logmsg "====> Active DATA channel not established\n";
|
|
return;
|
|
}
|
|
|
|
logmsg "DATA sockfilt for active data channel starting...\n";
|
|
|
|
# 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);
|
|
|
|
datasockf_state('ACTIVE');
|
|
|
|
print STDERR "$datasockfcmd\n" if($verbose);
|
|
|
|
print DWRITE "PING\n";
|
|
my $pong;
|
|
sysread_or_die(\*DREAD, \$pong, 5);
|
|
|
|
if($pong =~ /^FAIL/) {
|
|
logmsg "DATA sockfilt said: FAIL\n";
|
|
logmsg "DATA sockfilt for active data channel failed\n";
|
|
logmsg "DATA sockfilt not running\n";
|
|
datasockf_state('STOPPED');
|
|
# client shall timeout awaiting connection from server
|
|
return;
|
|
}
|
|
elsif($pong !~ /^PONG/) {
|
|
logmsg "DATA sockfilt unexpected response: $pong\n";
|
|
logmsg "DATA sockfilt for active data channel failed\n";
|
|
logmsg "DATA sockfilt killed now\n";
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt not running\n";
|
|
datasockf_state('STOPPED');
|
|
# client shall timeout awaiting connection from server
|
|
return;
|
|
}
|
|
|
|
logmsg "DATA sockfilt for active data channel started (pid $slavepid)\n";
|
|
|
|
logmsg "====> Active DATA channel connected to client port $port\n";
|
|
|
|
return;
|
|
}
|
|
|
|
#**********************************************************************
|
|
# datasockf_state is used to change variables that keep state info
|
|
# relative to the FTP secondary or data sockfilt process as soon as
|
|
# one of the five possible stable states is reached. Variables that
|
|
# are modified by this sub may be checked independently but should
|
|
# not be changed except by calling this sub.
|
|
#
|
|
sub datasockf_state {
|
|
my $state = $_[0];
|
|
|
|
if($state eq 'STOPPED') {
|
|
# Data sockfilter initial state, not running,
|
|
# not connected and not used.
|
|
$datasockf_state = $state;
|
|
$datasockf_mode = 'none';
|
|
$datasockf_runs = 'no';
|
|
$datasockf_conn = 'no';
|
|
}
|
|
elsif($state eq 'PASSIVE') {
|
|
# Data sockfilter accepted connection from client.
|
|
$datasockf_state = $state;
|
|
$datasockf_mode = 'passive';
|
|
$datasockf_runs = 'yes';
|
|
$datasockf_conn = 'yes';
|
|
}
|
|
elsif($state eq 'ACTIVE') {
|
|
# Data sockfilter has connected to client.
|
|
$datasockf_state = $state;
|
|
$datasockf_mode = 'active';
|
|
$datasockf_runs = 'yes';
|
|
$datasockf_conn = 'yes';
|
|
}
|
|
elsif($state eq 'PASSIVE_NODATACONN') {
|
|
# Data sockfilter bound port without listening,
|
|
# client won't be able to establish data connection.
|
|
$datasockf_state = $state;
|
|
$datasockf_mode = 'passive';
|
|
$datasockf_runs = 'yes';
|
|
$datasockf_conn = 'no';
|
|
}
|
|
elsif($state eq 'ACTIVE_NODATACONN') {
|
|
# Data sockfilter does not even run,
|
|
# client awaits data connection from server in vain.
|
|
$datasockf_state = $state;
|
|
$datasockf_mode = 'active';
|
|
$datasockf_runs = 'no';
|
|
$datasockf_conn = 'no';
|
|
}
|
|
else {
|
|
die "Internal error. Unknown datasockf state: $state!";
|
|
}
|
|
}
|
|
|
|
#**********************************************************************
|
|
# nodataconn_str returns string of efective nodataconn command. Notice
|
|
# that $nodataconn may be set alone or in addition to a $nodataconnXXX.
|
|
#
|
|
sub nodataconn_str {
|
|
my $str;
|
|
# order matters
|
|
$str = 'NODATACONN' if($nodataconn);
|
|
$str = 'NODATACONN425' if($nodataconn425);
|
|
$str = 'NODATACONN421' if($nodataconn421);
|
|
$str = 'NODATACONN150' if($nodataconn150);
|
|
return "$str";
|
|
}
|
|
|
|
#**********************************************************************
|
|
# 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
|
|
$nodataconn = 0; # default is to establish or accept data channel
|
|
$nodataconn425 = 0; # default is to not send 425 without data channel
|
|
$nodataconn421 = 0; # default is to not send 421 without data channel
|
|
$nodataconn150 = 0; # default is to not send 150 without data channel
|
|
@capabilities = (); # default is to not support capability commands
|
|
@auth_mechs = (); # default is to not support authentication commands
|
|
%fulltextreply = ();#
|
|
%commandreply = (); #
|
|
%customcount = (); #
|
|
%delayreply = (); #
|
|
|
|
open(CUSTOM, "<log/ftpserver.cmd") ||
|
|
return 1;
|
|
|
|
logmsg "FTPD: Getting commands from log/ftpserver.cmd\n";
|
|
|
|
while(<CUSTOM>) {
|
|
if($_ =~ /REPLY \"([A-Z]+ [A-Za-z0-9+-\/=\*. ]+)\" (.*)/) {
|
|
$fulltextreply{$1}=eval "qq{$2}";
|
|
logmsg "FTPD: set custom reply for $1\n";
|
|
}
|
|
elsif($_ =~ /REPLY ([A-Za-z0-9+\/=\*]*) (.*)/) {
|
|
$commandreply{$1}=eval "qq{$2}";
|
|
if($1 eq "") {
|
|
logmsg "FTPD: set custom reply for empty command\n";
|
|
}
|
|
else {
|
|
logmsg "FTPD: set custom reply for $1 command\n";
|
|
}
|
|
}
|
|
elsif($_ =~ /COUNT ([A-Z]+) (.*)/) {
|
|
# we blank the custom reply for this command when having
|
|
# been used this number of times
|
|
$customcount{$1}=$2;
|
|
logmsg "FTPD: blank custom reply for $1 command 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($_ =~ /NODATACONN425/) {
|
|
# applies to both active and passive FTP modes
|
|
logmsg "FTPD: instructed to use NODATACONN425\n";
|
|
$nodataconn425=1;
|
|
$nodataconn=1;
|
|
}
|
|
elsif($_ =~ /NODATACONN421/) {
|
|
# applies to both active and passive FTP modes
|
|
logmsg "FTPD: instructed to use NODATACONN421\n";
|
|
$nodataconn421=1;
|
|
$nodataconn=1;
|
|
}
|
|
elsif($_ =~ /NODATACONN150/) {
|
|
# applies to both active and passive FTP modes
|
|
logmsg "FTPD: instructed to use NODATACONN150\n";
|
|
$nodataconn150=1;
|
|
$nodataconn=1;
|
|
}
|
|
elsif($_ =~ /NODATACONN/) {
|
|
# applies to both active and passive FTP modes
|
|
logmsg "FTPD: instructed to use NODATACONN\n";
|
|
$nodataconn=1;
|
|
}
|
|
elsif($_ =~ /CAPA (.*)/) {
|
|
logmsg "FTPD: instructed to support CAPABILITY command\n";
|
|
@capabilities = split(/ (?!(?:[^" ]|[^"] [^"])+")/, $1);
|
|
foreach (@capabilities) {
|
|
$_ = $1 if /^"(.*)"$/;
|
|
}
|
|
}
|
|
elsif($_ =~ /AUTH (.*)/) {
|
|
logmsg "FTPD: instructed to support AUTHENTICATION command\n";
|
|
@auth_mechs = split(/ /, $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');
|
|
}
|
|
elsif($ARGV[0] eq '--ipv6') {
|
|
$ipvnum = 6;
|
|
$listenaddr = '::1' if($listenaddr eq '127.0.0.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) {
|
|
|
|
# kill previous data connection sockfilt when alive
|
|
if($datasockf_runs eq 'yes') {
|
|
killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
|
|
logmsg "DATA sockfilt for $datasockf_mode data channel killed now\n";
|
|
}
|
|
datasockf_state('STOPPED');
|
|
|
|
#
|
|
# 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 "MAIN sockfilt said: $input";
|
|
next;
|
|
}
|
|
logmsg "====> Client connect\n";
|
|
|
|
set_advisor_read_lock($SERVERLOGS_LOCK);
|
|
$serverlogslocked = 1;
|
|
|
|
# flush data:
|
|
$| = 1;
|
|
|
|
&customize(); # read test control instructions
|
|
|
|
my $welcome = $commandreply{"welcome"};
|
|
if(!$welcome) {
|
|
$welcome = $displaytext{"welcome"};
|
|
}
|
|
else {
|
|
# clear it after use
|
|
$commandreply{"welcome"}="";
|
|
if($welcome !~ /\r\n\z/) {
|
|
$welcome .= "\r\n";
|
|
}
|
|
}
|
|
sendcontrol $welcome;
|
|
|
|
#remove global variables from last connection
|
|
if($ftplistparserstate) {
|
|
undef $ftplistparserstate;
|
|
}
|
|
if($ftptargetdir) {
|
|
undef $ftptargetdir;
|
|
}
|
|
|
|
if($verbose) {
|
|
print STDERR "OUT: $welcome";
|
|
}
|
|
|
|
my $full = "";
|
|
|
|
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 "MAIN 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
|
|
read_mainsockf(\$input, $size);
|
|
|
|
ftpmsg $input;
|
|
|
|
$full .= $input;
|
|
|
|
# Loop until command completion
|
|
next unless($full =~ /\r\n$/);
|
|
|
|
# Remove trailing CRLF.
|
|
$full =~ s/[\n\r]+$//;
|
|
|
|
my $FTPCMD;
|
|
my $FTPARG;
|
|
if($proto eq "imap") {
|
|
# IMAP is different with its identifier first on the command line
|
|
if(($full =~ /^([^ ]+) ([^ ]+) (.*)/) ||
|
|
($full =~ /^([^ ]+) ([^ ]+)/)) {
|
|
$cmdid=$1; # set the global variable
|
|
$FTPCMD=$2;
|
|
$FTPARG=$3;
|
|
}
|
|
# IMAP authentication cancellation
|
|
elsif($full =~ /^\*$/) {
|
|
# Command id has already been set
|
|
$FTPCMD="*";
|
|
$FTPARG="";
|
|
}
|
|
# IMAP long "commands" are base64 authentication data
|
|
elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
|
|
# Command id has already been set
|
|
$FTPCMD=$full;
|
|
$FTPARG="";
|
|
}
|
|
else {
|
|
sendcontrol "$full BAD Command\r\n";
|
|
last;
|
|
}
|
|
}
|
|
elsif($full =~ /^([A-Z]{3,4})(\s(.*))?$/i) {
|
|
$FTPCMD=$1;
|
|
$FTPARG=$3;
|
|
}
|
|
elsif($proto eq "pop3") {
|
|
# POP3 authentication cancellation
|
|
if($full =~ /^\*$/) {
|
|
$FTPCMD="*";
|
|
$FTPARG="";
|
|
}
|
|
# POP3 long "commands" are base64 authentication data
|
|
elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
|
|
$FTPCMD=$full;
|
|
$FTPARG="";
|
|
}
|
|
else {
|
|
sendcontrol "-ERR Unrecognized command\r\n";
|
|
last;
|
|
}
|
|
}
|
|
elsif($proto eq "smtp") {
|
|
# SMTP authentication cancellation
|
|
if($full =~ /^\*$/) {
|
|
$FTPCMD="*";
|
|
$FTPARG="";
|
|
}
|
|
# SMTP long "commands" are base64 authentication data
|
|
elsif($full =~ /^[A-Z0-9+\/]{0,512}={0,2}$/i) {
|
|
$FTPCMD=$full;
|
|
$FTPARG="";
|
|
}
|
|
else {
|
|
sendcontrol "500 Unrecognized command\r\n";
|
|
last;
|
|
}
|
|
}
|
|
else {
|
|
sendcontrol "500 Unrecognized command\r\n";
|
|
last;
|
|
}
|
|
|
|
logmsg "< \"$full\"\n";
|
|
|
|
if($verbose) {
|
|
print STDERR "IN: $full\n";
|
|
}
|
|
|
|
$full = "";
|
|
|
|
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 $check = 1; # no response yet
|
|
|
|
# See if there is a custom reply for the full text
|
|
my $fulltext = $FTPARG ? $FTPCMD . " " . $FTPARG : $FTPCMD;
|
|
my $text = $fulltextreply{$fulltext};
|
|
if($text && ($text ne "")) {
|
|
sendcontrol "$text\r\n";
|
|
$check = 0;
|
|
}
|
|
else {
|
|
# See if there is a custom reply for the command
|
|
$text = $commandreply{$FTPCMD};
|
|
if($text && ($text ne "")) {
|
|
if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
|
|
# used enough times so blank the custom command reply
|
|
$commandreply{$FTPCMD}="";
|
|
}
|
|
|
|
sendcontrol "$text\r\n";
|
|
$check = 0;
|
|
}
|
|
else {
|
|
# See if there is any display text for the command
|
|
$text = $displaytext{$FTPCMD};
|
|
if($text && ($text ne "")) {
|
|
if($proto eq 'imap') {
|
|
sendcontrol "$cmdid $text\r\n";
|
|
}
|
|
else {
|
|
sendcontrol "$text\r\n";
|
|
}
|
|
|
|
$check = 0;
|
|
}
|
|
|
|
# only perform this if we're not faking a reply
|
|
my $func = $commandfunc{$FTPCMD};
|
|
if($func) {
|
|
&$func($FTPARG, $FTPCMD);
|
|
$check = 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
if($check) {
|
|
logmsg "$FTPCMD wasn't handled!\n";
|
|
if($proto eq 'pop3') {
|
|
sendcontrol "-ERR $FTPCMD is not dealt with!\r\n";
|
|
}
|
|
elsif($proto eq 'imap') {
|
|
sendcontrol "$cmdid BAD $FTPCMD is not dealt with!\r\n";
|
|
}
|
|
else {
|
|
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;
|