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