tests/httpserver.pl

   1 #!/usr/bin/perl
   2 use Socket;
   3 use Carp;
   4 use FileHandle;
   5
   6 sub spawn;  # forward declaration
   7 sub logmsg { #print "$0 $$: @_ at ", scalar localtime, "\n"
   8  }
   9
  10 my $port = $ARGV[0];
  11 my $proto = getprotobyname('tcp');
  12 $port = $1 if $port =~ /(\d+)/; # untaint port number
  13
  14 if($ARGV[1] =~ /^ftp$/i) {
  15     $protocol="FTP";
  16 }
  17 else {
  18     $protocol="HTTP";
  19 }
  20
  21 socket(Server, PF_INET, SOCK_STREAM, $proto)|| die "socket: $!";
  22 setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
  23            pack("l", 1)) || die "setsockopt: $!";
  24 bind(Server, sockaddr_in($port, INADDR_ANY))|| die "bind: $!";
  25 listen(Server,SOMAXCONN) || die "listen: $!";
  26
  27 print "$protocol server started on port $port\n";
  28
  29 open(PID, ">.server.pid");
  30 print PID $$;
  31 close(PID);
  32
  33 my $waitedpid = 0;
  34 my $paddr;
  35
  36 sub REAPER {
  37     $waitedpid = wait;
  38     $SIG{CHLD} = \&REAPER;  # loathe sysV
  39     logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
  40 }
  41
  42 # USER is ok in fresh state
  43 %commandok = ( "USER" => "fresh",
  44                "PASS" => "passwd",
  45                "PASV" => "loggedin",
  46                );
  47
  48 %statechange = ( 'USER' => 'passwd',   # USER goes to passwd state
  49                  'PASS' => 'loggedin', # PASS goes to loggedin state
  50                  );
  51
  52 %displaytext = ('USER' => '331 We are happy you popped in!', # output FTP line
  53                 'PASS' => '230 Welcome you silly person',
  54                 );
  55
  56 $SIG{CHLD} = \&REAPER;
  57
  58 for ( $waitedpid = 0;
  59       ($paddr = accept(Client,Server)) || $waitedpid;
  60         $waitedpid = 0, close Client)
  61 {
  62     next if $waitedpid and not $paddr;
  63     my($port,$iaddr) = sockaddr_in($paddr);
  64     my $name = gethostbyaddr($iaddr,AF_INET);
  65
  66     logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port";
  67
  68     # this code is forked and run
  69     spawn sub {
  70         my ($request, $path, $ver, $left, $cl);
  71
  72         if($protocol eq "FTP") {
  73
  74             # < 220 pm1 FTP server (SunOS 5.7) ready.
  75             # > USER anonymous
  76             # < 331 Guest login ok, send ident as password.
  77             # > PASS curl_by_daniel@haxx.se
  78             # < 230 Guest login ok, access restrictions apply.
  79             # * We have successfully logged in
  80             # * Connected to pm1 (193.15.23.1)
  81             # > PASV
  82             # < 227 Entering Passive Mode (193,15,23,1,231,59)
  83             # * Connecting to pm1 (193.15.23.1) port 59195
  84             # > TYPE A
  85             # < 200 Type set to A.
  86             # > LIST
  87             # < 150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes).
  88             # * Getting file with size: -1
  89
  90             # flush data:
  91             $| = 1;
  92
  93             print "220-running the curl suite test server\r\n",
  94             "220-running the curl suite test server\r\n",
  95             "220 running the curl suite test server\r\n";
  96
  97             $state="fresh";
  98
  99             while(1) {
 100
 101                 last unless defined ($_ = <STDIN>);
 102
 103                 # Remove trailing CRLF.
 104                 s/[\n\r]+$//;
 105
 106                 unless (m/^([A-Z]{3,4})\s?(.*)/i)
 107                 {
 108                     print STDERR
 109                         "badly formed command received: ".$_;
 110                     exit 0;
 111                 }
 112                 $FTPCMD=$1;
 113                 $full=$_;
 114
 115                 print STDERR "GOT: ($1) $_\n";
 116
 117                 $ok = $commandok{$FTPCMD};
 118                 if($ok !~ /$state/) {
 119                     print "314 $FTPCMD not OK ($ok) in state: $state!\r\n";
 120                     exit;
 121                 }
 122
 123                 $state=$statechange{$FTPCMD};
 124                 if($state eq "") {
 125                     print "314 Wwwwweeeeird internal error state: $state\r\n";
 126                     exit;
 127                 }
 128                 print STDERR "gone to state $state\n";
 129
 130                 $text = $displaytext{$FTPCMD};
 131                 print "$text\r\n";
 132             }
 133             exit;
 134         }
 135         # otherwise, we're doing HTTP
 136
 137         while(<STDIN>) {
 138             if($_ =~ /([A-Z]*) (.*) HTTP\/1.(\d)/) {
 139                 $request=$1;
 140                 $path=$2;
 141                 $ver=$3;
 142             }
 143             elsif($_ =~ /^Content-Length: (\d*)/) {
 144                 $cl=$1;
 145             }
 146
 147             push @headers, $_;
 148
 149             if($left > 0) {
 150                 $left -= length($_);
 151                 if($left == 0) {
 152                     $left = -1; # just to force a loop break here
 153                 }
 154             }
 155             # print STDERR "RCV ($left): $_";
 156
 157             if(!$left &&
 158                ($_ eq "\r\n") or ($_ eq "")) {
 159                 if($request =~ /^(POST|PUT)$/) {
 160                     $left=$cl;
 161                 }
 162                 else {
 163                     $left = -1; # force abort
 164                 }
 165             }
 166             if($left < 0) {
 167                 last;
 168             }
 169         }
 170
 171         if($path =~ /verifiedserver/) {
 172             # this is a hard-coded query-string for the test script
 173             # to verify that this is the server actually running!
 174             print "HTTP/1.1 999 WE ROOLZ\r\n";
 175             exit;
 176         }
 177         else {
 178
 179             #
 180             # we always start the path with a number, this is the
 181             # test number that this server will use to know what
 182             # contents to pass back to the client
 183             #
 184             if($path =~ /.*\/(\d*)/) {
 185                 $testnum=$1;
 186             }
 187             else {
 188                 print STDERR "UKNOWN TEST CASE\n";
 189                 exit;
 190             }
 191             open(INPUT, ">log/server.input");
 192             for(@headers) {
 193                 print INPUT $_;
 194             }
 195             close(INPUT);
 196
 197             # send a reply to the client
 198             open(DATA, "<data/reply$testnum.txt");
 199             while(<DATA>) {
 200                 print $_;
 201             }
 202             close(DATA);
 203         }
 204      #   print "Hello there, $name, it's now ", scalar localtime, "\r\n";
 205     };
 206 }
 207
 208
 209 sub spawn {
 210     my $coderef = shift;
 211
 212
 213     unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
 214         confess "usage: spawn CODEREF";
 215     }
 216
 217
 218     my $pid;
 219     if (!defined($pid = fork)) {
 220         logmsg "cannot fork: $!";
 221         return;
 222     } elsif ($pid) {
 223         logmsg "begat $pid";
 224         return; # I'm the parent
 225     }
 226     # else I'm the child -- go spawn
 227
 228
 229     open(STDIN,  "<&Client")   || die "can't dup client to stdin";
 230     open(STDOUT, ">&Client")   || die "can't dup client to stdout";
 231     ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
 232     exit &$coderef();
 233 }