bin/fbm

   1 #!/usr/bin/perl -w
   2
   3 # F*EX benchmark
   4 #
   5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   6 #
   7 # Copyright: Perl Artistic
   8
   9 use 5.006;
  10 use strict qw'vars subs';
  11 use Config;
  12 use Socket;
  13 use IO::Handle;
  14 use IO::Socket::INET;
  15 use Getopt::Std;
  16 use Time::HiRes qw'time';
  17 # use Smart::Comments;
  18 use constant k => 2**10;
  19 use constant M => 2**20;
  20
  21 our ($SH,$windoof,$sigpipe,$useragent);
  22 our ($FEXSERVER);
  23 our $version = 20150729;
  24
  25 # server defaults
  26 my $server = 'fex.rus.uni-stuttgart.de';
  27 my $port = 80;
  28 my $proxy = '';
  29
  30 my $from = 'nettest';
  31 my $to = $from;
  32 my $id = $from;
  33 my $proxy_prefix = '';
  34 my $mb;
  35 my (@r,$r);
  36 my $bs = 2**16;
  37 my $timeout = 30;       # server timeout
  38
  39 $version ||= mtime($0);
  40 $0 =~ s:.*/::;
  41
  42 my $usage = <<EOD;
  43 usage: $0 [-n] [-s server] [-P proxy] #MB
  44 options: -n  do not store on server
  45          -s  use alternative F*EX server:port
  46          -P  use proxy server:port
  47 examples: $0 1000
  48 EOD
  49
  50 if ($Config{osname} =~ /^mswin/i) {
  51   $windoof = $Config{osname};
  52   $useragent = sprintf("fbm-$version (%s %s)",
  53                        $Config{osname},$Config{archname});
  54 } else {
  55   $0 =~ s:.*/::;
  56   $_ = `(lsb_release -d||uname -a)2>/dev/null`||'';
  57   chomp;
  58   s/^Description:\s+//;
  59   $useragent = "fbm-$version ($_)";
  60 }
  61
  62 $| = 1;
  63
  64 autoflush STDERR;
  65
  66 my @_ARGV = @ARGV; # save arguments
  67
  68 our $opt_n = 0;
  69 our $opt_v = 0;
  70 our $opt_h = 0;
  71 our $opt_s = '';
  72 our $opt_P = '';
  73
  74 getopts('hvnP:s:') or die $usage;
  75
  76 if ($opt_h) {
  77   print $usage;
  78   exit;
  79 }
  80
  81 if ($opt_P) {
  82   if ($opt_P =~ /^[\w.-]+:\d+/) {
  83     $proxy = $opt_P;
  84   } else {
  85     die "$0: proxy must be: SERVER:PORT\n";
  86   }
  87 }
  88
  89 $mb = shift    or die $usage;
  90 $mb =~ /^\d+$/ or die $usage;
  91
  92 # $port = $1  if $server =~ s/:(\d+)//;
  93
  94 if ($opt_s) {
  95   ($server,$port) = split /:/,$opt_s;
  96   $port = 80 unless $port;
  97 }
  98 $server =~ s{http://}{};
  99 $server =~ s{/.*}{};
 100
 101 if ($proxy) {
 102   if ($port == 80)  { $proxy_prefix = "http://$server" }
 103   else              { $proxy_prefix = "http://$server:$port" }
 104 }
 105
 106 print "Testing $server:\n";
 107
 108 @r = formdatapost(
 109   from          => $from,
 110   to            => $to,
 111   id            => $id,
 112   comment       => $opt_n ? 'NOSTORE' : 'NOMAIL',
 113   keep          => 1,
 114   autodelete    => 'YES',
 115 );
 116
 117 if (not @r or not grep /\w/,@r) {
 118   die "$0: no response from server\n";
 119 }
 120
 121 if (($r) = grep /ERROR:/,@r) {
 122   $r =~ s/.*?:\s*//;
 123   $r =~ s/<.*//;
 124   die "$0: server error: $r\n";
 125 }
 126
 127 if (($r) = grep /^Location: http/,@r) {
 128   $r =~ s:.*(/fop/\w+/.+$):$1:;
 129   download($r);
 130 } else {
 131   download("/ddd/$mb");
 132 }
 133
 134 exit;
 135
 136
 137 sub formdatapost {
 138   my %P = @_;
 139   my ($boundary,$filename,$filesize,$length);
 140   my (@hh,@hb,@r,@pv);
 141   my ($t,$bt,$t0,$t1,$t2,$tt);
 142   my $buf = '#' x $bs;
 143   local $_;
 144
 145
 146   @hh = (); # HTTP header
 147   @hb = (); # HTTP body
 148   @r = ();
 149
 150   serverconnect($server,$port);
 151
 152   $boundary = randstring(48);
 153   $P{command} = 'CHECKRECIPIENT';
 154
 155   # HTTP POST variables
 156   @pv = qw'from to id command';
 157   foreach my $v (@pv) {
 158     if ($P{$v}) {
 159       my $name = uc($v);
 160       push @hb,"--$boundary";
 161       push @hb,"Content-Disposition: form-data; name=\"$name\"";
 162       push @hb,"";
 163       push @hb,$P{$v};
 164     }
 165   }
 166   push @hb,"--$boundary--";
 167
 168   $length = length(join('',@hb)) + scalar(@hb)*2 + $mb*M;
 169
 170   # HTTP header
 171   push @hh,"POST $proxy_prefix/fup HTTP/1.1";
 172   push @hh,"Host: $server:$port";
 173   push @hh,"User-Agent: $useragent";
 174   push @hh,"Content-Length: $length";
 175   push @hh,"Content-Type: multipart/form-data; boundary=$boundary";
 176   push @hh,"Connection: close";
 177   push @hh,'';
 178
 179   if ($opt_v) {
 180     printf "--> $_\n" foreach (@hh,@hb);
 181   }
 182
 183   nvtsend(@hh,@hb) or die "$0: server has closed the connection\n";
 184
 185   while (<$SH>) {
 186     s/[\r\n]+//;
 187     print "<-- $_\n" if $opt_v;
 188     push @r,$_;
 189     last if /^$/;
 190   }
 191
 192   unless (@r and $r[0] =~ / 204 /) {
 193     $_ = $r[0] || '';
 194     s/^HTTP.[.\d\s]+//;
 195     die "$0: server error: $_\n";
 196   }
 197
 198   @hh = (); # HTTP header
 199   @hb = (); # HTTP body
 200   @r = ();
 201   $filename = 'test_'.int(time*1000);
 202
 203   serverconnect($server,$port);
 204
 205   # HTTP POST variables
 206   @pv = qw'from to id keep autodelete comment filesize';
 207   foreach my $v (@pv) {
 208     if ($P{$v}) {
 209       my $name = uc($v);
 210       push @hb,"--$boundary";
 211       push @hb,"Content-Disposition: form-data; name=\"$name\"";
 212       push @hb,"";
 213       push @hb,$P{$v};
 214     }
 215   }
 216
 217   # at last, the file
 218   push @hb,"--$boundary";
 219   push @hb,"Content-Disposition: form-data; name=\"FILE\"; filename=\"$filename\"";
 220   push @hb,"Content-Type: application/octet-stream";
 221   push @hb,"";
 222   push @hb,"";
 223   push @hb,"--$boundary--";
 224
 225   $length = length(join('',@hb)) + scalar(@hb)*2 + $mb*M;
 226
 227   $hb[-2] = '(file content)';
 228
 229   # HTTP header
 230   push @hh,"POST $proxy_prefix/fup HTTP/1.1";
 231   push @hh,"Host: $server:$port";
 232   push @hh,"User-Agent: $useragent";
 233   push @hh,"Content-Length: $length";
 234   push @hh,"Content-Type: multipart/form-data; boundary=$boundary";
 235   push @hh,"Connection: close";
 236   push @hh,'';
 237
 238   if ($opt_v) {
 239     printf "--> $_\n" foreach (@hh,@hb);
 240   }
 241
 242   pop @hb;
 243   pop @hb;
 244   nvtsend(@hh,@hb) or die "$0: server has closed the connection\n";
 245
 246   $t0 = $t2 = int(time);
 247   $t1 = 0;
 248
 249   autoflush $SH 0;
 250
 251   for (;;) {
 252     print {$SH} $buf or die "$0: server has closed the connection\n";
 253     $b += $bs;
 254     $bt += $bs;
 255     $t2 = time;
 256     if (-t STDOUT and $t2-$t1>1) {
 257       # smaller block size is better on slow links
 258       if ($t1 and $bs>4096 and $bt/($t2-$t0)<65536) {
 259         $bs = 4096;
 260         $buf = '#' x $bs;
 261       }
 262       if ($bs>4096) {
 263         printf STDERR "upload: %s MB of %d MB, %d kB/s        \r",
 264           int($bt/M),
 265           $mb,
 266           int($b/k/($t2-$t1));
 267       } else {
 268         printf STDERR "upload: %s kB of %d MB, %d kB/s        \r",
 269           int($bt/k),
 270           $mb,
 271           int($b/k/($t2-$t1));
 272       }
 273       $t1 = $t2;
 274       $b = 0;
 275     }
 276     last if $bt >= $mb*M;
 277   }
 278
 279   autoflush $SH 1;
 280   print {$SH} "\r\n--$boundary--\r\n";
 281
 282   while (<$SH>) {
 283     s/[\r\n]+//;
 284     print "<-- $_\n" if $opt_v;
 285     last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i;
 286     push @r,$_;
 287   }
 288
 289   $tt = (time-$t0)||1;
 290   printf STDERR "upload: %d MB in %d s, %d kB/s        \n",
 291                 int($bt/M),$tt,int($bt/k/$tt);
 292
 293   close $SH;
 294   undef $SH;
 295
 296   return @r;
 297 }
 298
 299
 300 sub randstring {
 301     my $n = shift;
 302     my @rc = ('A'..'Z','a'..'z',0..9 );
 303     my $rn = @rc;
 304     my $rs;
 305
 306     for (1..$n) { $rs .= $rc[int(rand($rn))] };
 307     return $rs;
 308 }
 309
 310
 311 sub serverconnect {
 312   my ($server,$port) = @_;
 313   my $connect = "CONNECT $server:$port HTTP/1.1";
 314   local $_;
 315
 316   if ($proxy) {
 317     tcpconnect(split(':',$proxy));
 318     if ($port == 443) {
 319       printf "--> %s\n",$connect if $opt_v;
 320       nvtsend($connect,"");
 321       $_ = <$SH>;
 322       s/\r//;
 323       printf "<-- $_"if $opt_v;
 324       unless (/^HTTP.1.. 200/) {
 325         die "$0: proxy error : $_";
 326       }
 327       eval "use IO::Socket::SSL";
 328       die "$0: cannot load IO::Socket::SSL\n" if $@;
 329       $SH = IO::Socket::SSL->start_SSL($SH);
 330     }
 331   } else {
 332     tcpconnect($server,$port);
 333   }
 334 }
 335
 336
 337 # set up tcp/ip connection
 338 sub tcpconnect {
 339   my ($server,$port) = @_;
 340
 341   if ($SH) {
 342     close $SH;
 343     undef $SH;
 344   }
 345
 346   if ($port == 443) {
 347     eval "use IO::Socket::SSL";
 348     die "$0: cannot load IO::Socket::SSL\n" if $@;
 349     $SH = IO::Socket::SSL->new(
 350       PeerAddr => $server,
 351       PeerPort => $port,
 352       Proto    => 'tcp',
 353     );
 354   } else {
 355     $SH = IO::Socket::INET->new(
 356       PeerAddr => $server,
 357       PeerPort => $port,
 358       Proto    => 'tcp',
 359     );
 360   }
 361
 362   if ($SH) {
 363     autoflush $SH 1;
 364   } else {
 365     die "$0: cannot connect $server:$port - $@\n";
 366   }
 367
 368   print "TCPCONNECT to $server:$port\n" if $opt_v;
 369 }
 370
 371
 372 sub nvtsend {
 373   local $SIG{PIPE} = sub { $sigpipe = "@_" };
 374
 375   $sigpipe = '';
 376
 377   die "$0: internal error: no active network handle\n" unless $SH;
 378   die "$0: remote host has closed the link\n" unless $SH->connected;
 379
 380   foreach my $line (@_) {
 381     print {$SH} $line,"\r\n";
 382     if ($sigpipe) {
 383       undef $SH;
 384       return 0;
 385     }
 386   }
 387
 388   return 1;
 389 }
 390
 391
 392 sub mtime {
 393   my @d = localtime((stat shift)[9]);
 394   return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
 395 }
 396
 397
 398 sub download {
 399   my $fop = shift;
 400   my ($file);
 401   my ($t0,$t1,$t2,$tt,$kBs,$b,$bt,$tb,$B,$buf);
 402   my $length = 0;
 403   local $_;
 404
 405   serverconnect($server,$port);
 406
 407   sendheader(
 408     "GET $proxy_prefix$fop HTTP/1.1",
 409     "User-Agent: $useragent",
 410     "Host: $server:$port",
 411   );
 412
 413   $_ = <$SH>;
 414   die "$0: no response from fex server $server\n" unless $_;
 415   s/\r//;
 416
 417   if (/^HTTP\/[\d.]+ 2/) {
 418     warn "<-- $_" if $opt_v;
 419     while (<$SH>) {
 420       s/\r//;
 421       print "<-- $_" if $opt_v;
 422       last if /^\r?\n/;
 423       if (/^Content-length:\s*(\d+)/i) {
 424         $length = $1;
 425       }
 426     }
 427   } else {
 428     s/HTTP\/[\d.]+ \d+ //;
 429     die "$0: bad server reply: $_";
 430   }
 431
 432   $t0 = $t1 = $t2 = int(time);
 433   $tb = $B = 0;
 434   while ($B < $length and $b = read $SH,$buf,$bs) {
 435     $B += $b;
 436     $tb += $b;
 437     $bt += $b;
 438     $t2 = time;
 439     if (int($t2) > $t1) {
 440       $kBs = int($bt/k/($t2-$t1));
 441       $kBs = int($tb/k/($t2-$t0)) if $kBs < 10;
 442       $t1 = $t2;
 443       $bt = 0;
 444       # smaller block size is better on slow links
 445       $bs = 4096 if $bs>4096 and $tb/($t2-$t0)<65536;
 446       printf STDERR "download: %d MB in %d s, %d kB/s        \r",
 447                     int($tb/M),$t2-$t0,$kBs;
 448     }
 449   }
 450   close $SH;
 451
 452   $tt = $t2-$t0;
 453   $kBs = int($tb/k/($tt||1));
 454   printf STDERR "download: %d MB in %d s, %d kB/s        \n",
 455                 int($tb/M),$tt,$kBs;
 456 }
 457
 458
 459 sub sendheader {
 460   my @head = @_;
 461   my $head;
 462
 463   foreach $head (@head) {
 464     print "--> $head\n" if $opt_v;
 465     print {$SH} $head,"\r\n";
 466   }
 467   print "-->\n" if $opt_v;
 468   print {$SH} "\r\n";
 469 }