fex-utils 20160104-1 / usr / share / fex / bin / fbm

#!/usr/bin/perl -w

# F*EX benchmark
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: Perl Artistic

use 5.006;
use strict qw'vars subs';
use Config;
use Socket;
use IO::Handle;
use IO::Socket::INET;
use Getopt::Std;
use Time::HiRes qw'time';
# use Smart::Comments;
use constant k => 2**10;
use constant M => 2**20;

our ($SH,$windoof,$sigpipe,$useragent);
our ($FEXSERVER);
our $version = 20160104;

# server defaults
my $server = 'fex.rus.uni-stuttgart.de';
my $port = 80;
my $proxy = '';

my $from = 'nettest';
my $to = $from;
my $id = $from;
my $proxy_prefix = '';
my $mb;
my (@r,$r);
my $bs = 2**16;
my $timeout = 30; 	# server timeout

$version ||= mtime($0);
$0 =~ s:.*/::;

my $usage = <<EOD;
usage: $0 [-n] [-s server] [-P proxy] #MB
options: -n  do not store on server
         -s  use alternative F*EX server:port
         -P  use proxy server:port
examples: $0 1000
EOD
  
if ($Config{osname} =~ /^mswin/i) {
  $windoof = $Config{osname};
  $useragent = sprintf("fbm-$version (%s %s)",
                       $Config{osname},$Config{archname});
} else {
  $0 =~ s:.*/::;
  $_ = `(lsb_release -d||uname -a)2>/dev/null`||'';
  chomp;
  s/^Description:\s+//;
  $useragent = "fbm-$version ($_)";
}

$| = 1;

autoflush STDERR;

my @_ARGV = @ARGV; # save arguments

our $opt_n = 0;
our $opt_v = 0;
our $opt_h = 0;
our $opt_s = '';
our $opt_P = '';

getopts('hvnP:s:') or die $usage;

if ($opt_h) {
  print $usage;
  exit;
}

if ($opt_P) { 
  if ($opt_P =~ /^[\w.-]+:\d+/) {
    $proxy = $opt_P;
  } else {
    die "$0: proxy must be: SERVER:PORT\n";
  }
}

$mb = shift    or die $usage;
$mb =~ /^\d+$/ or die $usage;

# $port = $1  if $server =~ s/:(\d+)//;

if ($opt_s) {
  ($server,$port) = split /:/,$opt_s;
  $port = 80 unless $port;
}
$server =~ s{http://}{};
$server =~ s{/.*}{};

if ($proxy) {
  if ($port == 80)  { $proxy_prefix = "http://$server" }
  else              { $proxy_prefix = "http://$server:$port" }
}

print "Testing $server:\n";

@r = formdatapost(
  from		=> $from,
  to		=> $to,
  id		=> $id,
  comment	=> $opt_n ? 'NOSTORE' : 'NOMAIL',
  keep		=> 1,
  autodelete	=> 'YES', 
);
  
if (not @r or not grep /\w/,@r) {
  die "$0: no response from server\n";
}

if (($r) = grep /ERROR:/,@r) {
  $r =~ s/.*?:\s*//;
  $r =~ s/<.*//;
  die "$0: server error: $r\n";
}

if (($r) = grep /^Location: http/,@r) {
  $r =~ s:.*(/fop/\w+/.+$):$1:;
  download($r);
} else {
  download("/ddd/$mb");
}
  
exit;


sub formdatapost {
  my %P = @_; 
  my ($boundary,$filename,$filesize,$length);
  my (@hh,@hb,@r,@pv);
  my ($t,$bt,$t0,$t1,$t2,$tt);
  my $buf = '#' x $bs;
  local $_;


  @hh = (); # HTTP header
  @hb = (); # HTTP body
  @r = ();

  serverconnect($server,$port);
    
  $boundary = randstring(48);
  $P{command} = 'CHECKRECIPIENT';
  
  # HTTP POST variables
  @pv = qw'from to id command';
  foreach my $v (@pv) {
    if ($P{$v}) {
      my $name = uc($v);
      push @hb,"--$boundary";
      push @hb,"Content-Disposition: form-data; name=\"$name\"";
      push @hb,"";
      push @hb,$P{$v};
    }
  }
  push @hb,"--$boundary--";

  $length = length(join('',@hb)) + scalar(@hb)*2 + $mb*M;

  # HTTP header
  push @hh,"POST $proxy_prefix/fup HTTP/1.1";
  push @hh,"Host: $server:$port";
  push @hh,"User-Agent: $useragent";
  push @hh,"Content-Length: $length";
  push @hh,"Content-Type: multipart/form-data; boundary=$boundary";
  push @hh,"Connection: close";
  push @hh,'';

  if ($opt_v) {
    printf "--> $_\n" foreach (@hh,@hb);
  }

  nvtsend(@hh,@hb) or die "$0: server has closed the connection\n";

  while (<$SH>) {
    s/[\r\n]+//;
    print "<-- $_\n" if $opt_v;
    push @r,$_;
    last if /^$/;
  }

  unless (@r and $r[0] =~ / 204 /) {
    $_ = $r[0] || '';
    s/^HTTP.[.\d\s]+//;
    die "$0: server error: $_\n";
  }

  @hh = (); # HTTP header
  @hb = (); # HTTP body
  @r = ();
  $filename = 'test_'.int(time*1000);

  serverconnect($server,$port);

  # HTTP POST variables
  @pv = qw'from to id keep autodelete comment filesize';
  foreach my $v (@pv) {
    if ($P{$v}) {
      my $name = uc($v);
      push @hb,"--$boundary";
      push @hb,"Content-Disposition: form-data; name=\"$name\"";
      push @hb,"";
      push @hb,$P{$v};
    }
  }
  
  # at last, the file
  push @hb,"--$boundary";
  push @hb,"Content-Disposition: form-data; name=\"FILE\"; filename=\"$filename\"";
  push @hb,"Content-Type: application/octet-stream";
  push @hb,"";
  push @hb,"";
  push @hb,"--$boundary--";

  $length = length(join('',@hb)) + scalar(@hb)*2 + $mb*M;

  $hb[-2] = '(file content)';

  # HTTP header
  push @hh,"POST $proxy_prefix/fup HTTP/1.1";
  push @hh,"Host: $server:$port";
  push @hh,"User-Agent: $useragent";
  push @hh,"Content-Length: $length";
  push @hh,"Content-Type: multipart/form-data; boundary=$boundary";
  push @hh,"Connection: close";
  push @hh,'';

  if ($opt_v) {
    printf "--> $_\n" foreach (@hh,@hb);
  }

  pop @hb;
  pop @hb;
  nvtsend(@hh,@hb) or die "$0: server has closed the connection\n";
      
  $t0 = $t2 = int(time);
  $t1 = 0;
      
  autoflush $SH 0;
      
  for (;;) {
    print {$SH} $buf or die "$0: server has closed the connection\n";
    $b += $bs;
    $bt += $bs;
    $t2 = time;
    if (-t STDOUT and $t2-$t1>1) {
      # smaller block size is better on slow links
      if ($t1 and $bs>4096 and $bt/($t2-$t0)<65536) {
        $bs = 4096;
        $buf = '#' x $bs;
      }
      if ($bs>4096) {
        printf STDERR "upload: %s MB of %d MB, %d kB/s        \r",
          int($bt/M),
          $mb,
          int($b/k/($t2-$t1));
      } else {
        printf STDERR "upload: %s kB of %d MB, %d kB/s        \r",
          int($bt/k),
          $mb,
          int($b/k/($t2-$t1));
      }
      $t1 = $t2;
      $b = 0;
    }
    last if $bt >= $mb*M;
  }
  
  autoflush $SH 1;
  print {$SH} "\r\n--$boundary--\r\n";

  while (<$SH>) {
    s/[\r\n]+//;
    print "<-- $_\n" if $opt_v;
    last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i;
    push @r,$_;
  }
  
  $tt = (time-$t0)||1;
  printf STDERR "upload: %d MB in %d s, %d kB/s        \n",
                int($bt/M),$tt,int($bt/k/$tt);
      
  close $SH;
  undef $SH;
  
  return @r;
}


sub randstring {
    my $n = shift;
    my @rc = ('A'..'Z','a'..'z',0..9 );
    my $rn = @rc;
    my $rs;

    for (1..$n) { $rs .= $rc[int(rand($rn))] };
    return $rs;
}


sub serverconnect {
  my ($server,$port) = @_;
  my $connect = "CONNECT $server:$port HTTP/1.1";
  local $_;
  
  if ($proxy) {
    tcpconnect(split(':',$proxy));
    if ($port == 443) {
      printf "--> %s\n",$connect if $opt_v;
      nvtsend($connect,"");
      $_ = <$SH>;
      s/\r//;
      printf "<-- $_"if $opt_v;
      unless (/^HTTP.1.. 200/) {
        die "$0: proxy error : $_";
      }
      eval "use IO::Socket::SSL";
      die "$0: cannot load IO::Socket::SSL\n" if $@;
      $SH = IO::Socket::SSL->start_SSL($SH);
    }
  } else {
    tcpconnect($server,$port);
  }
}


# set up tcp/ip connection
sub tcpconnect {
  my ($server,$port) = @_;
  
  if ($SH) {
    close $SH;
    undef $SH;
  }
  
  if ($port == 443) {
    eval "use IO::Socket::SSL";
    die "$0: cannot load IO::Socket::SSL\n" if $@;
    $SH = IO::Socket::SSL->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
    );
  } else {
    $SH = IO::Socket::INET->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
    );
  }
  
  if ($SH) {
    autoflush $SH 1;
  } else {
    die "$0: cannot connect $server:$port - $@\n";
  }
  
  print "TCPCONNECT to $server:$port\n" if $opt_v;
}


sub nvtsend {
  local $SIG{PIPE} = sub { $sigpipe = "@_" };
  
  $sigpipe = '';
  
  die "$0: internal error: no active network handle\n" unless $SH;
  die "$0: remote host has closed the link\n" unless $SH->connected;
  
  foreach my $line (@_) {
    print {$SH} $line,"\r\n";
    if ($sigpipe) {
      undef $SH;
      return 0;
    }
  }
  
  return 1;
}


sub mtime {
  my @d = localtime((stat shift)[9]);
  return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
}


sub download {
  my $fop = shift;
  my ($file);
  my ($t0,$t1,$t2,$tt,$kBs,$b,$bt,$tb,$B,$buf);
  my $length = 0;
  local $_;

  serverconnect($server,$port);
  
  sendheader(
    "GET $proxy_prefix$fop HTTP/1.1",
    "User-Agent: $useragent",
    "Host: $server:$port",
  );

  $_ = <$SH>;
  die "$0: no response from fex server $server\n" unless $_;
  s/\r//;

  if (/^HTTP\/[\d.]+ 2/) {
    warn "<-- $_" if $opt_v;
    while (<$SH>) {
      s/\r//;
      print "<-- $_" if $opt_v;
      last if /^\r?\n/;
      if (/^Content-length:\s*(\d+)/i) {
        $length = $1;
      }
    }
  } else {
    s/HTTP\/[\d.]+ \d+ //;
    die "$0: bad server reply: $_";
  }

  $t0 = $t1 = $t2 = int(time);
  $tb = $B = 0;
  while ($B < $length and $b = read $SH,$buf,$bs) {
    $B += $b;
    $tb += $b;
    $bt += $b;
    $t2 = time;
    if (int($t2) > $t1) {
      $kBs = int($bt/k/($t2-$t1));
      $kBs = int($tb/k/($t2-$t0)) if $kBs < 10;
      $t1 = $t2;
      $bt = 0;
      # smaller block size is better on slow links
      $bs = 4096 if $bs>4096 and $tb/($t2-$t0)<65536;
      printf STDERR "download: %d MB in %d s, %d kB/s        \r",
                    int($tb/M),$t2-$t0,$kBs;
    }
  }
  close $SH;

  $tt = $t2-$t0;
  $kBs = int($tb/k/($tt||1));
  printf STDERR "download: %d MB in %d s, %d kB/s        \n",
                int($tb/M),$tt,$kBs;
}


sub sendheader {
  my @head = @_;
  my $head;
  
  foreach $head (@head) {
    print "--> $head\n" if $opt_v;
    print {$SH} $head,"\r\n";
  }
  print "-->\n" if $opt_v;
  print {$SH} "\r\n";
}