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