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