ftpserver.pl - quickjs-tart - quickjs-based runtime for wallet-core logic

ftpserver.pl (92189B)
      1 #!/usr/bin/env perl
      2 #***************************************************************************
      3 #                                  _   _ ____  _
      4 #  Project                     ___| | | |  _ \| |
      5 #                             / __| | | | |_) | |
      6 #                            | (__| |_| |  _ <| |___
      7 #                             \___|\___/|_| \_\_____|
      8 #
      9 # Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
     10 #
     11 # This software is licensed as described in the file COPYING, which
     12 # you should have received as part of this distribution. The terms
     13 # are also available at https://curl.se/docs/copyright.html.
     14 #
     15 # You may opt to use, copy, modify, merge, publish, distribute and/or sell
     16 # copies of the Software, and permit persons to whom the Software is
     17 # furnished to do so, under the terms of the COPYING file.
     18 #
     19 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
     20 # KIND, either express or implied.
     21 #
     22 # SPDX-License-Identifier: curl
     23 #
     24 ###########################################################################
     25 
     26 # This is a server designed for the curl test suite.
     27 #
     28 # In December 2009 we started remaking the server to support more protocols
     29 # that are similar in spirit. Like POP3, IMAP and SMTP in addition to the FTP
     30 # it already supported since a long time. Note that it still only supports one
     31 # protocol per invoke. You need to start multiple servers to support multiple
     32 # protocols simultaneously.
     33 #
     34 # It is meant to exercise curl, it is not meant to be a fully working
     35 # or even very standard compliant server.
     36 #
     37 # You may optionally specify port on the command line, otherwise it'll
     38 # default to port 8921.
     39 #
     40 # All socket/network/TCP related stuff is done by the 'sockfilt' program.
     41 #
     42 
     43 use strict;
     44 use warnings;
     45 
     46 BEGIN {
     47     push(@INC, $ENV{'srcdir'}) if(defined $ENV{'srcdir'});
     48     push(@INC, ".");
     49 }
     50 
     51 use IPC::Open2;
     52 use Digest::MD5;
     53 use File::Basename;
     54 
     55 use directories;
     56 
     57 use getpart qw(
     58     getpartattr
     59     getpart
     60     loadtest
     61     );
     62 
     63 use processhelp;
     64 
     65 use serverhelp qw(
     66     logmsg
     67     $logfile
     68     servername_str
     69     server_pidfilename
     70     server_logfilename
     71     server_exe_args
     72     mainsockf_pidfilename
     73     mainsockf_logfilename
     74     datasockf_pidfilename
     75     datasockf_logfilename
     76     );
     77 
     78 use globalconfig qw(
     79     $SERVERCMD
     80     $LOCKDIR
     81     );
     82 
     83 #**********************************************************************
     84 # global vars...
     85 #
     86 my $verbose = 0;    # set to 1 for debugging
     87 my $idstr = "";     # server instance string
     88 my $idnum = 1;      # server instance number
     89 my $ipvnum = 4;     # server IPv number (4 or 6)
     90 my $proto = 'ftp';  # default server protocol
     91 my $srcdir;         # directory where ftpserver.pl is located
     92 my $srvrname;       # server name for presentation purposes
     93 my $cwd_testno;     # test case numbers extracted from CWD command
     94 my $testno = 0;     # test case number (read from server.cmd)
     95 my $path   = '.';
     96 my $logdir = $path .'/log';
     97 my $piddir;
     98 
     99 #**********************************************************************
    100 # global vars used for server address and primary listener port
    101 #
    102 my $port = 8921;               # default primary listener port
    103 my $listenaddr = '127.0.0.1';  # default address for listener port
    104 
    105 #**********************************************************************
    106 # global vars used for file names
    107 #
    108 my $PORTFILE="ftpserver.port"; # server port file name
    109 my $portfile;           # server port file path
    110 my $pidfile;            # server pid file name
    111 my $mainsockf_pidfile;  # pid file for primary connection sockfilt process
    112 my $mainsockf_logfile;  # log file for primary connection sockfilt process
    113 my $datasockf_pidfile;  # pid file for secondary connection sockfilt process
    114 my $datasockf_logfile;  # log file for secondary connection sockfilt process
    115 
    116 #**********************************************************************
    117 # global vars used for server logs advisor read lock handling
    118 #
    119 my $serverlogs_lockfile;
    120 my $serverlogslocked = 0;
    121 
    122 #**********************************************************************
    123 # global vars used for child processes PID tracking
    124 #
    125 my $sfpid;        # PID for primary connection sockfilt process
    126 my $slavepid;     # PID for secondary connection sockfilt process
    127 
    128 #**********************************************************************
    129 # global typeglob filehandle vars to read/write from/to sockfilters
    130 #
    131 local *SFREAD;    # used to read from primary connection
    132 local *SFWRITE;   # used to write to primary connection
    133 local *DREAD;     # used to read from secondary connection
    134 local *DWRITE;    # used to write to secondary connection
    135 
    136 my $sockfilt_timeout = 5;  # default timeout for sockfilter eXsysreads
    137 
    138 #**********************************************************************
    139 # global vars which depend on server protocol selection
    140 #
    141 my %commandfunc;   # protocol command specific function callbacks
    142 my %displaytext;   # text returned to client before callback runs
    143 
    144 #**********************************************************************
    145 # global vars customized for each test from the server commands file
    146 #
    147 my $ctrldelay;     # set if server should throttle ctrl stream
    148 my $datadelay;     # set if server should throttle data stream
    149 my $retrweirdo;    # set if ftp server should use RETRWEIRDO
    150 my $retrnosize;    # set if ftp server should use RETRNOSIZE
    151 my $retrsize;      # set if ftp server should use RETRSIZE
    152 my $pasvbadip;     # set if ftp server should use PASVBADIP
    153 my $nosave;        # set if ftp server should not save uploaded data
    154 my $nodataconn;    # set if ftp srvr doesn't establish or accepts data channel
    155 my $nodataconn425; # set if ftp srvr doesn't establish data ch and replies 425
    156 my $nodataconn421; # set if ftp srvr doesn't establish data ch and replies 421
    157 my $nodataconn150; # set if ftp srvr doesn't establish data ch and replies 150
    158 my $storeresp;
    159 my $postfetch;
    160 my @capabilities;  # set if server supports capability commands
    161 my @auth_mechs;    # set if server supports authentication commands
    162 my %fulltextreply; #
    163 my %commandreply;  #
    164 my %customcount;   #
    165 my %delayreply;    #
    166 
    167 #**********************************************************************
    168 # global variables for to test ftp wildcardmatching or other test that
    169 # need flexible LIST responses.. and corresponding files.
    170 # $ftptargetdir is keeping the fake "name" of LIST directory.
    171 #
    172 my $ftplistparserstate;
    173 my $ftptargetdir="";
    174 
    175 #**********************************************************************
    176 # global variables used when running a ftp server to keep state info
    177 # relative to the secondary or data sockfilt process. Values of these
    178 # variables should only be modified using datasockf_state() sub, given
    179 # that they are closely related and relationship is a bit awkward.
    180 #
    181 my $datasockf_state = 'STOPPED'; # see datasockf_state() sub
    182 my $datasockf_mode = 'none';     # ['none','active','passive']
    183 my $datasockf_runs = 'no';       # ['no','yes']
    184 my $datasockf_conn = 'no';       # ['no','yes']
    185 
    186 #**********************************************************************
    187 # global vars used for signal handling
    188 #
    189 my $got_exit_signal = 0; # set if program should finish execution ASAP
    190 
    191 #**********************************************************************
    192 # Mail related definitions
    193 #
    194 my $TEXT_PASSWORD = "secret";
    195 my $POP3_TIMESTAMP = "<1972.987654321\@curl>";
    196 
    197 #**********************************************************************
    198 # exit_signal_handler will be triggered to indicate that the program
    199 # should finish its execution in a controlled way as soon as possible.
    200 # For now, program will also terminate from within this handler.
    201 #
    202 sub exit_signal_handler {
    203     my $signame = shift;
    204     # For now, simply mimic old behavior.
    205     killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
    206     unlink($pidfile);
    207     unlink($portfile);
    208     if($serverlogslocked) {
    209         $serverlogslocked = 0;
    210         clear_advisor_read_lock($serverlogs_lockfile);
    211     }
    212     exit;
    213 }
    214 
    215 sub ftpmsg {
    216   # append to the server.input file
    217   open(my $input, ">>", "$logdir/server$idstr.input") ||
    218     logmsg "failed to open $logdir/server$idstr.input\n";
    219 
    220   print $input @_;
    221   close($input);
    222 
    223   # use this, open->print->close system only to make the file
    224   # open as little as possible, to make the test suite run
    225   # better on Windows/Cygwin
    226 }
    227 
    228 #**********************************************************************
    229 # eXsysread is a wrapper around perl's sysread() function. This will
    230 # repeat the call to sysread() until it has actually read the complete
    231 # number of requested bytes or an unrecoverable condition occurs.
    232 # On success returns a positive value, the number of bytes requested.
    233 # On failure or timeout returns zero.
    234 #
    235 sub eXsysread {
    236     my $FH      = shift;
    237     my $scalar  = shift;
    238     my $nbytes  = shift;
    239     my $timeout = shift; # A zero timeout disables eXsysread() time limit
    240     #
    241     my $time_limited = 0;
    242     my $timeout_rest = 0;
    243     my $start_time = 0;
    244     my $nread  = 0;
    245     my $rc;
    246 
    247     $$scalar = "";
    248 
    249     if((not defined $nbytes) || ($nbytes < 1)) {
    250         logmsg "Error: eXsysread() failure: " .
    251                "length argument must be positive\n";
    252         return 0;
    253     }
    254     if((not defined $timeout) || ($timeout < 0)) {
    255         logmsg "Error: eXsysread() failure: " .
    256                "timeout argument must be zero or positive\n";
    257         return 0;
    258     }
    259     if($timeout > 0) {
    260         # caller sets eXsysread() time limit
    261         $time_limited = 1;
    262         $timeout_rest = $timeout;
    263         $start_time = int(time());
    264     }
    265 
    266     while($nread < $nbytes) {
    267         if($time_limited) {
    268             eval {
    269                 local $SIG{ALRM} = sub { die "alarm\n"; };
    270                 alarm $timeout_rest;
    271                 $rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
    272                 alarm 0;
    273             };
    274             $timeout_rest = $timeout - (int(time()) - $start_time);
    275             if($timeout_rest < 1) {
    276                 logmsg "Error: eXsysread() failure: timed out\n";
    277                 return 0;
    278             }
    279         }
    280         else {
    281             $rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
    282         }
    283         if($got_exit_signal) {
    284             logmsg "Error: eXsysread() failure: signalled to die\n";
    285             return 0;
    286         }
    287         if(not defined $rc) {
    288             if($!{EINTR}) {
    289                 logmsg "Warning: retrying sysread() interrupted system call\n";
    290                 next;
    291             }
    292             if($!{EAGAIN}) {
    293                 logmsg "Warning: retrying sysread() due to EAGAIN\n";
    294                 next;
    295             }
    296             if($!{EWOULDBLOCK}) {
    297                 logmsg "Warning: retrying sysread() due to EWOULDBLOCK\n";
    298                 next;
    299             }
    300             logmsg "Error: sysread() failure: $!\n";
    301             return 0;
    302         }
    303         if($rc < 0) {
    304             logmsg "Error: sysread() failure: returned negative value $rc\n";
    305             return 0;
    306         }
    307         if($rc == 0) {
    308             logmsg "Error: sysread() failure: read zero bytes\n";
    309             return 0;
    310         }
    311         $nread += $rc;
    312     }
    313     return $nread;
    314 }
    315 
    316 #**********************************************************************
    317 # read_mainsockf attempts to read the given amount of output from the
    318 # sockfilter which is in use for the main or primary connection. This
    319 # reads untranslated sockfilt lingo which may hold data read from the
    320 # main or primary socket. On success returns 1, otherwise zero.
    321 #
    322 sub read_mainsockf {
    323     my $scalar  = shift;
    324     my $nbytes  = shift;
    325     my $timeout = shift; # Optional argument, if zero blocks indefinitely
    326     my $FH = \*SFREAD;
    327 
    328     if(not defined $timeout) {
    329         $timeout = $sockfilt_timeout + ($nbytes >> 12);
    330     }
    331     if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
    332         my ($fcaller, $lcaller) = (caller)[1,2];
    333         logmsg "Error: read_mainsockf() failure at $fcaller " .
    334                "line $lcaller. Due to eXsysread() failure\n";
    335         return 0;
    336     }
    337     return 1;
    338 }
    339 
    340 #**********************************************************************
    341 # read_datasockf attempts to read the given amount of output from the
    342 # sockfilter which is in use for the data or secondary connection. This
    343 # reads untranslated sockfilt lingo which may hold data read from the
    344 # data or secondary socket. On success returns 1, otherwise zero.
    345 #
    346 sub read_datasockf {
    347     my $scalar = shift;
    348     my $nbytes = shift;
    349     my $timeout = shift; # Optional argument, if zero blocks indefinitely
    350     my $FH = \*DREAD;
    351 
    352     if(not defined $timeout) {
    353         $timeout = $sockfilt_timeout + ($nbytes >> 12);
    354     }
    355     if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
    356         my ($fcaller, $lcaller) = (caller)[1,2];
    357         logmsg "Error: read_datasockf() failure at $fcaller " .
    358                "line $lcaller. Due to eXsysread() failure\n";
    359         return 0;
    360     }
    361     return 1;
    362 }
    363 
    364 sub sysread_or_die {
    365     my $FH     = shift;
    366     my $scalar = shift;
    367     my $length = shift;
    368     my $fcaller;
    369     my $lcaller;
    370     my $result;
    371 
    372     $result = sysread($$FH, $$scalar, $length);
    373 
    374     if(not defined $result) {
    375         ($fcaller, $lcaller) = (caller)[1,2];
    376         logmsg "Failed to read input\n";
    377         logmsg "Error: $srvrname server, sysread error: $!\n";
    378         logmsg "Exited from sysread_or_die() at $fcaller " .
    379                "line $lcaller. $srvrname server, sysread error: $!\n";
    380         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
    381         unlink($pidfile);
    382         unlink($portfile);
    383         if($serverlogslocked) {
    384             $serverlogslocked = 0;
    385             clear_advisor_read_lock($serverlogs_lockfile);
    386         }
    387         exit;
    388     }
    389     elsif($result == 0) {
    390         ($fcaller, $lcaller) = (caller)[1,2];
    391         logmsg "Failed to read input\n";
    392         logmsg "Error: $srvrname server, read zero\n";
    393         logmsg "Exited from sysread_or_die() at $fcaller " .
    394                "line $lcaller. $srvrname server, read zero\n";
    395         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
    396         unlink($pidfile);
    397         unlink($portfile);
    398         if($serverlogslocked) {
    399             $serverlogslocked = 0;
    400             clear_advisor_read_lock($serverlogs_lockfile);
    401         }
    402         exit;
    403     }
    404 
    405     return $result;
    406 }
    407 
    408 sub startsf {
    409     my @mainsockfcmd = (server_exe_args('sockfilt'),
    410         "--ipv$ipvnum",
    411         "--port", $port,
    412         "--pidfile", $mainsockf_pidfile,
    413         "--portfile", $portfile,
    414         "--logfile", $mainsockf_logfile);
    415     $sfpid = open2(*SFREAD, *SFWRITE, @mainsockfcmd);
    416 
    417     print STDERR "@mainsockfcmd\n" if($verbose);
    418 
    419     print SFWRITE "PING\n";
    420     my $pong;
    421     sysread_or_die(\*SFREAD, \$pong, 5);
    422 
    423     if($pong !~ /^PONG/) {
    424         logmsg "Failed sockfilt command: @mainsockfcmd\n";
    425         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
    426         unlink($pidfile);
    427         unlink($portfile);
    428         if($serverlogslocked) {
    429             $serverlogslocked = 0;
    430             clear_advisor_read_lock($serverlogs_lockfile);
    431         }
    432         die "Failed to start sockfilt!";
    433     }
    434 }
    435 
    436 #**********************************************************************
    437 # Returns the given test's reply data
    438 #
    439 sub getreplydata {
    440     my ($num) = @_;
    441     my $testpart = "";
    442 
    443     $num =~ s/^([^0-9]*)//;
    444     if($num > 10000) {
    445        $testpart = $num % 10000;
    446     }
    447 
    448     my @data = getpart("reply", "data$testpart");
    449     if((!@data) && ($testpart ne "")) {
    450         @data = getpart("reply", "data");
    451     }
    452 
    453     return @data;
    454 }
    455 
    456 sub sockfilt {
    457     my $l;
    458     foreach $l (@_) {
    459         printf SFWRITE "DATA\n%04x\n", length($l);
    460         print SFWRITE $l;
    461     }
    462 }
    463 
    464 sub sockfiltsecondary {
    465     my $l;
    466     foreach $l (@_) {
    467         printf DWRITE "DATA\n%04x\n", length($l);
    468         print DWRITE $l;
    469     }
    470 }
    471 
    472 #**********************************************************************
    473 # Send data to the client on the control stream, which happens to be plain
    474 # stdout.
    475 #
    476 sub sendcontrol {
    477     if(!$ctrldelay) {
    478         # spit it all out at once
    479         sockfilt @_;
    480     }
    481     else {
    482         my $a = join("", @_);
    483         my @a = split("", $a);
    484 
    485         for(@a) {
    486             sockfilt $_;
    487             portable_sleep($ctrldelay);
    488         }
    489     }
    490     my $log;
    491     foreach $log (@_) {
    492         my $l = $log;
    493         $l =~ s/\r/[CR]/g;
    494         $l =~ s/\n/[LF]/g;
    495         logmsg "> \"$l\"\n";
    496     }
    497 }
    498 
    499 #**********************************************************************
    500 # Send data to the FTP client on the data stream when data connection
    501 # is actually established. Given that this sub should only be called
    502 # when a data connection is supposed to be established, calling this
    503 # without a data connection is an indication of weak logic somewhere.
    504 #
    505 sub senddata {
    506     my $l;
    507     if($datasockf_conn eq 'no') {
    508         logmsg "WARNING: Detected data sending attempt without DATA channel\n";
    509         foreach $l (@_) {
    510             logmsg "WARNING: Data swallowed: $l\n"
    511         }
    512         return;
    513     }
    514 
    515     foreach $l (@_) {
    516         if(!$datadelay) {
    517             # spit it all out at once
    518             sockfiltsecondary $l;
    519         }
    520         else {
    521             # pause between each byte
    522             for (split(//,$l)) {
    523                 sockfiltsecondary $_;
    524                 portable_sleep($datadelay);
    525             }
    526         }
    527     }
    528 }
    529 
    530 #**********************************************************************
    531 # protocolsetup initializes the 'displaytext' and 'commandfunc' hashes
    532 # for the given protocol. References to protocol command callbacks are
    533 # stored in 'commandfunc' hash, and text which will be returned to the
    534 # client before the command callback runs is stored in 'displaytext'.
    535 #
    536 sub protocolsetup {
    537     my $proto = $_[0];
    538 
    539     if($proto eq 'ftp') {
    540         %commandfunc = (
    541             'PORT' => \&PORT_ftp,
    542             'EPRT' => \&PORT_ftp,
    543             'LIST' => \&LIST_ftp,
    544             'NLST' => \&NLST_ftp,
    545             'PASV' => \&PASV_ftp,
    546             'CWD'  => \&CWD_ftp,
    547             'PWD'  => \&PWD_ftp,
    548             'EPSV' => \&PASV_ftp,
    549             'RETR' => \&RETR_ftp,
    550             'SIZE' => \&SIZE_ftp,
    551             'REST' => \&REST_ftp,
    552             'STOR' => \&STOR_ftp,
    553             'APPE' => \&STOR_ftp, # append looks like upload
    554             'MDTM' => \&MDTM_ftp,
    555         );
    556         %displaytext = (
    557             'USER' => '331 We are happy you popped in!',
    558             'PASS' => '230 Welcome you silly person',
    559             'PORT' => '200 You said PORT - I say FINE',
    560             'TYPE' => '200 I modify TYPE as you wanted',
    561             'LIST' => '150 here comes a directory',
    562             'NLST' => '150 here comes a directory',
    563             'CWD'  => '250 CWD command successful.',
    564             'SYST' => '215 UNIX Type: L8', # just fake something
    565             'QUIT' => '221 bye bye baby', # just reply something
    566             'MKD'  => '257 Created your requested directory',
    567             'REST' => '350 Yeah yeah we set it there for you',
    568             'DELE' => '200 OK OK OK whatever you say',
    569             'RNFR' => '350 Received your order. Please provide more',
    570             'RNTO' => '250 Ok, thanks. File renaming completed.',
    571             'NOOP' => '200 Yes, I\'m very good at doing nothing.',
    572             'PBSZ' => '500 PBSZ not implemented',
    573             'PROT' => '500 PROT not implemented',
    574             'welcome' => join("",
    575             '220-        _   _ ____  _     '."\r\n",
    576             '220-    ___| | | |  _ \| |    '."\r\n",
    577             '220-   / __| | | | |_) | |    '."\r\n",
    578             '220-  | (__| |_| |  _ {| |___ '."\r\n",
    579             '220    \___|\___/|_| \_\_____|'."\r\n")
    580         );
    581     }
    582     elsif($proto eq 'pop3') {
    583         %commandfunc = (
    584             'APOP' => \&APOP_pop3,
    585             'AUTH' => \&AUTH_pop3,
    586             'CAPA' => \&CAPA_pop3,
    587             'DELE' => \&DELE_pop3,
    588             'LIST' => \&LIST_pop3,
    589             'NOOP' => \&NOOP_pop3,
    590             'PASS' => \&PASS_pop3,
    591             'QUIT' => \&QUIT_pop3,
    592             'RETR' => \&RETR_pop3,
    593             'RSET' => \&RSET_pop3,
    594             'STAT' => \&STAT_pop3,
    595             'TOP'  => \&TOP_pop3,
    596             'UIDL' => \&UIDL_pop3,
    597             'USER' => \&USER_pop3,
    598         );
    599         %displaytext = (
    600             'welcome' => join("",
    601             '        _   _ ____  _     '."\r\n",
    602             '    ___| | | |  _ \| |    '."\r\n",
    603             '   / __| | | | |_) | |    '."\r\n",
    604             '  | (__| |_| |  _ {| |___ '."\r\n",
    605             '   \___|\___/|_| \_\_____|'."\r\n",
    606             '+OK curl POP3 server ready to serve '."\r\n")
    607         );
    608     }
    609     elsif($proto eq 'imap') {
    610         %commandfunc = (
    611             'APPEND'     => \&APPEND_imap,
    612             'CAPABILITY' => \&CAPABILITY_imap,
    613             'CHECK'      => \&CHECK_imap,
    614             'CLOSE'      => \&CLOSE_imap,
    615             'COPY'       => \&COPY_imap,
    616             'CREATE'     => \&CREATE_imap,
    617             'DELETE'     => \&DELETE_imap,
    618             'EXAMINE'    => \&EXAMINE_imap,
    619             'EXPUNGE'    => \&EXPUNGE_imap,
    620             'FETCH'      => \&FETCH_imap,
    621             'LIST'       => \&LIST_imap,
    622             'LSUB'       => \&LSUB_imap,
    623             'LOGIN'      => \&LOGIN_imap,
    624             'LOGOUT'     => \&LOGOUT_imap,
    625             'NOOP'       => \&NOOP_imap,
    626             'RENAME'     => \&RENAME_imap,
    627             'SEARCH'     => \&SEARCH_imap,
    628             'SELECT'     => \&SELECT_imap,
    629             'STATUS'     => \&STATUS_imap,
    630             'STORE'      => \&STORE_imap,
    631             'UID'        => \&UID_imap,
    632             'IDLE'       => \&IDLE_imap,
    633         );
    634         %displaytext = (
    635             'welcome' => join("",
    636             '        _   _ ____  _     '."\r\n",
    637             '    ___| | | |  _ \| |    '."\r\n",
    638             '   / __| | | | |_) | |    '."\r\n",
    639             '  | (__| |_| |  _ {| |___ '."\r\n",
    640             '   \___|\___/|_| \_\_____|'."\r\n",
    641             '* OK curl IMAP server ready to serve'."\r\n")
    642         );
    643     }
    644     elsif($proto eq 'smtp') {
    645         %commandfunc = (
    646             'DATA' => \&DATA_smtp,
    647             'EHLO' => \&EHLO_smtp,
    648             'EXPN' => \&EXPN_smtp,
    649             'HELO' => \&HELO_smtp,
    650             'HELP' => \&HELP_smtp,
    651             'MAIL' => \&MAIL_smtp,
    652             'NOOP' => \&NOOP_smtp,
    653             'RSET' => \&RSET_smtp,
    654             'RCPT' => \&RCPT_smtp,
    655             'VRFY' => \&VRFY_smtp,
    656             'QUIT' => \&QUIT_smtp,
    657         );
    658         %displaytext = (
    659             'welcome' => join("",
    660             '220-        _   _ ____  _     '."\r\n",
    661             '220-    ___| | | |  _ \| |    '."\r\n",
    662             '220-   / __| | | | |_) | |    '."\r\n",
    663             '220-  | (__| |_| |  _ {| |___ '."\r\n",
    664             '220    \___|\___/|_| \_\_____|'."\r\n")
    665         );
    666     }
    667 }
    668 
    669 # Perform the disconnect handshake with sockfilt on the secondary connection
    670 # (the only connection we actively disconnect).
    671 # This involves waiting for the disconnect acknowledgment after the DISC
    672 # command, while throwing away anything else that might come in before
    673 # that.
    674 sub disc_handshake {
    675     print DWRITE "DISC\n";
    676     my $line;
    677     my $nr;
    678     while(5 == ($nr = sysread DREAD, $line, 5)) {
    679         if($line eq "DATA\n") {
    680             # Must read the data bytes to stay in sync
    681             my $i;
    682             sysread DREAD, $i, 5;
    683 
    684             my $size = 0;
    685             if($i =~ /^([0-9a-fA-F]{4})\n/) {
    686                 $size = hex($1);
    687             }
    688 
    689             logmsg "> Throwing away $size bytes on closed connection\n";
    690             read_datasockf(\$line, $size);
    691         }
    692         elsif($line eq "DISC\n") {
    693             logmsg "Fancy that; client wants to DISC, too\n";
    694             printf DWRITE "ACKD\n";
    695         }
    696         elsif($line eq "ACKD\n") {
    697             # Got the ack we were waiting for
    698             last;
    699         }
    700         else {
    701             logmsg "Ignoring: $line";
    702             # sockfilt should not be sending us any other commands
    703         }
    704     }
    705     if(!defined($nr)) {
    706         logmsg "Error: pipe read error ($!) while waiting for ACKD";
    707     }
    708     elsif($nr <= 0) {
    709         logmsg "Error: pipe EOF while waiting for ACKD";
    710     }
    711 }
    712 
    713 sub close_dataconn {
    714     my ($closed)=@_; # non-zero if already disconnected
    715 
    716     my $datapid = processexists($datasockf_pidfile);
    717 
    718     logmsg "=====> Closing $datasockf_mode DATA connection...\n";
    719 
    720     if(!$closed) {
    721         if($datapid > 0) {
    722             logmsg "Server disconnects $datasockf_mode DATA connection\n";
    723             disc_handshake();
    724             logmsg "Server disconnected $datasockf_mode DATA connection\n";
    725         }
    726         else {
    727             logmsg "Server finds $datasockf_mode DATA connection already ".
    728                    "disconnected\n";
    729         }
    730     }
    731     else {
    732         logmsg "Server knows $datasockf_mode DATA connection is already ".
    733                "disconnected\n";
    734     }
    735 
    736     if($datapid > 0) {
    737         logmsg "DATA sockfilt for $datasockf_mode data channel quits ".
    738                "(pid $datapid)\n";
    739         print DWRITE "QUIT\n";
    740         pidwait($datapid, 0);
    741         unlink($datasockf_pidfile) if(-f $datasockf_pidfile);
    742         logmsg "DATA sockfilt for $datasockf_mode data channel quit ".
    743                "(pid $datapid)\n";
    744     }
    745     else {
    746         logmsg "DATA sockfilt for $datasockf_mode data channel already ".
    747                "dead\n";
    748     }
    749 
    750     logmsg "=====> Closed $datasockf_mode DATA connection\n";
    751 
    752     datasockf_state('STOPPED');
    753 }
    754 
    755 ################
    756 ################ SMTP commands
    757 ################
    758 
    759 # The type of server (SMTP or ESMTP)
    760 my $smtp_type;
    761 
    762 # The client (which normally contains the test number)
    763 my $smtp_client;
    764 
    765 sub EHLO_smtp {
    766     my ($client) = @_;
    767     my @data;
    768 
    769     # TODO: Get the IP address of the client connection to use in the
    770     # EHLO response when the client doesn't specify one but for now use
    771     # 127.0.0.1
    772     if(!$client) {
    773         $client = "[127.0.0.1]";
    774     }
    775 
    776     # Set the server type to ESMTP
    777     $smtp_type = "ESMTP";
    778 
    779     # Calculate the EHLO response
    780     push @data, "$smtp_type pingpong test server Hello $client";
    781 
    782     if((@capabilities) || (@auth_mechs)) {
    783         my $mechs;
    784 
    785         for my $c (@capabilities) {
    786             push @data, $c;
    787         }
    788 
    789         for my $am (@auth_mechs) {
    790             if(!$mechs) {
    791                 $mechs = "$am";
    792             }
    793             else {
    794                 $mechs .= " $am";
    795             }
    796         }
    797 
    798         if($mechs) {
    799             push @data, "AUTH $mechs";
    800         }
    801     }
    802 
    803     # Send the EHLO response
    804     for(my $i = 0; $i < @data; $i++) {
    805         my $d = $data[$i];
    806 
    807         if($i < @data - 1) {
    808             sendcontrol "250-$d\r\n";
    809         }
    810         else {
    811             sendcontrol "250 $d\r\n";
    812         }
    813     }
    814 
    815     # Store the client (as it may contain the test number)
    816     $smtp_client = $client;
    817 
    818     return 0;
    819 }
    820 
    821 sub HELO_smtp {
    822     my ($client) = @_;
    823 
    824     # TODO: Get the IP address of the client connection to use in the HELO
    825     # response when the client doesn't specify one but for now use 127.0.0.1
    826     if(!$client) {
    827         $client = "[127.0.0.1]";
    828     }
    829 
    830     # Set the server type to SMTP
    831     $smtp_type = "SMTP";
    832 
    833     # Send the HELO response
    834     sendcontrol "250 $smtp_type pingpong test server Hello $client\r\n";
    835 
    836     # Store the client (as it may contain the test number)
    837     $smtp_client = $client;
    838 
    839     return 0;
    840 }
    841 
    842 sub MAIL_smtp {
    843     my ($args) = @_;
    844 
    845     logmsg "MAIL_smtp got $args\n";
    846 
    847     if(!$args) {
    848         sendcontrol "501 Unrecognized parameter\r\n";
    849     }
    850     else {
    851         my $from;
    852         my $size;
    853         my $smtputf8 = grep /^SMTPUTF8$/, @capabilities;
    854         my @elements = split(/ /, $args);
    855 
    856         # Get the FROM and SIZE parameters
    857         for my $e (@elements) {
    858             if($e =~ /^FROM:(.*)$/) {
    859                 $from = $1;
    860             }
    861             elsif($e =~ /^SIZE=(\d+)$/) {
    862                 $size = $1;
    863             }
    864         }
    865 
    866         # this server doesn't "validate" MAIL FROM addresses
    867         if(length($from)) {
    868             my @found;
    869             my $valid = 1;
    870 
    871             # Check the capabilities for SIZE and if the specified size is
    872             # greater than the message size then reject it
    873             if(@found = grep /^SIZE (\d+)$/, @capabilities) {
    874                 if($found[0] =~ /^SIZE (\d+)$/) {
    875                     if($size > $1) {
    876                         $valid = 0;
    877                     }
    878                 }
    879             }
    880 
    881             if(!$valid) {
    882                 sendcontrol "552 Message size too large\r\n";
    883             }
    884             else {
    885                 sendcontrol "250 Sender OK\r\n";
    886             }
    887         }
    888         else {
    889             sendcontrol "501 Invalid address\r\n";
    890         }
    891     }
    892 
    893     return 0;
    894 }
    895 
    896 sub RCPT_smtp {
    897     my ($args) = @_;
    898 
    899     logmsg "RCPT_smtp got $args\n";
    900 
    901     # Get the TO parameter
    902     if($args !~ /^TO:(.*)/) {
    903         sendcontrol "501 Unrecognized parameter\r\n";
    904     }
    905     else {
    906         my $smtputf8 = grep /^SMTPUTF8$/, @capabilities;
    907         my $to = $1;
    908 
    909         # Validate the to address (only a valid email address inside <> is
    910         # allowed, such as <user@example.com>)
    911         if((!$smtputf8 && $to =~
    912              /^<([a-zA-Z0-9._%+-]+)\@(([a-zA-Z0-9-]+)\.)+([a-zA-Z]{2,4})>$/) ||
    913            ($smtputf8 && $to =~
    914              /^<([a-zA-Z0-9\x{80}-\x{ff}._%+-]+)\@(([a-zA-Z0-9\x{80}-\x{ff}-]+)\.)+([a-zA-Z]{2,4})>$/)) {
    915             sendcontrol "250 Recipient OK\r\n";
    916         }
    917         else {
    918             sendcontrol "501 Invalid address\r\n";
    919         }
    920     }
    921 
    922     return 0;
    923 }
    924 
    925 sub DATA_smtp {
    926     my ($args) = @_;
    927 
    928     if($args) {
    929         sendcontrol "501 Unrecognized parameter\r\n";
    930     }
    931     elsif($smtp_client !~ /^(\d*)$/) {
    932         sendcontrol "501 Invalid arguments\r\n";
    933     }
    934     else {
    935         sendcontrol "354 Show me the mail\r\n";
    936 
    937         my $testno = $smtp_client;
    938         my $filename = "$logdir/upload.$testno";
    939 
    940         logmsg "Store test number $testno in $filename\n";
    941 
    942         open(my $file, ">", "$filename") ||
    943             return 0; # failed to open output
    944 
    945         my $line;
    946         my $ulsize=0;
    947         my $disc=0;
    948         my $raw;
    949         while(5 == (sysread \*SFREAD, $line, 5)) {
    950             if($line eq "DATA\n") {
    951                 my $i;
    952                 my $eob;
    953                 sysread \*SFREAD, $i, 5;
    954 
    955                 my $size = 0;
    956                 if($i =~ /^([0-9a-fA-F]{4})\n/) {
    957                     $size = hex($1);
    958                 }
    959 
    960                 read_mainsockf(\$line, $size);
    961 
    962                 $ulsize += $size;
    963                 print $file $line if(!$nosave);
    964 
    965                 $raw .= $line;
    966                 if($raw =~ /(?:^|\x0d\x0a)\x2e\x0d\x0a/) {
    967                     # end of data marker!
    968                     $eob = 1;
    969                 }
    970 
    971                 logmsg "> Appending $size bytes to file\n";
    972 
    973                 if($eob) {
    974                     logmsg "Found SMTP EOB marker\n";
    975                     last;
    976                 }
    977             }
    978             elsif($line eq "DISC\n") {
    979                 # disconnect!
    980                 $disc=1;
    981                 printf SFWRITE "ACKD\n";
    982                 last;
    983             }
    984             else {
    985                 logmsg "No support for: $line";
    986                 last;
    987             }
    988         }
    989 
    990         if($nosave) {
    991             print $file "$ulsize bytes would've been stored here\n";
    992         }
    993 
    994         close($file);
    995 
    996         logmsg "received $ulsize bytes upload\n";
    997 
    998         sendcontrol "250 OK, data received!\r\n";
    999     }
   1000 
   1001     return 0;
   1002 }
   1003 
   1004 sub NOOP_smtp {
   1005     my ($args) = @_;
   1006 
   1007     if($args) {
   1008         sendcontrol "501 Unrecognized parameter\r\n";
   1009     }
   1010     else {
   1011         sendcontrol "250 OK\r\n";
   1012     }
   1013 
   1014     return 0;
   1015 }
   1016 
   1017 sub RSET_smtp {
   1018     my ($args) = @_;
   1019 
   1020     if($args) {
   1021         sendcontrol "501 Unrecognized parameter\r\n";
   1022     }
   1023     else {
   1024         sendcontrol "250 Resetting\r\n";
   1025     }
   1026 
   1027     return 0;
   1028 }
   1029 
   1030 sub HELP_smtp {
   1031     my ($args) = @_;
   1032 
   1033     # One argument is optional
   1034     if($args) {
   1035         logmsg "HELP_smtp got $args\n";
   1036     }
   1037 
   1038     if($smtp_client eq "verifiedserver") {
   1039         # This is the secret command that verifies that this actually is
   1040         # the curl test server
   1041         sendcontrol "214 WE ROOLZ: $$\r\n";
   1042 
   1043         if($verbose) {
   1044             print STDERR "FTPD: We returned proof we are the test server\n";
   1045         }
   1046 
   1047         logmsg "return proof we are we\n";
   1048     }
   1049     else {
   1050         sendcontrol "214-This server supports the following commands:\r\n";
   1051 
   1052         if(@auth_mechs) {
   1053             sendcontrol "214 HELO EHLO RCPT DATA RSET MAIL VRFY EXPN QUIT HELP AUTH\r\n";
   1054         }
   1055         else {
   1056             sendcontrol "214 HELO EHLO RCPT DATA RSET MAIL VRFY EXPN QUIT HELP\r\n";
   1057         }
   1058     }
   1059 
   1060     return 0;
   1061 }
   1062 
   1063 sub VRFY_smtp {
   1064     my ($args) = @_;
   1065     my ($username, $address) = split(/ /, $args, 2);
   1066 
   1067     logmsg "VRFY_smtp got $args\n";
   1068 
   1069     if($username eq "") {
   1070         sendcontrol "501 Unrecognized parameter\r\n";
   1071     }
   1072     else {
   1073         my $smtputf8 = grep /^SMTPUTF8$/, @capabilities;
   1074 
   1075         # Validate the username (only a valid local or external username is
   1076         # allowed, such as user or user@example.com)
   1077         if((!$smtputf8 && $username =~
   1078            /^([a-zA-Z0-9._%+-]+)(\@(([a-zA-Z0-9-]+)\.)+([a-zA-Z]{2,4}))?$/) ||
   1079            ($smtputf8 && $username =~
   1080            /^([a-zA-Z0-9\x{80}-\x{ff}._%+-]+)(\@(([a-zA-Z0-9\x{80}-\x{ff}-]+)\.)+([a-zA-Z]{2,4}))?$/)) {
   1081 
   1082             my @data = getreplydata($smtp_client);
   1083 
   1084             if(!@data) {
   1085                 if($username !~
   1086                    /^([a-zA-Z0-9._%+-]+)\@(([a-zA-Z0-9-]+)\.)+([a-zA-Z]{2,4})$/) {
   1087                   push @data, "250 <$username\@example.com>\r\n"
   1088                 }
   1089                 else {
   1090                   push @data, "250 <$username>\r\n"
   1091                 }
   1092             }
   1093 
   1094             for my $d (@data) {
   1095                 sendcontrol $d;
   1096             }
   1097         }
   1098         else {
   1099             sendcontrol "501 Invalid address\r\n";
   1100         }
   1101     }
   1102 
   1103     return 0;
   1104 }
   1105 
   1106 sub EXPN_smtp {
   1107     my ($list_name) = @_;
   1108 
   1109     logmsg "EXPN_smtp got $list_name\n";
   1110 
   1111     if(!$list_name) {
   1112         sendcontrol "501 Unrecognized parameter\r\n";
   1113     }
   1114     else {
   1115         my @data = getreplydata($smtp_client);
   1116 
   1117         for my $d (@data) {
   1118             sendcontrol $d;
   1119         }
   1120     }
   1121 
   1122     return 0;
   1123 }
   1124 
   1125 sub QUIT_smtp {
   1126     sendcontrol "221 curl $smtp_type server signing off\r\n";
   1127 
   1128     return 0;
   1129 }
   1130 
   1131 # What was deleted by IMAP STORE / POP3 DELE commands
   1132 my @deleted;
   1133 
   1134 ################
   1135 ################ IMAP commands
   1136 ################
   1137 
   1138 # global to allow the command functions to read it
   1139 my $cmdid;
   1140 
   1141 # what was picked by SELECT
   1142 my $selected;
   1143 
   1144 # Any IMAP parameter can come in escaped and in double quotes.
   1145 # This function is dumb (so far) and just removes the quotes if present.
   1146 sub fix_imap_params {
   1147     foreach (@_) {
   1148         $_ = $1 if /^"(.*)"$/;
   1149     }
   1150 }
   1151 
   1152 sub CAPABILITY_imap {
   1153     if((!@capabilities) && (!@auth_mechs)) {
   1154         sendcontrol "$cmdid BAD Command\r\n";
   1155     }
   1156     else {
   1157         my $data;
   1158 
   1159         # Calculate the CAPABILITY response
   1160         $data = "* CAPABILITY IMAP4";
   1161 
   1162         for my $c (@capabilities) {
   1163             $data .= " $c";
   1164         }
   1165 
   1166         for my $am (@auth_mechs) {
   1167             $data .= " AUTH=$am";
   1168         }
   1169 
   1170         $data .= " pingpong test server\r\n";
   1171 
   1172         # Send the CAPABILITY response
   1173         sendcontrol $data;
   1174         sendcontrol "$cmdid OK CAPABILITY completed\r\n";
   1175     }
   1176 
   1177     return 0;
   1178 }
   1179 
   1180 sub LOGIN_imap {
   1181     my ($args) = @_;
   1182     my ($user, $password) = split(/ /, $args, 2);
   1183     fix_imap_params($user, $password);
   1184 
   1185     logmsg "LOGIN_imap got $args\n";
   1186 
   1187     if($user eq "") {
   1188         sendcontrol "$cmdid BAD Command Argument\r\n";
   1189     }
   1190     else {
   1191         sendcontrol "$cmdid OK LOGIN completed\r\n";
   1192     }
   1193 
   1194     return 0;
   1195 }
   1196 
   1197 sub SELECT_imap {
   1198     my ($mailbox) = @_;
   1199     fix_imap_params($mailbox);
   1200 
   1201     logmsg "SELECT_imap got test $mailbox\n";
   1202 
   1203     if($mailbox eq "") {
   1204         sendcontrol "$cmdid BAD Command Argument\r\n";
   1205     }
   1206     else {
   1207         # Example from RFC 3501, 6.3.1. SELECT Command
   1208         sendcontrol "* 172 EXISTS\r\n";
   1209         sendcontrol "* 1 RECENT\r\n";
   1210         sendcontrol "* OK [UNSEEN 12] Message 12 is first unseen\r\n";
   1211         sendcontrol "* OK [UIDVALIDITY 3857529045] UIDs valid\r\n";
   1212         sendcontrol "* OK [UIDNEXT 4392] Predicted next UID\r\n";
   1213         sendcontrol "* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n";
   1214         sendcontrol "* OK [PERMANENTFLAGS (\\Deleted \\Seen \\*)] Limited\r\n";
   1215         sendcontrol "$cmdid OK [READ-WRITE] SELECT completed\r\n";
   1216 
   1217         $selected = $mailbox;
   1218     }
   1219 
   1220     return 0;
   1221 }
   1222 
   1223 sub FETCH_imap {
   1224     my ($args) = @_;
   1225     my ($uid, $how) = split(/ /, $args, 2);
   1226     fix_imap_params($uid, $how);
   1227 
   1228     logmsg "FETCH_imap got $args\n";
   1229 
   1230     if($selected eq "") {
   1231         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1232     }
   1233     else {
   1234         my @data;
   1235         my $size;
   1236 
   1237         if($selected eq "verifiedserver") {
   1238             # this is the secret command that verifies that this actually is
   1239             # the curl test server
   1240             my $response = "WE ROOLZ: $$\r\n";
   1241             if($verbose) {
   1242                 print STDERR "FTPD: We returned proof we are the test server\n";
   1243             }
   1244             $data[0] = $response;
   1245             logmsg "return proof we are we\n";
   1246         }
   1247         else {
   1248             # send mail content
   1249             logmsg "retrieve a mail\n";
   1250 
   1251             @data = getreplydata($selected);
   1252         }
   1253 
   1254         for (@data) {
   1255             $size += length($_);
   1256         }
   1257 
   1258         sendcontrol "* $uid FETCH ($how {$size}\r\n";
   1259 
   1260         for my $d (@data) {
   1261             sendcontrol $d;
   1262         }
   1263 
   1264         # Set the custom extra header content with POSTFETCH
   1265         sendcontrol "$postfetch)\r\n";
   1266         sendcontrol "$cmdid OK FETCH completed\r\n";
   1267     }
   1268 
   1269     return 0;
   1270 }
   1271 
   1272 sub APPEND_imap {
   1273     my ($args) = @_;
   1274 
   1275     logmsg "APPEND_imap got $args\r\n";
   1276 
   1277     $args =~ /^([^ ]+) [^{]*\{(\d+)\}$/;
   1278     my ($mailbox, $size) = ($1, $2);
   1279     fix_imap_params($mailbox);
   1280 
   1281     if($mailbox eq "") {
   1282         sendcontrol "$cmdid BAD Command Argument\r\n";
   1283     }
   1284     else {
   1285         sendcontrol "+ Ready for literal data\r\n";
   1286 
   1287         my $testno = $mailbox;
   1288         my $filename = "$logdir/upload.$testno";
   1289 
   1290         logmsg "Store test number $testno in $filename\n";
   1291 
   1292         open(my $file, ">", "$filename") ||
   1293             return 0; # failed to open output
   1294 
   1295         my $received = 0;
   1296         my $line;
   1297         while(5 == (sysread \*SFREAD, $line, 5)) {
   1298             if($line eq "DATA\n") {
   1299                 sysread \*SFREAD, $line, 5;
   1300 
   1301                 my $chunksize = 0;
   1302                 if($line =~ /^([0-9a-fA-F]{4})\n/) {
   1303                     $chunksize = hex($1);
   1304                 }
   1305 
   1306                 read_mainsockf(\$line, $chunksize);
   1307 
   1308                 my $left = $size - $received;
   1309                 my $datasize = ($left > $chunksize) ? $chunksize : $left;
   1310 
   1311                 if($datasize > 0) {
   1312                     logmsg "> Appending $datasize bytes to file\n";
   1313                     print $file substr($line, 0, $datasize) if(!$nosave);
   1314                     $line = substr($line, $datasize);
   1315 
   1316                     $received += $datasize;
   1317                     if($received == $size) {
   1318                         logmsg "Received all data, waiting for final CRLF.\n";
   1319                     }
   1320                 }
   1321 
   1322                 if($received == $size && $line eq "\r\n") {
   1323                     last;
   1324                 }
   1325             }
   1326             elsif($line eq "DISC\n") {
   1327                 logmsg "Unexpected disconnect!\n";
   1328                 printf SFWRITE "ACKD\n";
   1329                 last;
   1330             }
   1331             else {
   1332                 logmsg "No support for: $line";
   1333                 last;
   1334             }
   1335         }
   1336 
   1337         if($nosave) {
   1338             print $file "$size bytes would've been stored here\n";
   1339         }
   1340 
   1341         close($file);
   1342 
   1343         logmsg "received $size bytes upload\n";
   1344 
   1345         sendcontrol "$cmdid OK APPEND completed\r\n";
   1346     }
   1347 
   1348     return 0;
   1349 }
   1350 
   1351 sub STORE_imap {
   1352     my ($args) = @_;
   1353     my ($uid, $what, $value) = split(/ /, $args, 3);
   1354     fix_imap_params($uid);
   1355 
   1356     logmsg "STORE_imap got $args\n";
   1357 
   1358     if($selected eq "") {
   1359         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1360     }
   1361     elsif(($uid eq "") || ($what ne "+Flags") || ($value eq "")) {
   1362         sendcontrol "$cmdid BAD Command Argument\r\n";
   1363     }
   1364     else {
   1365         if($value eq "\\Deleted") {
   1366             push(@deleted, $uid);
   1367         }
   1368 
   1369         sendcontrol "* $uid FETCH (FLAGS (\\Seen $value))\r\n";
   1370         sendcontrol "$cmdid OK STORE completed\r\n";
   1371     }
   1372 
   1373     return 0;
   1374 }
   1375 
   1376 sub LIST_imap {
   1377     my ($args) = @_;
   1378     my ($reference, $mailbox) = split(/ /, $args, 2);
   1379     fix_imap_params($reference, $mailbox);
   1380 
   1381     logmsg "LIST_imap got $args\n";
   1382 
   1383     if($reference eq "") {
   1384         sendcontrol "$cmdid BAD Command Argument\r\n";
   1385     }
   1386     elsif($reference eq "verifiedserver") {
   1387         # this is the secret command that verifies that this actually is
   1388         # the curl test server
   1389         sendcontrol "* LIST () \"/\" \"WE ROOLZ: $$\"\r\n";
   1390         sendcontrol "$cmdid OK LIST Completed\r\n";
   1391 
   1392         if($verbose) {
   1393             print STDERR "FTPD: We returned proof we are the test server\n";
   1394         }
   1395 
   1396         logmsg "return proof we are we\n";
   1397     }
   1398     else {
   1399         my @data = getreplydata($reference);
   1400 
   1401         for my $d (@data) {
   1402             sendcontrol $d;
   1403         }
   1404 
   1405         sendcontrol "$cmdid OK LIST Completed\r\n";
   1406     }
   1407 
   1408     return 0;
   1409 }
   1410 
   1411 sub LSUB_imap {
   1412     my ($args) = @_;
   1413     my ($reference, $mailbox) = split(/ /, $args, 2);
   1414     fix_imap_params($reference, $mailbox);
   1415 
   1416     logmsg "LSUB_imap got $args\n";
   1417 
   1418     if($reference eq "") {
   1419         sendcontrol "$cmdid BAD Command Argument\r\n";
   1420     }
   1421     else {
   1422         my @data = getreplydata($reference);
   1423 
   1424         for my $d (@data) {
   1425             sendcontrol $d;
   1426         }
   1427 
   1428         sendcontrol "$cmdid OK LSUB Completed\r\n";
   1429     }
   1430 
   1431     return 0;
   1432 }
   1433 
   1434 sub EXAMINE_imap {
   1435     my ($mailbox) = @_;
   1436     fix_imap_params($mailbox);
   1437 
   1438     logmsg "EXAMINE_imap got $mailbox\n";
   1439 
   1440     if($mailbox eq "") {
   1441         sendcontrol "$cmdid BAD Command Argument\r\n";
   1442     }
   1443     else {
   1444         my @data = getreplydata($mailbox);
   1445 
   1446         for my $d (@data) {
   1447             sendcontrol $d;
   1448         }
   1449 
   1450         sendcontrol "$cmdid OK [READ-ONLY] EXAMINE completed\r\n";
   1451     }
   1452 
   1453     return 0;
   1454 }
   1455 
   1456 sub STATUS_imap {
   1457     my ($args) = @_;
   1458     my ($mailbox, $what) = split(/ /, $args, 2);
   1459     fix_imap_params($mailbox);
   1460 
   1461     logmsg "STATUS_imap got $args\n";
   1462 
   1463     if($mailbox eq "") {
   1464         sendcontrol "$cmdid BAD Command Argument\r\n";
   1465     }
   1466     else {
   1467         my @data = getreplydata($mailbox);
   1468 
   1469         for my $d (@data) {
   1470             sendcontrol $d;
   1471         }
   1472 
   1473         sendcontrol "$cmdid OK STATUS completed\r\n";
   1474     }
   1475 
   1476     return 0;
   1477 }
   1478 
   1479 sub SEARCH_imap {
   1480     my ($what) = @_;
   1481     fix_imap_params($what);
   1482 
   1483     logmsg "SEARCH_imap got $what\n";
   1484 
   1485     if($selected eq "") {
   1486         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1487     }
   1488     elsif($what eq "") {
   1489         sendcontrol "$cmdid BAD Command Argument\r\n";
   1490     }
   1491     else {
   1492         my @data = getreplydata($selected);
   1493 
   1494         for my $d (@data) {
   1495             sendcontrol $d;
   1496         }
   1497 
   1498         sendcontrol "$cmdid OK SEARCH completed\r\n";
   1499     }
   1500 
   1501     return 0;
   1502 }
   1503 
   1504 sub CREATE_imap {
   1505     my ($args) = @_;
   1506     fix_imap_params($args);
   1507 
   1508     logmsg "CREATE_imap got $args\n";
   1509 
   1510     if($args eq "") {
   1511         sendcontrol "$cmdid BAD Command Argument\r\n";
   1512     }
   1513     else {
   1514         sendcontrol "$cmdid OK CREATE completed\r\n";
   1515     }
   1516 
   1517     return 0;
   1518 }
   1519 
   1520 sub DELETE_imap {
   1521     my ($args) = @_;
   1522     fix_imap_params($args);
   1523 
   1524     logmsg "DELETE_imap got $args\n";
   1525 
   1526     if($args eq "") {
   1527         sendcontrol "$cmdid BAD Command Argument\r\n";
   1528     }
   1529     else {
   1530         sendcontrol "$cmdid OK DELETE completed\r\n";
   1531     }
   1532 
   1533     return 0;
   1534 }
   1535 
   1536 sub RENAME_imap {
   1537     my ($args) = @_;
   1538     my ($from_mailbox, $to_mailbox) = split(/ /, $args, 2);
   1539     fix_imap_params($from_mailbox, $to_mailbox);
   1540 
   1541     logmsg "RENAME_imap got $args\n";
   1542 
   1543     if(($from_mailbox eq "") || ($to_mailbox eq "")) {
   1544         sendcontrol "$cmdid BAD Command Argument\r\n";
   1545     }
   1546     else {
   1547         sendcontrol "$cmdid OK RENAME completed\r\n";
   1548     }
   1549 
   1550     return 0;
   1551 }
   1552 
   1553 sub CHECK_imap {
   1554     if($selected eq "") {
   1555         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1556     }
   1557     else {
   1558         sendcontrol "$cmdid OK CHECK completed\r\n";
   1559     }
   1560 
   1561     return 0;
   1562 }
   1563 
   1564 sub CLOSE_imap {
   1565     if($selected eq "") {
   1566         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1567     }
   1568     elsif(!@deleted) {
   1569         sendcontrol "$cmdid BAD Command Argument\r\n";
   1570     }
   1571     else {
   1572         sendcontrol "$cmdid OK CLOSE completed\r\n";
   1573 
   1574         @deleted = ();
   1575     }
   1576 
   1577     return 0;
   1578 }
   1579 
   1580 sub EXPUNGE_imap {
   1581     if($selected eq "") {
   1582         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1583     }
   1584     else {
   1585         if(!@deleted) {
   1586             # Report the number of existing messages as per the SELECT
   1587             # command
   1588             sendcontrol "* 172 EXISTS\r\n";
   1589         }
   1590         else {
   1591             # Report the message UIDs being deleted
   1592             for my $d (@deleted) {
   1593                 sendcontrol "* $d EXPUNGE\r\n";
   1594             }
   1595 
   1596             @deleted = ();
   1597         }
   1598 
   1599         sendcontrol "$cmdid OK EXPUNGE completed\r\n";
   1600     }
   1601 
   1602     return 0;
   1603 }
   1604 
   1605 sub COPY_imap {
   1606     my ($args) = @_;
   1607     my ($uid, $mailbox) = split(/ /, $args, 2);
   1608     fix_imap_params($uid, $mailbox);
   1609 
   1610     logmsg "COPY_imap got $args\n";
   1611 
   1612     if(($uid eq "") || ($mailbox eq "")) {
   1613         sendcontrol "$cmdid BAD Command Argument\r\n";
   1614     }
   1615     else {
   1616         sendcontrol "$cmdid OK COPY completed\r\n";
   1617     }
   1618 
   1619     return 0;
   1620 }
   1621 
   1622 sub IDLE_imap {
   1623     logmsg "IDLE received\n";
   1624 
   1625     sendcontrol "+ entering idle mode\r\n";
   1626     return 0;
   1627 }
   1628 
   1629 sub UID_imap {
   1630     my ($args) = @_;
   1631     my ($command) = split(/ /, $args, 1);
   1632     fix_imap_params($command);
   1633 
   1634     logmsg "UID_imap got $args\n";
   1635 
   1636     if($selected eq "") {
   1637         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
   1638     }
   1639     elsif(substr($command, 0, 5) eq "FETCH"){
   1640         my $func = $commandfunc{"FETCH"};
   1641         if($func) {
   1642             &$func($args, $command);
   1643         }
   1644     }
   1645     elsif(($command ne "COPY") &&
   1646           ($command ne "STORE") && ($command ne "SEARCH")) {
   1647         sendcontrol "$cmdid BAD Command Argument\r\n";
   1648     }
   1649     else {
   1650         my @data = getreplydata($selected);
   1651 
   1652         for my $d (@data) {
   1653             sendcontrol $d;
   1654         }
   1655 
   1656         sendcontrol "$cmdid OK $command completed\r\n";
   1657     }
   1658 
   1659     return 0;
   1660 }
   1661 
   1662 sub NOOP_imap {
   1663     my ($args) = @_;
   1664     my @data = (
   1665         "* 22 EXPUNGE\r\n",
   1666         "* 23 EXISTS\r\n",
   1667         "* 3 RECENT\r\n",
   1668         "* 14 FETCH (FLAGS (\\Seen \\Deleted))\r\n",
   1669     );
   1670 
   1671     if($args) {
   1672         sendcontrol "$cmdid BAD Command Argument\r\n";
   1673     }
   1674     else {
   1675         for my $d (@data) {
   1676             sendcontrol $d;
   1677         }
   1678 
   1679         sendcontrol "$cmdid OK NOOP completed\r\n";
   1680     }
   1681 
   1682     return 0;
   1683 }
   1684 
   1685 sub LOGOUT_imap {
   1686     sendcontrol "* BYE curl IMAP server signing off\r\n";
   1687     sendcontrol "$cmdid OK LOGOUT completed\r\n";
   1688 
   1689     return 0;
   1690 }
   1691 
   1692 ################
   1693 ################ POP3 commands
   1694 ################
   1695 
   1696 # Who is attempting to log in
   1697 my $username;
   1698 
   1699 sub CAPA_pop3 {
   1700     my @list = ();
   1701     my $mechs;
   1702 
   1703     # Calculate the capability list based on the specified capabilities
   1704     # (except APOP) and any authentication mechanisms
   1705     for my $c (@capabilities) {
   1706         push @list, "$c\r\n" unless $c eq "APOP";
   1707     }
   1708 
   1709     for my $am (@auth_mechs) {
   1710         if(!$mechs) {
   1711             $mechs = "$am";
   1712         }
   1713         else {
   1714             $mechs .= " $am";
   1715         }
   1716     }
   1717 
   1718     if($mechs) {
   1719         push @list, "SASL $mechs\r\n";
   1720     }
   1721 
   1722     if(!@list) {
   1723         sendcontrol "-ERR Unrecognized command\r\n";
   1724     }
   1725     else {
   1726         my @data = ();
   1727 
   1728         # Calculate the CAPA response
   1729         push @data, "+OK List of capabilities follows\r\n";
   1730 
   1731         for my $l (@list) {
   1732             push @data, "$l\r\n";
   1733         }
   1734 
   1735         push @data, "IMPLEMENTATION POP3 pingpong test server\r\n";
   1736 
   1737         # Send the CAPA response
   1738         for my $d (@data) {
   1739             sendcontrol $d;
   1740         }
   1741 
   1742         # End with the magic 3-byte end of listing marker
   1743         sendcontrol ".\r\n";
   1744     }
   1745 
   1746     return 0;
   1747 }
   1748 
   1749 sub APOP_pop3 {
   1750     my ($args) = @_;
   1751     my ($user, $secret) = split(/ /, $args, 2);
   1752 
   1753     if(!grep /^APOP$/, @capabilities) {
   1754         sendcontrol "-ERR Unrecognized command\r\n";
   1755     }
   1756     elsif(($user eq "") || ($secret eq "")) {
   1757         sendcontrol "-ERR Protocol error\r\n";
   1758     }
   1759     else {
   1760         my $digest = Digest::MD5::md5_hex($POP3_TIMESTAMP, $TEXT_PASSWORD);
   1761 
   1762         if($secret ne $digest) {
   1763             sendcontrol "-ERR Login failure\r\n";
   1764         }
   1765         else {
   1766             sendcontrol "+OK Login successful\r\n";
   1767         }
   1768     }
   1769 
   1770     return 0;
   1771 }
   1772 
   1773 sub AUTH_pop3 {
   1774     if(!@auth_mechs) {
   1775         sendcontrol "-ERR Unrecognized command\r\n";
   1776     }
   1777     else {
   1778         my @data = ();
   1779 
   1780         # Calculate the AUTH response
   1781         push @data, "+OK List of supported mechanisms follows\r\n";
   1782 
   1783         for my $am (@auth_mechs) {
   1784             push @data, "$am\r\n";
   1785         }
   1786 
   1787         # Send the AUTH response
   1788         for my $d (@data) {
   1789             sendcontrol $d;
   1790         }
   1791 
   1792         # End with the magic 3-byte end of listing marker
   1793         sendcontrol ".\r\n";
   1794     }
   1795 
   1796     return 0;
   1797 }
   1798 
   1799 sub USER_pop3 {
   1800     my ($user) = @_;
   1801 
   1802     logmsg "USER_pop3 got $user\n";
   1803 
   1804     if(!$user) {
   1805         sendcontrol "-ERR Protocol error\r\n";
   1806     }
   1807     else {
   1808         $username = $user;
   1809 
   1810         sendcontrol "+OK\r\n";
   1811     }
   1812 
   1813     return 0;
   1814 }
   1815 
   1816 sub PASS_pop3 {
   1817     my ($password) = @_;
   1818 
   1819     logmsg "PASS_pop3 got $password\n";
   1820 
   1821     sendcontrol "+OK Login successful\r\n";
   1822 
   1823     return 0;
   1824 }
   1825 
   1826 sub RETR_pop3 {
   1827     my ($msgid) = @_;
   1828     my @data;
   1829 
   1830     if($msgid =~ /^verifiedserver$/) {
   1831         # this is the secret command that verifies that this actually is
   1832         # the curl test server
   1833         my $response = "WE ROOLZ: $$\r\n";
   1834         if($verbose) {
   1835             print STDERR "FTPD: We returned proof we are the test server\n";
   1836         }
   1837         $data[0] = $response;
   1838         logmsg "return proof we are we\n";
   1839     }
   1840     else {
   1841         # send mail content
   1842         logmsg "retrieve a mail\n";
   1843 
   1844         @data = getreplydata($msgid);
   1845     }
   1846 
   1847     sendcontrol "+OK Mail transfer starts\r\n";
   1848 
   1849     for my $d (@data) {
   1850         sendcontrol $d;
   1851     }
   1852 
   1853     # end with the magic 3-byte end of mail marker, assumes that the
   1854     # mail body ends with a CRLF!
   1855     sendcontrol ".\r\n";
   1856 
   1857     return 0;
   1858 }
   1859 
   1860 sub LIST_pop3 {
   1861     my @data = getpart("reply", "data");
   1862 
   1863     logmsg "retrieve a message list\n";
   1864 
   1865     sendcontrol "+OK Listing starts\r\n";
   1866 
   1867     for my $d (@data) {
   1868         sendcontrol $d;
   1869     }
   1870 
   1871     # End with the magic 3-byte end of listing marker
   1872     sendcontrol ".\r\n";
   1873 
   1874     return 0;
   1875 }
   1876 
   1877 sub DELE_pop3 {
   1878     my ($msgid) = @_;
   1879 
   1880     logmsg "DELE_pop3 got $msgid\n";
   1881 
   1882     if(!$msgid) {
   1883         sendcontrol "-ERR Protocol error\r\n";
   1884     }
   1885     else {
   1886         push (@deleted, $msgid);
   1887 
   1888         sendcontrol "+OK\r\n";
   1889     }
   1890 
   1891     return 0;
   1892 }
   1893 
   1894 sub STAT_pop3 {
   1895     my ($args) = @_;
   1896 
   1897     if($args) {
   1898         sendcontrol "-ERR Protocol error\r\n";
   1899     }
   1900     else {
   1901         # Send statistics for the built-in fake message list as
   1902         # detailed in the LIST_pop3 function above
   1903         sendcontrol "+OK 3 4294967800\r\n";
   1904     }
   1905 
   1906     return 0;
   1907 }
   1908 
   1909 sub NOOP_pop3 {
   1910     my ($args) = @_;
   1911 
   1912     if($args) {
   1913         sendcontrol "-ERR Protocol error\r\n";
   1914     }
   1915     else {
   1916         sendcontrol "+OK\r\n";
   1917     }
   1918 
   1919     return 0;
   1920 }
   1921 
   1922 sub UIDL_pop3 {
   1923     # This is a built-in fake-message UID list
   1924     my @data = (
   1925         "1 1\r\n",
   1926         "2 2\r\n",
   1927         "3 4\r\n", # Note that UID 3 is a simulated "deleted" message
   1928     );
   1929 
   1930     if(!grep /^UIDL$/, @capabilities) {
   1931         sendcontrol "-ERR Unrecognized command\r\n";
   1932     }
   1933     else {
   1934         logmsg "retrieve a message UID list\n";
   1935 
   1936         sendcontrol "+OK Listing starts\r\n";
   1937 
   1938         for my $d (@data) {
   1939             sendcontrol $d;
   1940         }
   1941 
   1942         # End with the magic 3-byte end of listing marker
   1943         sendcontrol ".\r\n";
   1944     }
   1945 
   1946     return 0;
   1947 }
   1948 
   1949 sub TOP_pop3 {
   1950     my ($args) = @_;
   1951     my ($msgid, $lines) = split(/ /, $args, 2);
   1952 
   1953     logmsg "TOP_pop3 got $args\n";
   1954 
   1955     if(!grep /^TOP$/, @capabilities) {
   1956         sendcontrol "-ERR Unrecognized command\r\n";
   1957     }
   1958     elsif(($msgid eq "") || ($lines eq "")) {
   1959         sendcontrol "-ERR Protocol error\r\n";
   1960     }
   1961     else {
   1962         if($lines == "0") {
   1963             logmsg "retrieve header of mail\n";
   1964         }
   1965         else {
   1966             logmsg "retrieve top $lines lines of mail\n";
   1967         }
   1968 
   1969         my @data = getreplydata($msgid);
   1970 
   1971         sendcontrol "+OK Mail transfer starts\r\n";
   1972 
   1973         # Send mail content
   1974         for my $d (@data) {
   1975             sendcontrol $d;
   1976         }
   1977 
   1978         # End with the magic 3-byte end of mail marker, assumes that the
   1979         # mail body ends with a CRLF!
   1980         sendcontrol ".\r\n";
   1981     }
   1982 
   1983     return 0;
   1984 }
   1985 
   1986 sub RSET_pop3 {
   1987     my ($args) = @_;
   1988 
   1989     if($args) {
   1990         sendcontrol "-ERR Protocol error\r\n";
   1991     }
   1992     else {
   1993         if(@deleted) {
   1994             logmsg "resetting @deleted message(s)\n";
   1995 
   1996             @deleted = ();
   1997         }
   1998 
   1999         sendcontrol "+OK\r\n";
   2000     }
   2001 
   2002     return 0;
   2003 }
   2004 
   2005 sub QUIT_pop3 {
   2006     if(@deleted) {
   2007         logmsg "deleting @deleted message(s)\n";
   2008 
   2009         @deleted = ();
   2010     }
   2011 
   2012     sendcontrol "+OK curl POP3 server signing off\r\n";
   2013 
   2014     return 0;
   2015 }
   2016 
   2017 ################
   2018 ################ FTP commands
   2019 ################
   2020 my $rest=0;
   2021 sub REST_ftp {
   2022     $rest = $_[0];
   2023     logmsg "Set REST position to $rest\n"
   2024 }
   2025 
   2026 sub switch_directory_goto {
   2027     my $target_dir = $_;
   2028 
   2029     if(!$ftptargetdir) {
   2030         $ftptargetdir = "/";
   2031     }
   2032 
   2033     if($target_dir eq "") {
   2034         $ftptargetdir = "/";
   2035     }
   2036     elsif($target_dir eq "..") {
   2037         if($ftptargetdir eq "/") {
   2038             $ftptargetdir = "/";
   2039         }
   2040         else {
   2041             $ftptargetdir =~ s/[[:alnum:]]+\/$//;
   2042         }
   2043     }
   2044     else {
   2045         $ftptargetdir .= $target_dir . "/";
   2046     }
   2047 }
   2048 
   2049 sub switch_directory {
   2050     my $target_dir = $_[0];
   2051 
   2052     if($target_dir =~ /^test-(\d+)/) {
   2053         $cwd_testno = $1;
   2054     }
   2055     elsif($target_dir eq "/") {
   2056         $ftptargetdir = "/";
   2057     }
   2058     else {
   2059         my @dirs = split("/", $target_dir);
   2060         for(@dirs) {
   2061           switch_directory_goto($_);
   2062         }
   2063     }
   2064 }
   2065 
   2066 sub CWD_ftp {
   2067   my ($folder, $fullcommand) = $_[0];
   2068   switch_directory($folder);
   2069   if($ftptargetdir =~ /^\/fully_simulated/) {
   2070       $ftplistparserstate = "enabled";
   2071       logmsg "enabled FTP list parser mode\n";
   2072   }
   2073   else {
   2074     undef $ftplistparserstate;
   2075   }
   2076 }
   2077 
   2078 sub PWD_ftp {
   2079     my $mydir;
   2080     $mydir = $ftptargetdir ? $ftptargetdir : "/";
   2081 
   2082     if($mydir ne "/") {
   2083         $mydir =~ s/\/$//;
   2084     }
   2085     sendcontrol "257 \"$mydir\" is current directory\r\n";
   2086 }
   2087 
   2088 sub LIST_ftp {
   2089     #  print "150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes)\r\n";
   2090 
   2091     if($datasockf_conn eq 'no') {
   2092         if($nodataconn425) {
   2093             sendcontrol "150 Opening data connection\r\n";
   2094             sendcontrol "425 Can't open data connection\r\n";
   2095         }
   2096         elsif($nodataconn421) {
   2097             sendcontrol "150 Opening data connection\r\n";
   2098             sendcontrol "421 Connection timed out\r\n";
   2099         }
   2100         elsif($nodataconn150) {
   2101             sendcontrol "150 Opening data connection\r\n";
   2102             # client shall timeout
   2103         }
   2104         else {
   2105             # client shall timeout
   2106         }
   2107         return 0;
   2108     }
   2109 
   2110     logmsg "pass LIST data on data connection\n";
   2111 
   2112     if($ftplistparserstate) {
   2113         # provide a synthetic response
   2114         my @ftpdir = ftp_contentlist($ftptargetdir);
   2115         # old hard-coded style
   2116         for(@ftpdir) {
   2117             senddata $_;
   2118         }
   2119     }
   2120     else {
   2121         my @data = getpart("reply", "data");
   2122         for(@data) {
   2123             my $send = $_;
   2124             # convert all \n to \r\n for ASCII transfer
   2125             $send =~ s/\r\n/\n/g;
   2126             $send =~ s/\n/\r\n/g;
   2127             logmsg "send $send as data\n";
   2128             senddata $send;
   2129         }
   2130     }
   2131     close_dataconn(0);
   2132     sendcontrol "226 ASCII transfer complete\r\n";
   2133     return 0;
   2134 }
   2135 
   2136 sub NLST_ftp {
   2137     my @ftpdir=("file", "with space", "fake", "..", " ..", "funny", "README");
   2138 
   2139     if($datasockf_conn eq 'no') {
   2140         if($nodataconn425) {
   2141             sendcontrol "150 Opening data connection\r\n";
   2142             sendcontrol "425 Can't open data connection\r\n";
   2143         }
   2144         elsif($nodataconn421) {
   2145             sendcontrol "150 Opening data connection\r\n";
   2146             sendcontrol "421 Connection timed out\r\n";
   2147         }
   2148         elsif($nodataconn150) {
   2149             sendcontrol "150 Opening data connection\r\n";
   2150             # client shall timeout
   2151         }
   2152         else {
   2153             # client shall timeout
   2154         }
   2155         return 0;
   2156     }
   2157 
   2158     logmsg "pass NLST data on data connection\n";
   2159     for(@ftpdir) {
   2160         senddata "$_\r\n";
   2161     }
   2162     close_dataconn(0);
   2163     sendcontrol "226 ASCII transfer complete\r\n";
   2164     return 0;
   2165 }
   2166 
   2167 sub MDTM_ftp {
   2168     my $testno = $_[0];
   2169     my $testpart = "";
   2170     if($testno > 10000) {
   2171         $testpart = $testno % 10000;
   2172         $testno = int($testno / 10000);
   2173     }
   2174 
   2175     loadtest("$logdir/test$testno");
   2176 
   2177     my @data = getpart("reply", "mdtm");
   2178 
   2179     my $reply = $data[0];
   2180     chomp $reply if($reply);
   2181 
   2182     if($reply && ($reply =~ /^[+-]?\d+$/) && ($reply < 0)) {
   2183         sendcontrol "550 $testno: no such file.\r\n";
   2184     }
   2185     elsif($reply) {
   2186         sendcontrol "$reply\r\n";
   2187     }
   2188     else {
   2189         sendcontrol "500 MDTM: no such command.\r\n";
   2190     }
   2191     return 0;
   2192 }
   2193 
   2194 sub SIZE_ftp {
   2195     my $testno = $_[0];
   2196 
   2197     if($ftplistparserstate) {
   2198         my $size = wildcard_filesize($ftptargetdir, $testno);
   2199         if($size == -1) {
   2200             sendcontrol "550 $testno: No such file or directory.\r\n";
   2201         }
   2202         else {
   2203             sendcontrol "213 $size\r\n";
   2204         }
   2205         return 0;
   2206     }
   2207 
   2208     if($testno =~ /^verifiedserver$/) {
   2209         my $response = "WE ROOLZ: $$\r\n";
   2210         my $size = length($response);
   2211         sendcontrol "213 $size\r\n";
   2212         return 0;
   2213     }
   2214 
   2215     if($testno =~ /(\d+)\/?$/) {
   2216         $testno = $1;
   2217     }
   2218     else {
   2219         print STDERR "SIZE_ftp: invalid test number: $testno\n";
   2220         return 1;
   2221     }
   2222 
   2223     my $testpart = "";
   2224     if($testno > 10000) {
   2225         $testpart = $testno % 10000;
   2226         $testno = int($testno / 10000);
   2227     }
   2228 
   2229     loadtest("$logdir/test$testno");
   2230     my @data = getpart("reply", "size");
   2231 
   2232     my $size = $data[0];
   2233 
   2234     if($size) {
   2235         $size += 0; # make it a number
   2236         if($size > -1) {
   2237             sendcontrol "213 $size\r\n";
   2238         }
   2239         else {
   2240             sendcontrol "550 $testno: No such file or directory.\r\n";
   2241         }
   2242     }
   2243     else {
   2244         $size=0;
   2245         @data = getpart("reply", "data$testpart");
   2246         for(@data) {
   2247             $size += length($_);
   2248         }
   2249         if($size) {
   2250             sendcontrol "213 $size\r\n";
   2251         }
   2252         else {
   2253             sendcontrol "550 $testno: No such file or directory.\r\n";
   2254         }
   2255     }
   2256     return 0;
   2257 }
   2258 
   2259 sub RETR_ftp {
   2260     my ($testno) = @_;
   2261 
   2262     if($datasockf_conn eq 'no') {
   2263         if($nodataconn425) {
   2264             sendcontrol "150 Opening data connection\r\n";
   2265             sendcontrol "425 Can't open data connection\r\n";
   2266         }
   2267         elsif($nodataconn421) {
   2268             sendcontrol "150 Opening data connection\r\n";
   2269             sendcontrol "421 Connection timed out\r\n";
   2270         }
   2271         elsif($nodataconn150) {
   2272             sendcontrol "150 Opening data connection\r\n";
   2273             # client shall timeout
   2274         }
   2275         else {
   2276             # client shall timeout
   2277         }
   2278         return 0;
   2279     }
   2280 
   2281     if($ftplistparserstate) {
   2282         my @content = wildcard_getfile($ftptargetdir, $testno);
   2283         if($content[0] == -1) {
   2284             #file not found
   2285         }
   2286         else {
   2287             my $size = length $content[1];
   2288             sendcontrol "150 Binary data connection for $testno ($size bytes).\r\n",
   2289             senddata $content[1];
   2290             close_dataconn(0);
   2291             sendcontrol "226 File transfer complete\r\n";
   2292         }
   2293         return 0;
   2294     }
   2295 
   2296     if($testno =~ /^verifiedserver$/) {
   2297         # this is the secret command that verifies that this actually is
   2298         # the curl test server
   2299         my $response = "WE ROOLZ: $$\r\n";
   2300         my $len = length($response);
   2301         sendcontrol "150 Binary junk ($len bytes).\r\n";
   2302         senddata "WE ROOLZ: $$\r\n";
   2303         close_dataconn(0);
   2304         sendcontrol "226 File transfer complete\r\n";
   2305         if($verbose) {
   2306             print STDERR "FTPD: We returned proof we are the test server\n";
   2307         }
   2308         return 0;
   2309     }
   2310 
   2311     $testno =~ s/^([^0-9]*)//;
   2312     my $testpart = "";
   2313     if($testno > 10000) {
   2314         $testpart = $testno % 10000;
   2315         $testno = int($testno / 10000);
   2316     }
   2317 
   2318     loadtest("$logdir/test$testno");
   2319 
   2320     my @data = getpart("reply", "data$testpart");
   2321 
   2322     my $size=0;
   2323     for(@data) {
   2324         $size += length($_);
   2325     }
   2326 
   2327     my %hash = getpartattr("reply", "data$testpart");
   2328 
   2329     if($size || $hash{'sendzero'}) {
   2330 
   2331         if($rest) {
   2332             # move read pointer forward
   2333             $size -= $rest;
   2334             logmsg "REST $rest was removed from size, makes $size left\n";
   2335             $rest = 0; # reset REST offset again
   2336         }
   2337         if($retrweirdo) {
   2338             sendcontrol "150 Binary data connection for $testno () ($size bytes).\r\n",
   2339             "226 File transfer complete\r\n";
   2340 
   2341             for(@data) {
   2342                 my $send = $_;
   2343                 senddata $send;
   2344             }
   2345             close_dataconn(0);
   2346             $retrweirdo=0; # switch off the weirdo again!
   2347         }
   2348         else {
   2349             my $sz = "($size bytes)";
   2350             if($retrnosize) {
   2351                 $sz = "size?";
   2352             }
   2353             elsif($retrsize > 0) {
   2354                 $sz = "($retrsize bytes)";
   2355             }
   2356 
   2357             sendcontrol "150 Binary data connection for $testno ($testpart) $sz.\r\n";
   2358 
   2359             for(@data) {
   2360                 my $send = $_;
   2361                 senddata $send;
   2362             }
   2363             close_dataconn(0);
   2364             sendcontrol "226 File transfer complete\r\n";
   2365         }
   2366     }
   2367     else {
   2368         sendcontrol "550 $testno: No such file or directory.\r\n";
   2369     }
   2370     return 0;
   2371 }
   2372 
   2373 sub STOR_ftp {
   2374     my $testno=$_[0];
   2375 
   2376     my $filename = "$logdir/upload.$testno";
   2377 
   2378     if($datasockf_conn eq 'no') {
   2379         if($nodataconn425) {
   2380             sendcontrol "150 Opening data connection\r\n";
   2381             sendcontrol "425 Can't open data connection\r\n";
   2382         }
   2383         elsif($nodataconn421) {
   2384             sendcontrol "150 Opening data connection\r\n";
   2385             sendcontrol "421 Connection timed out\r\n";
   2386         }
   2387         elsif($nodataconn150) {
   2388             sendcontrol "150 Opening data connection\r\n";
   2389             # client shall timeout
   2390         }
   2391         else {
   2392             # client shall timeout
   2393         }
   2394         return 0;
   2395     }
   2396 
   2397     logmsg "STOR test number $testno in $filename\n";
   2398 
   2399     sendcontrol "125 Gimme gimme gimme!\r\n";
   2400 
   2401     open(my $file, ">", "$filename") ||
   2402         return 0; # failed to open output
   2403 
   2404     my $line;
   2405     my $ulsize=0;
   2406     my $disc=0;
   2407     while(5 == (sysread DREAD, $line, 5)) {
   2408         if($line eq "DATA\n") {
   2409             my $i;
   2410             sysread DREAD, $i, 5;
   2411 
   2412             my $size = 0;
   2413             if($i =~ /^([0-9a-fA-F]{4})\n/) {
   2414                 $size = hex($1);
   2415             }
   2416 
   2417             read_datasockf(\$line, $size);
   2418 
   2419             #print STDERR "  GOT: $size bytes\n";
   2420 
   2421             $ulsize += $size;
   2422             print $file $line if(!$nosave);
   2423             logmsg "> Appending $size bytes to file\n";
   2424         }
   2425         elsif($line eq "DISC\n") {
   2426             # disconnect!
   2427             $disc=1;
   2428             printf DWRITE "ACKD\n";
   2429             last;
   2430         }
   2431         else {
   2432             logmsg "No support for: $line";
   2433             last;
   2434         }
   2435         if($storeresp) {
   2436             # abort early
   2437             last;
   2438         }
   2439     }
   2440     if($nosave) {
   2441         print $file "$ulsize bytes would've been stored here\n";
   2442     }
   2443     close($file);
   2444     close_dataconn($disc);
   2445     logmsg "received $ulsize bytes upload\n";
   2446     if($storeresp) {
   2447         sendcontrol "$storeresp\r\n";
   2448     }
   2449     else {
   2450         sendcontrol "226 File transfer complete\r\n";
   2451     }
   2452     return 0;
   2453 }
   2454 
   2455 sub PASV_ftp {
   2456     my ($arg, $cmd)=@_;
   2457     my $pasvport;
   2458 
   2459     # kill previous data connection sockfilt when alive
   2460     if($datasockf_runs eq 'yes') {
   2461         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   2462         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
   2463     }
   2464     datasockf_state('STOPPED');
   2465 
   2466     logmsg "====> Passive DATA channel requested by client\n";
   2467 
   2468     logmsg "DATA sockfilt for passive data channel starting...\n";
   2469 
   2470     # We fire up a new sockfilt to do the data transfer for us.
   2471     my @datasockfcmd = (server_exe_args('sockfilt'),
   2472         "--ipv$ipvnum", "--port", 0,
   2473         "--pidfile", $datasockf_pidfile,
   2474         "--logfile", $datasockf_logfile);
   2475     if($nodataconn) {
   2476         push(@datasockfcmd, '--bindonly');
   2477     }
   2478     $slavepid = open2(\*DREAD, \*DWRITE, @datasockfcmd);
   2479 
   2480     if($nodataconn) {
   2481         datasockf_state('PASSIVE_NODATACONN');
   2482     }
   2483     else {
   2484         datasockf_state('PASSIVE');
   2485     }
   2486 
   2487     print STDERR "@datasockfcmd\n" if($verbose);
   2488 
   2489     print DWRITE "PING\n";
   2490     my $pong;
   2491     sysread_or_die(\*DREAD, \$pong, 5);
   2492 
   2493     if($pong =~ /^FAIL/) {
   2494         logmsg "DATA sockfilt said: FAIL\n";
   2495         logmsg "DATA sockfilt for passive data channel failed\n";
   2496         logmsg "DATA sockfilt not running\n";
   2497         datasockf_state('STOPPED');
   2498         sendcontrol "500 no free ports!\r\n";
   2499         return;
   2500     }
   2501     elsif($pong !~ /^PONG/) {
   2502         logmsg "DATA sockfilt unexpected response: $pong\n";
   2503         logmsg "DATA sockfilt for passive data channel failed\n";
   2504         logmsg "DATA sockfilt killed now\n";
   2505         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   2506         logmsg "DATA sockfilt not running\n";
   2507         datasockf_state('STOPPED');
   2508         sendcontrol "500 no free ports!\r\n";
   2509         return;
   2510     }
   2511 
   2512     logmsg "DATA sockfilt for passive data channel started (pid $slavepid)\n";
   2513 
   2514     # Find out on what port we listen on or have bound
   2515     my $i;
   2516     print DWRITE "PORT\n";
   2517 
   2518     # READ the response code
   2519     sysread_or_die(\*DREAD, \$i, 5);
   2520 
   2521     # READ the response size
   2522     sysread_or_die(\*DREAD, \$i, 5);
   2523 
   2524     my $size = 0;
   2525     if($i =~ /^([0-9a-fA-F]{4})\n/) {
   2526         $size = hex($1);
   2527     }
   2528 
   2529     # READ the response data
   2530     read_datasockf(\$i, $size);
   2531 
   2532     # The data is in the format
   2533     # IPvX/NNN
   2534 
   2535     if($i =~ /IPv(\d)\/(\d+)/) {
   2536         # FIX: deal with IP protocol version
   2537         $pasvport = $2;
   2538     }
   2539 
   2540     if(!$pasvport) {
   2541         logmsg "DATA sockfilt unknown listener port\n";
   2542         logmsg "DATA sockfilt for passive data channel failed\n";
   2543         logmsg "DATA sockfilt killed now\n";
   2544         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   2545         logmsg "DATA sockfilt not running\n";
   2546         datasockf_state('STOPPED');
   2547         sendcontrol "500 no free ports!\r\n";
   2548         return;
   2549     }
   2550 
   2551     if($nodataconn) {
   2552         my $str = nodataconn_str();
   2553         logmsg "DATA sockfilt for passive data channel ($str) bound on port ".
   2554                "$pasvport\n";
   2555     }
   2556     else {
   2557         logmsg "DATA sockfilt for passive data channel listens on port ".
   2558                "$pasvport\n";
   2559     }
   2560 
   2561     if($cmd ne "EPSV") {
   2562         # PASV reply
   2563         my $p=$listenaddr;
   2564         $p =~ s/\./,/g;
   2565         if($pasvbadip) {
   2566             $p="1,2,3,4";
   2567         }
   2568         sendcontrol sprintf("227 Entering Passive Mode ($p,%d,%d)\n",
   2569                             int($pasvport/256), int($pasvport%256));
   2570     }
   2571     else {
   2572         # EPSV reply
   2573         sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
   2574     }
   2575 
   2576     logmsg "Client has been notified that DATA conn ".
   2577            "will be accepted on port $pasvport\n";
   2578 
   2579     if($nodataconn) {
   2580         my $str = nodataconn_str();
   2581         logmsg "====> Client fooled ($str)\n";
   2582         return;
   2583     }
   2584 
   2585     eval {
   2586         local $SIG{ALRM} = sub { die "alarm\n" };
   2587 
   2588         # assume swift operations unless explicitly slow
   2589         alarm ($datadelay?20:2);
   2590 
   2591         # Wait for 'CNCT'
   2592         my $input;
   2593 
   2594         # FIX: Monitor ctrl conn for disconnect
   2595 
   2596         while(sysread(DREAD, $input, 5)) {
   2597 
   2598             if($input !~ /^CNCT/) {
   2599                 # we wait for a connected client
   2600                 logmsg "Odd, we got $input from client\n";
   2601                 next;
   2602             }
   2603             logmsg "Client connects to port $pasvport\n";
   2604             last;
   2605         }
   2606         alarm 0;
   2607     };
   2608     if($@) {
   2609         # timed out
   2610         logmsg "$srvrname server timed out awaiting data connection ".
   2611             "on port $pasvport\n";
   2612         logmsg "accept failed or connection not even attempted\n";
   2613         logmsg "DATA sockfilt killed now\n";
   2614         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   2615         logmsg "DATA sockfilt not running\n";
   2616         datasockf_state('STOPPED');
   2617         return;
   2618     }
   2619     else {
   2620         logmsg "====> Client established passive DATA connection ".
   2621                "on port $pasvport\n";
   2622     }
   2623 
   2624     return;
   2625 }
   2626 
   2627 #
   2628 # Support both PORT and EPRT here.
   2629 #
   2630 
   2631 sub PORT_ftp {
   2632     my ($arg, $cmd) = @_;
   2633     my $port;
   2634     my $addr;
   2635 
   2636     # kill previous data connection sockfilt when alive
   2637     if($datasockf_runs eq 'yes') {
   2638         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   2639         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
   2640     }
   2641     datasockf_state('STOPPED');
   2642 
   2643     logmsg "====> Active DATA channel requested by client\n";
   2644 
   2645     # We always ignore the given IP and use localhost.
   2646 
   2647     if($cmd eq "PORT") {
   2648         if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
   2649             logmsg "DATA sockfilt for active data channel not started ".
   2650                    "(bad PORT-line: $arg)\n";
   2651             sendcontrol "500 silly you, go away\r\n";
   2652             return;
   2653         }
   2654         $port = ($5<<8)+$6;
   2655         $addr = "$1.$2.$3.$4";
   2656     }
   2657     # EPRT |2|::1|49706|
   2658     elsif($cmd eq "EPRT") {
   2659         if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
   2660             logmsg "DATA sockfilt for active data channel not started ".
   2661                    "(bad EPRT-line: $arg)\n";
   2662             sendcontrol "500 silly you, go away\r\n";
   2663             return;
   2664         }
   2665         sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
   2666         $port = $3;
   2667         $addr = $2;
   2668     }
   2669     else {
   2670         logmsg "DATA sockfilt for active data channel not started ".
   2671                "(invalid command: $cmd)\n";
   2672         sendcontrol "500 we don't like $cmd now\r\n";
   2673         return;
   2674     }
   2675 
   2676     if(!$port || $port > 65535) {
   2677         logmsg "DATA sockfilt for active data channel not started ".
   2678                "(illegal PORT number: $port)\n";
   2679         return;
   2680     }
   2681 
   2682     if($nodataconn) {
   2683         my $str = nodataconn_str();
   2684         logmsg "DATA sockfilt for active data channel not started ($str)\n";
   2685         datasockf_state('ACTIVE_NODATACONN');
   2686         logmsg "====> Active DATA channel not established\n";
   2687         return;
   2688     }
   2689 
   2690     logmsg "DATA sockfilt for active data channel starting...\n";
   2691 
   2692     # We fire up a new sockfilt to do the data transfer for us.
   2693     my @datasockfcmd = (server_exe_args('sockfilt'),
   2694         "--ipv$ipvnum", "--connect", $port, "--addr", $addr,
   2695         "--pidfile", $datasockf_pidfile,
   2696         "--logfile", $datasockf_logfile);
   2697     $slavepid = open2(\*DREAD, \*DWRITE, @datasockfcmd);
   2698 
   2699     datasockf_state('ACTIVE');
   2700 
   2701     print STDERR "@datasockfcmd\n" if($verbose);
   2702 
   2703     print DWRITE "PING\n";
   2704     my $pong;
   2705     sysread_or_die(\*DREAD, \$pong, 5);
   2706 
   2707     if($pong =~ /^FAIL/) {
   2708         logmsg "DATA sockfilt said: FAIL\n";
   2709         logmsg "DATA sockfilt for active data channel failed\n";
   2710         logmsg "DATA sockfilt not running\n";
   2711         datasockf_state('STOPPED');
   2712         # client shall timeout awaiting connection from server
   2713         return;
   2714     }
   2715     elsif($pong !~ /^PONG/) {
   2716         logmsg "DATA sockfilt unexpected response: $pong\n";
   2717         logmsg "DATA sockfilt for active data channel failed\n";
   2718         logmsg "DATA sockfilt killed now\n";
   2719         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   2720         logmsg "DATA sockfilt not running\n";
   2721         datasockf_state('STOPPED');
   2722         # client shall timeout awaiting connection from server
   2723         return;
   2724     }
   2725 
   2726     logmsg "DATA sockfilt for active data channel started (pid $slavepid)\n";
   2727 
   2728     logmsg "====> Active DATA channel connected to client port $port\n";
   2729 
   2730     return;
   2731 }
   2732 
   2733 #**********************************************************************
   2734 # datasockf_state is used to change variables that keep state info
   2735 # relative to the FTP secondary or data sockfilt process as soon as
   2736 # one of the five possible stable states is reached. Variables that
   2737 # are modified by this sub may be checked independently but should
   2738 # not be changed except by calling this sub.
   2739 #
   2740 sub datasockf_state {
   2741     my $state = $_[0];
   2742 
   2743     if($state eq 'STOPPED') {
   2744         # Data sockfilter initial state, not running,
   2745         # not connected and not used.
   2746         $datasockf_state = $state;
   2747         $datasockf_mode = 'none';
   2748         $datasockf_runs = 'no';
   2749         $datasockf_conn = 'no';
   2750     }
   2751     elsif($state eq 'PASSIVE') {
   2752         # Data sockfilter accepted connection from client.
   2753         $datasockf_state = $state;
   2754         $datasockf_mode = 'passive';
   2755         $datasockf_runs = 'yes';
   2756         $datasockf_conn = 'yes';
   2757     }
   2758     elsif($state eq 'ACTIVE') {
   2759         # Data sockfilter has connected to client.
   2760         $datasockf_state = $state;
   2761         $datasockf_mode = 'active';
   2762         $datasockf_runs = 'yes';
   2763         $datasockf_conn = 'yes';
   2764     }
   2765     elsif($state eq 'PASSIVE_NODATACONN') {
   2766         # Data sockfilter bound port without listening,
   2767         # client won't be able to establish data connection.
   2768         $datasockf_state = $state;
   2769         $datasockf_mode = 'passive';
   2770         $datasockf_runs = 'yes';
   2771         $datasockf_conn = 'no';
   2772     }
   2773     elsif($state eq 'ACTIVE_NODATACONN') {
   2774         # Data sockfilter does not even run,
   2775         # client awaits data connection from server in vain.
   2776         $datasockf_state = $state;
   2777         $datasockf_mode = 'active';
   2778         $datasockf_runs = 'no';
   2779         $datasockf_conn = 'no';
   2780     }
   2781     else {
   2782         die "Internal error. Unknown datasockf state: $state!";
   2783     }
   2784 }
   2785 
   2786 #**********************************************************************
   2787 # nodataconn_str returns string of effective nodataconn command. Notice
   2788 # that $nodataconn may be set alone or in addition to a $nodataconnXXX.
   2789 #
   2790 sub nodataconn_str {
   2791     my $str;
   2792     # order matters
   2793     $str = 'NODATACONN' if($nodataconn);
   2794     $str = 'NODATACONN425' if($nodataconn425);
   2795     $str = 'NODATACONN421' if($nodataconn421);
   2796     $str = 'NODATACONN150' if($nodataconn150);
   2797     return "$str";
   2798 }
   2799 
   2800 #**********************************************************************
   2801 # customize configures test server operation for each curl test, reading
   2802 # configuration commands/parameters from server commands file each time
   2803 # a new client control connection is established with the test server.
   2804 # On success returns 1, otherwise zero.
   2805 #
   2806 sub customize {
   2807     my($cmdfile) = @_;
   2808     $ctrldelay = 0;     # default is no throttling of the ctrl stream
   2809     $datadelay = 0;     # default is no throttling of the data stream
   2810     $retrweirdo = 0;    # default is no use of RETRWEIRDO
   2811     $retrnosize = 0;    # default is no use of RETRNOSIZE
   2812     $retrsize = 0;      # default is no use of RETRSIZE
   2813     $pasvbadip = 0;     # default is no use of PASVBADIP
   2814     $nosave = 0;        # default is to actually save uploaded data to file
   2815     $nodataconn = 0;    # default is to establish or accept data channel
   2816     $nodataconn425 = 0; # default is to not send 425 without data channel
   2817     $nodataconn421 = 0; # default is to not send 421 without data channel
   2818     $nodataconn150 = 0; # default is to not send 150 without data channel
   2819     $storeresp = "";    # send as ultimate STOR response
   2820     $postfetch = "";    # send as header after a FETCH response
   2821     @capabilities = (); # default is to not support capability commands
   2822     @auth_mechs = ();   # default is to not support authentication commands
   2823     %fulltextreply = ();#
   2824     %commandreply = (); #
   2825     %customcount = ();  #
   2826     %delayreply = ();   #
   2827 
   2828     open(my $custom, "<", "$logdir/$SERVERCMD") ||
   2829         return 1;
   2830 
   2831     logmsg "FTPD: Getting commands from $logdir/$SERVERCMD\n";
   2832 
   2833     while(<$custom>) {
   2834         if($_ =~ /REPLY \"([A-Z]+ [A-Za-z0-9+-\/=\*. ]+)\" (.*)/) {
   2835             $fulltextreply{$1}=eval "qq{$2}";
   2836             logmsg "FTPD: set custom reply for $1\n";
   2837         }
   2838         elsif($_ =~ /REPLY(LF|) ([A-Za-z0-9+\/=\*]*) (.*)/) {
   2839             $commandreply{$2}=eval "qq{$3}";
   2840             if($1 ne "LF") {
   2841                 $commandreply{$2}.="\r\n";
   2842             }
   2843             else {
   2844                 $commandreply{$2}.="\n";
   2845             }
   2846             if($2 eq "") {
   2847                 logmsg "FTPD: set custom reply for empty command\n";
   2848             }
   2849             else {
   2850                 logmsg "FTPD: set custom reply for $2 command\n";
   2851             }
   2852         }
   2853         elsif($_ =~ /COUNT ([A-Z]+) (.*)/) {
   2854             # we blank the custom reply for this command when having
   2855             # been used this number of times
   2856             $customcount{$1}=$2;
   2857             logmsg "FTPD: blank custom reply for $1 command after $2 uses\n";
   2858         }
   2859         elsif($_ =~ /DELAY ([A-Z]+) (\d*)/) {
   2860             $delayreply{$1}=$2;
   2861             logmsg "FTPD: delay reply for $1 with $2 seconds\n";
   2862         }
   2863         elsif($_ =~ /POSTFETCH (.*)/) {
   2864             logmsg "FTPD: read POSTFETCH header data\n";
   2865             $postfetch = $1;
   2866         }
   2867         elsif($_ =~ /SLOWDOWNDATA/) {
   2868             $ctrldelay=0;
   2869             $datadelay=0.005;
   2870             logmsg "FTPD: send response data with 5ms delay per byte\n";
   2871         }
   2872         elsif($_ =~ /SLOWDOWN/) {
   2873             $ctrldelay=0.005;
   2874             $datadelay=0.005;
   2875             logmsg "FTPD: send response with 5ms delay between each byte\n";
   2876         }
   2877         elsif($_ =~ /RETRWEIRDO/) {
   2878             logmsg "FTPD: instructed to use RETRWEIRDO\n";
   2879             $retrweirdo=1;
   2880         }
   2881         elsif($_ =~ /RETRNOSIZE/) {
   2882             logmsg "FTPD: instructed to use RETRNOSIZE\n";
   2883             $retrnosize=1;
   2884         }
   2885         elsif($_ =~ /RETRSIZE (\d+)/) {
   2886             $retrsize= $1;
   2887             logmsg "FTPD: instructed to use RETRSIZE = $1\n";
   2888         }
   2889         elsif($_ =~ /PASVBADIP/) {
   2890             logmsg "FTPD: instructed to use PASVBADIP\n";
   2891             $pasvbadip=1;
   2892         }
   2893         elsif($_ =~ /NODATACONN425/) {
   2894             # applies to both active and passive FTP modes
   2895             logmsg "FTPD: instructed to use NODATACONN425\n";
   2896             $nodataconn425=1;
   2897             $nodataconn=1;
   2898         }
   2899         elsif($_ =~ /NODATACONN421/) {
   2900             # applies to both active and passive FTP modes
   2901             logmsg "FTPD: instructed to use NODATACONN421\n";
   2902             $nodataconn421=1;
   2903             $nodataconn=1;
   2904         }
   2905         elsif($_ =~ /NODATACONN150/) {
   2906             # applies to both active and passive FTP modes
   2907             logmsg "FTPD: instructed to use NODATACONN150\n";
   2908             $nodataconn150=1;
   2909             $nodataconn=1;
   2910         }
   2911         elsif($_ =~ /NODATACONN/) {
   2912             # applies to both active and passive FTP modes
   2913             logmsg "FTPD: instructed to use NODATACONN\n";
   2914             $nodataconn=1;
   2915         }
   2916         elsif($_ =~ /^STOR (.*)/) {
   2917             $storeresp=$1;
   2918             logmsg "FTPD: instructed to use respond to STOR with '$storeresp'\n";
   2919         }
   2920         elsif($_ =~ /CAPA (.*)/) {
   2921             logmsg "FTPD: instructed to support CAPABILITY command\n";
   2922             @capabilities = split(/ (?!(?:[^" ]|[^"] [^"])+")/, $1);
   2923             foreach (@capabilities) {
   2924                 $_ = $1 if /^"(.*)"$/;
   2925             }
   2926         }
   2927         elsif($_ =~ /AUTH (.*)/) {
   2928             logmsg "FTPD: instructed to support AUTHENTICATION command\n";
   2929             @auth_mechs = split(/ /, $1);
   2930         }
   2931         elsif($_ =~ /NOSAVE/) {
   2932             # don't actually store the file we upload - to be used when
   2933             # uploading insanely huge amounts
   2934             $nosave = 1;
   2935             logmsg "FTPD: NOSAVE prevents saving of uploaded data\n";
   2936         }
   2937         elsif($_ =~ /^Testnum (\d+)/){
   2938             $testno = $1;
   2939             logmsg "FTPD: run test case number: $testno\n";
   2940         }
   2941     }
   2942     close($custom);
   2943 }
   2944 
   2945 #----------------------------------------------------------------------
   2946 #----------------------------------------------------------------------
   2947 #---------------------------  END OF SUBS  ----------------------------
   2948 #----------------------------------------------------------------------
   2949 #----------------------------------------------------------------------
   2950 
   2951 #**********************************************************************
   2952 # Parse command line options
   2953 #
   2954 # Options:
   2955 #
   2956 # --verbose   # verbose
   2957 # --srcdir    # source directory
   2958 # --id        # server instance number
   2959 # --proto     # server protocol
   2960 # --pidfile   # server pid file
   2961 # --portfile  # server port file
   2962 # --logfile   # server log file
   2963 # --logdir    # server log directory
   2964 # --ipv4      # server IP version 4
   2965 # --ipv6      # server IP version 6
   2966 # --port      # server listener port
   2967 # --addr      # server address for listener port binding
   2968 #
   2969 while(@ARGV) {
   2970     if($ARGV[0] eq '--verbose') {
   2971         $verbose = 1;
   2972     }
   2973     elsif($ARGV[0] eq '--srcdir') {
   2974         if($ARGV[1]) {
   2975             $srcdir = $ARGV[1];
   2976             shift @ARGV;
   2977         }
   2978     }
   2979     elsif($ARGV[0] eq '--id') {
   2980         if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
   2981             $idnum = $1 if($1 > 0);
   2982             shift @ARGV;
   2983         }
   2984     }
   2985     elsif($ARGV[0] eq '--proto') {
   2986         if($ARGV[1] && ($ARGV[1] =~ /^(ftp|imap|pop3|smtp)$/)) {
   2987             $proto = $1;
   2988             shift @ARGV;
   2989         }
   2990         else {
   2991             die "unsupported protocol $ARGV[1]";
   2992         }
   2993     }
   2994     elsif($ARGV[0] eq '--pidfile') {
   2995         if($ARGV[1]) {
   2996             $pidfile = $ARGV[1];
   2997             shift @ARGV;
   2998         }
   2999     }
   3000     elsif($ARGV[0] eq '--portfile') {
   3001         if($ARGV[1]) {
   3002             $portfile = $ARGV[1];
   3003             shift @ARGV;
   3004         }
   3005     }
   3006     elsif($ARGV[0] eq '--logfile') {
   3007         if($ARGV[1]) {
   3008             $logfile = $ARGV[1];
   3009             shift @ARGV;
   3010         }
   3011     }
   3012     elsif($ARGV[0] eq '--logdir') {
   3013         if($ARGV[1]) {
   3014             $logdir = $ARGV[1];
   3015             shift @ARGV;
   3016         }
   3017     }
   3018     elsif($ARGV[0] eq '--ipv4') {
   3019         $ipvnum = 4;
   3020         $listenaddr = '127.0.0.1' if($listenaddr eq '::1');
   3021     }
   3022     elsif($ARGV[0] eq '--ipv6') {
   3023         $ipvnum = 6;
   3024         $listenaddr = '::1' if($listenaddr eq '127.0.0.1');
   3025     }
   3026     elsif($ARGV[0] eq '--port') {
   3027         if($ARGV[1] =~ /^(\d+)$/) {
   3028             $port = $1;
   3029             shift @ARGV;
   3030         }
   3031     }
   3032     elsif($ARGV[0] eq '--addr') {
   3033         if($ARGV[1]) {
   3034             my $tmpstr = $ARGV[1];
   3035             if($tmpstr =~ /^(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)$/) {
   3036                 $listenaddr = "$1.$2.$3.$4" if($ipvnum == 4);
   3037             }
   3038             elsif($ipvnum == 6) {
   3039                 $listenaddr = $tmpstr;
   3040                 $listenaddr =~ s/^\[(.*)\]$/$1/;
   3041             }
   3042             shift @ARGV;
   3043         }
   3044     }
   3045     else {
   3046         print STDERR "\nWarning: ftpserver.pl unknown parameter: $ARGV[0]\n";
   3047     }
   3048     shift @ARGV;
   3049 }
   3050 
   3051 #***************************************************************************
   3052 # Initialize command line option dependent variables
   3053 #
   3054 
   3055 if($pidfile) {
   3056     # Use our pidfile directory to store the other pidfiles
   3057     $piddir = dirname($pidfile);
   3058 }
   3059 else {
   3060     # Use the current directory to store all the pidfiles
   3061     $piddir = $path;
   3062     $pidfile = server_pidfilename($piddir, $proto, $ipvnum, $idnum);
   3063 }
   3064 if(!$portfile) {
   3065     $portfile = $piddir . "/" . $PORTFILE;
   3066 }
   3067 if(!$srcdir) {
   3068     $srcdir = $ENV{'srcdir'} || '.';
   3069 }
   3070 if(!$logfile) {
   3071     $logfile = server_logfilename($logdir, $proto, $ipvnum, $idnum);
   3072 }
   3073 
   3074 $mainsockf_pidfile = mainsockf_pidfilename($piddir, $proto, $ipvnum, $idnum);
   3075 $mainsockf_logfile =
   3076     mainsockf_logfilename($logdir, $proto, $ipvnum, $idnum);
   3077 
   3078 if($proto eq 'ftp') {
   3079     $datasockf_pidfile = datasockf_pidfilename($piddir, $proto, $ipvnum, $idnum);
   3080     $datasockf_logfile =
   3081         datasockf_logfilename($logdir, $proto, $ipvnum, $idnum);
   3082 }
   3083 
   3084 $srvrname = servername_str($proto, $ipvnum, $idnum);
   3085 $serverlogs_lockfile = "$logdir/$LOCKDIR/${srvrname}.lock";
   3086 
   3087 $idstr = "$idnum" if($idnum > 1);
   3088 
   3089 protocolsetup($proto);
   3090 
   3091 $SIG{INT} = \&exit_signal_handler;
   3092 $SIG{TERM} = \&exit_signal_handler;
   3093 
   3094 startsf();
   3095 
   3096 # actual port
   3097 if($portfile && !$port) {
   3098     my $aport;
   3099     open(my $p, "<", "$portfile");
   3100     $aport = <$p>;
   3101     close($p);
   3102     $port = 0 + $aport;
   3103 }
   3104 
   3105 logmsg sprintf("%s server listens on port IPv${ipvnum}/${port}\n", uc($proto));
   3106 
   3107 open(my $pid, ">", "$pidfile");
   3108 print $pid $$."\n";
   3109 close($pid);
   3110 
   3111 logmsg("logged pid $$ in $pidfile\n");
   3112 
   3113 while(1) {
   3114 
   3115     # kill previous data connection sockfilt when alive
   3116     if($datasockf_runs eq 'yes') {
   3117         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
   3118         logmsg "DATA sockfilt for $datasockf_mode data channel killed now\n";
   3119     }
   3120     datasockf_state('STOPPED');
   3121 
   3122     #
   3123     # We read 'sockfilt' commands.
   3124     #
   3125     my $input;
   3126 
   3127     logmsg "Awaiting input\n";
   3128     sysread_or_die(\*SFREAD, \$input, 5);
   3129 
   3130     if($input !~ /^CNCT/) {
   3131         # we wait for a connected client
   3132         logmsg "MAIN sockfilt said: $input";
   3133         next;
   3134     }
   3135     logmsg "====> Client connect\n";
   3136 
   3137     set_advisor_read_lock($serverlogs_lockfile);
   3138     $serverlogslocked = 1;
   3139 
   3140     # flush data:
   3141     $| = 1;
   3142 
   3143     &customize(); # read test control instructions
   3144     loadtest("$logdir/test$testno");
   3145 
   3146     my $welcome = $commandreply{"welcome"};
   3147     if(!$welcome) {
   3148         $welcome = $displaytext{"welcome"};
   3149     }
   3150     else {
   3151         # clear it after use
   3152         $commandreply{"welcome"}="";
   3153         if($welcome !~ /\r\n\z/) {
   3154             $welcome .= "\r\n";
   3155         }
   3156     }
   3157     sendcontrol $welcome;
   3158 
   3159     #remove global variables from last connection
   3160     if($ftplistparserstate) {
   3161       undef $ftplistparserstate;
   3162     }
   3163     if($ftptargetdir) {
   3164       $ftptargetdir = "";
   3165     }
   3166 
   3167     if($verbose) {
   3168         print STDERR "OUT: $welcome";
   3169     }
   3170 
   3171     my $full = "";
   3172 
   3173     while(1) {
   3174         my $i;
   3175 
   3176         # Now we expect to read DATA\n[hex size]\n[prot], where the [prot]
   3177         # part only is FTP lingo.
   3178 
   3179         # COMMAND
   3180         sysread_or_die(\*SFREAD, \$i, 5);
   3181 
   3182         if($i !~ /^DATA/) {
   3183             logmsg "MAIN sockfilt said $i";
   3184             if($i =~ /^DISC/) {
   3185                 # disconnect
   3186                 printf SFWRITE "ACKD\n";
   3187                 last;
   3188             }
   3189             next;
   3190         }
   3191 
   3192         # SIZE of data
   3193         sysread_or_die(\*SFREAD, \$i, 5);
   3194 
   3195         my $size = 0;
   3196         if($i =~ /^([0-9a-fA-F]{4})\n/) {
   3197             $size = hex($1);
   3198         }
   3199 
   3200         # data
   3201         read_mainsockf(\$input, $size);
   3202 
   3203         ftpmsg $input;
   3204 
   3205         $full .= $input;
   3206 
   3207         # Loop until command completion
   3208         next unless($full =~ /\r\n$/);
   3209 
   3210         # Remove trailing CRLF.
   3211         $full =~ s/[\n\r]+$//;
   3212 
   3213         my $FTPCMD;
   3214         my $FTPARG;
   3215         if($proto eq "imap") {
   3216             # IMAP is different with its identifier first on the command line
   3217             if(($full =~ /^([^ ]+) ([^ ]+) (.*)/) ||
   3218                ($full =~ /^([^ ]+) ([^ ]+)/)) {
   3219                 $cmdid=$1; # set the global variable
   3220                 $FTPCMD=$2;
   3221                 $FTPARG=$3;
   3222             }
   3223             # IMAP authentication cancellation
   3224             elsif($full =~ /^\*$/) {
   3225                 # Command id has already been set
   3226                 $FTPCMD="*";
   3227                 $FTPARG="";
   3228             }
   3229             # IMAP long "commands" are base64 authentication data
   3230             elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
   3231                 # Command id has already been set
   3232                 $FTPCMD=$full;
   3233                 $FTPARG="";
   3234             }
   3235             else {
   3236                 sendcontrol "$full BAD Command\r\n";
   3237                 last;
   3238             }
   3239         }
   3240         elsif($full =~ /^([A-Z]{3,4})(\s(.*))?$/i) {
   3241             $FTPCMD=$1;
   3242             $FTPARG=$3;
   3243         }
   3244         elsif($proto eq "pop3") {
   3245             # POP3 authentication cancellation
   3246             if($full =~ /^\*$/) {
   3247                 $FTPCMD="*";
   3248                 $FTPARG="";
   3249             }
   3250             # POP3 long "commands" are base64 authentication data
   3251             elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
   3252                 $FTPCMD=$full;
   3253                 $FTPARG="";
   3254             }
   3255             else {
   3256                 sendcontrol "-ERR Unrecognized command\r\n";
   3257                 last;
   3258             }
   3259         }
   3260         elsif($proto eq "smtp") {
   3261             # SMTP authentication cancellation
   3262             if($full =~ /^\*$/) {
   3263                 $FTPCMD="*";
   3264                 $FTPARG="";
   3265             }
   3266             # SMTP long "commands" are base64 authentication data
   3267             elsif($full =~ /^[A-Z0-9+\/]{0,512}={0,2}$/i) {
   3268                 $FTPCMD=$full;
   3269                 $FTPARG="";
   3270             }
   3271             else {
   3272                 sendcontrol "500 Unrecognized command\r\n";
   3273                 last;
   3274             }
   3275         }
   3276         else {
   3277             sendcontrol "500 Unrecognized command\r\n";
   3278             last;
   3279         }
   3280 
   3281         logmsg "< \"$full\"\n";
   3282 
   3283         if($verbose) {
   3284             print STDERR "IN: $full\n";
   3285         }
   3286 
   3287         $full = "";
   3288 
   3289         my $delay = $delayreply{$FTPCMD};
   3290         if($delay) {
   3291             # just go sleep this many seconds!
   3292             logmsg("Sleep for $delay seconds\n");
   3293             my $twentieths = $delay * 20;
   3294             while($twentieths--) {
   3295                 portable_sleep(0.05) unless($got_exit_signal);
   3296             }
   3297         }
   3298 
   3299         my $check = 1; # no response yet
   3300 
   3301         # See if there is a custom reply for the full text
   3302         my $fulltext = $FTPARG ? $FTPCMD . " " . $FTPARG : $FTPCMD;
   3303         my $text = $fulltextreply{$fulltext};
   3304         if($text && ($text ne "")) {
   3305             sendcontrol "$text\r\n";
   3306             $check = 0;
   3307         }
   3308         else {
   3309             # See if there is a custom reply for the command
   3310             $text = $commandreply{$FTPCMD};
   3311             if($text && ($text ne "")) {
   3312                 if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
   3313                     # used enough times so blank the custom command reply
   3314                     $commandreply{$FTPCMD}="";
   3315                 }
   3316 
   3317                 sendcontrol $text;
   3318                 $check = 0;
   3319             }
   3320             else {
   3321                 # See if there is any display text for the command
   3322                 $text = $displaytext{$FTPCMD};
   3323                 if($text && ($text ne "")) {
   3324                     if($proto eq 'imap') {
   3325                         sendcontrol "$cmdid $text\r\n";
   3326                     }
   3327                     else {
   3328                         sendcontrol "$text\r\n";
   3329                     }
   3330 
   3331                     $check = 0;
   3332                 }
   3333 
   3334                 # only perform this if we're not faking a reply
   3335                 my $func = $commandfunc{uc($FTPCMD)};
   3336                 if($func) {
   3337                     &$func($FTPARG, $FTPCMD);
   3338                     $check = 0;
   3339                 }
   3340             }
   3341         }
   3342 
   3343         if($check) {
   3344             logmsg "$FTPCMD wasn't handled!\n";
   3345             if($proto eq 'pop3') {
   3346                 sendcontrol "-ERR $FTPCMD is not dealt with!\r\n";
   3347             }
   3348             elsif($proto eq 'imap') {
   3349                 sendcontrol "$cmdid BAD $FTPCMD is not dealt with!\r\n";
   3350             }
   3351             else {
   3352                 sendcontrol "500 $FTPCMD is not dealt with!\r\n";
   3353             }
   3354         }
   3355 
   3356     } # while(1)
   3357     logmsg "====> Client disconnected\n";
   3358 
   3359     if($serverlogslocked) {
   3360         $serverlogslocked = 0;
   3361         clear_advisor_read_lock($serverlogs_lockfile);
   3362     }
   3363 }
   3364 
   3365 killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
   3366 unlink($pidfile);
   3367 if($serverlogslocked) {
   3368     $serverlogslocked = 0;
   3369     clear_advisor_read_lock($serverlogs_lockfile);
   3370 }
   3371 
   3372 exit;
	quickjs-tart quickjs-based runtime for wallet-core logic
	Log \| Files \| Refs \| README \| LICENSE