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