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