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