luna - curl/tests/ftpserver.pl

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