]> git.treefish.org Git - fex.git/blob - bin/fbm
Original release 20160328
[fex.git] / 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 = 20160328;
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 }