The Tor Browser / file comparison

comparison: tools/page-loader/loader.pl

tools/page-loader/loader.pl

changeset 0
6474c204b198
equal deleted inserted replaced
-1:000000000000 0:f5c174a27413
1 #!/usr/bin/perl
2 #
3 # This Source Code Form is subject to the terms of the Mozilla Public
4 # License, v. 2.0. If a copy of the MPL was not distributed with this
5 # file, You can obtain one at http://mozilla.org/MPL/2.0/.
6
7 use strict;
8 use CGI::Request;
9 use CGI::Carp qw(fatalsToBrowser);
10 use Time::HiRes qw(gettimeofday tv_interval);
11 use POSIX qw(strftime);
12 use DBI;
13
14 # list of test pages, JS to insert, httpbase, filebase, etc.
15 use PageData;
16
17 use vars qw(%params $req $cgi $dbh $pagedata
18 $gStartNow $gStartNowStr
19 $gResponseNow $gLogging);
20
21 $gStartNow = [gettimeofday]; # checkpoint the time
22 $gStartNowStr = strftime "%Y%m%d%H%M%S", localtime;
23 $gLogging = 1;
24
25 $req = new CGI::Request; # get the HTTP/CGI request
26 $cgi = $req->cgi;
27
28 $pagedata = PageData->new;
29
30 setDefaultParams();
31
32 #XXXdebugcrap
33 #warn $params{index}, " ", $params{maxidx};
34
35 if (!defined($req->param('delay'))) {
36 # give the user a form to pick options (but note that going
37 # to "loader.pl?delay=1000" immediately starts the test run
38 outputForm();
39 }
40 elsif (!$req->param('id')) {
41 initialize(); # do redirect to start the cycle
42 }
43 elsif ($params{index} > $params{maxidx}) {
44 redirectToReport(); # the test is over; spit out a summary
45 markTestAsComplete(); # close the meta table entry
46 }
47 elsif (!isRequestStale()) {
48 outputPage(); # otherwise, keep dishing out pages
49 updateDataBase(); # client has the response; now write out stats to db
50 }
51
52 # cleanup
53 $req = undef;
54 $dbh->disconnect() if $dbh; # not strictly required (ignored in some cases anyways)
55
56 #logMessage(sprintf("Page load server responded in %3d msec, total time %3d msec, pid: %d",
57 # 1000*tv_interval($gStartNow, $gResponseNow), 1000*tv_interval($gStartNow), $$))
58 # if $gResponseNow; # log only when a test page has been dished out
59
60 exit 0;
61
62 #######################################################################
63
64 sub logMessage {
65 print STDERR strftime("[%a %b %d %H:%M:%S %Y] ", localtime), @_, "\n"
66 if $gLogging;
67 }
68
69
70 sub isRequestStale {
71 my $limit = 30*60; # 30 minutes, although if we never stalled on mac I'd make it 3 minutes
72 my $ts = decodeHiResTime($params{s_ts});
73 my $delta = tv_interval($ts, $gStartNow);
74 return undef if $delta < $limit;
75 # otherwise, punt this request
76 print "Content-type: text/html\n\n";
77 print <<"ENDOFHTML";
78 <html><head><title>Page Loading Times Test</title></head><body>
79 <p><b>The timestamp on the request is too old to continue:<br>
80 s_ts=$params{s_ts} was $delta seconds ago. Limit is $limit seconds.</b></p>
81 </body></html>
82 ENDOFHTML
83 return 1; # it's stale
84 }
85
86
87 sub initialize {
88 updateMetaTable();
89 createDataSetTable();
90
91 # start the test by bouncing off of an echo page
92 my $script = $cgi->var("SCRIPT_NAME");
93 my $server = $cgi->var("SERVER_NAME");
94 my $proto = $ENV{SERVER_PORT} == 443 ? 'https://' : 'http://';
95 my $me = $proto . $server . $script;
96 $script =~ /^(.*\/).*$/;
97 my $loc = "Location: ". $proto . $server . $1 . "echo.pl?";
98 for (qw(id index maxcyc delay replace nocache timeout)) {
99 $loc .= "$_=$params{$_}\&";
100 }
101 $loc .= "url=" . $me;
102 print $loc, "\n\n";
103 }
104
105
106 sub redirectToReport {
107 # n.b., can also add '&sort=1' to get a time sorted list
108 my $proto = $ENV{SERVER_PORT} == 443 ? 'https://' : 'http://';
109 my $loc = "Location: " . $proto . $cgi->var("SERVER_NAME");
110 $cgi->var("SCRIPT_NAME") =~ /^(.*\/).*$/;
111 $loc .= $1 . "report.pl?id=" . $params{id};
112 # To use for a tinderbox, comment out the line above and uncomment this:
113 # $loc .= $1 . "dump.pl?id=" . $params{id} . "&purge=1";
114 print $loc, "\n\n";
115 }
116
117
118 sub generateTestId {
119 # use the epoch time, in hex, plus a two-character random.
120 return sprintf "%8X%02X", time(), int(256*rand());
121 }
122
123
124 sub setDefaultParams {
125 $params{id} = $req->param('id') || generateTestId(); # "unique" id for this run
126 $params{index} = $req->param('index') || 0; # request index for the test
127 $params{maxcyc} = defined($req->param('maxcyc')) ?
128 $req->param('maxcyc') : 3; # max visits (zero-based count)
129 $params{delay} = $req->param('delay') || 1000; # setTimeout on the next request (msec)
130 $params{replace} = $req->param('replace') || 0; # use Location.replace (1) or Location.href (0)
131 $params{nocache} = $req->param('nocache') || 0; # serve content via uncacheable path
132 $params{c_part} = $req->param('c_part') || 0; # client time elapsed; page head to onload (msec)
133 $params{c_intvl} = $req->param('c_intvl') || 0; # client time elapsed; onload to onload event (msec)
134 $params{c_ts} = $req->param('c_ts') || 0; # client timestamp (.getTime()) (msec)
135 $params{content} = $req->param('content') || "UNKNOWN"; # name of content page for this data
136 $params{s_ts} = $req->param('s_ts') || undef; # server timestamp; no default
137 $params{timeout} = $req->param('timeout') || 30000; # msec; timer will cancel stalled page loading
138 $params{maxidx} = ($params{maxcyc}+1) * $pagedata->length; # total pages loads to be done
139 $params{curidx} = $params{index} % $pagedata->length; # current request index into page list
140 $params{curcyc} = int(($params{index}-1) / $pagedata->length); # current "cycle" (visit)
141 }
142
143
144 sub outputPage {
145 my $relpath = $pagedata->url($params{curidx});
146 my $file = $pagedata->filebase . $relpath;
147 open (HTML, "<$file") ||
148 die "Can't open file: $file, $!";
149
150 my $hook = "<script xmlns='http://www.w3.org/1999/xhtml'>\n";
151 $hook .= "var g_moztest_Start = (new Date()).getTime();\n";
152 $hook .= "var g_moztest_ServerTime='" . encodeHiResTime($gStartNow) . "';\n";
153 $hook .= "var g_moztest_Content='" . $pagedata->name($params{curidx}) . "';\n";
154 $hook .= $pagedata->clientJS; # ... and the main body
155 $hook .= "var g_moztest_safetyTimer = ";
156 $hook .= "window.setTimeout(moztest_safetyValve, " . $params{timeout} . ");";
157 $hook .= "</script>\n";
158
159 my $basepath = $pagedata->httpbase;
160 $basepath =~ s/^http:/https:/i
161 if $ENV{SERVER_PORT} == 443;
162 #warn "basepath: $basepath";
163 $basepath =~ s#^(.*?)(/base/)$#$1/nocache$2# if ($params{nocache});
164 $hook .= "<base href='". $basepath . $relpath .
165 "' xmlns='http://www.w3.org/1999/xhtml' />";
166
167 my $magic = $pagedata->magicString;
168 my $content = "";
169 while (<HTML>) {
170 s/$magic/$hook/;
171 $content .= $_;
172 }
173
174 my $contentTypeHeader;
175 my $mimetype = $pagedata->mimetype($params{curidx});
176 my $charset = $pagedata->charset($params{curidx});
177 if ($charset) {
178 $contentTypeHeader = qq{Content-type: $mimetype; charset="$charset"\n\n};
179 } else {
180 $contentTypeHeader = qq{Content-type: $mimetype\n\n};
181 }
182 #warn $contentTypeHeader; #XXXjrgm testing...
183
184 # N.B., these two cookie headers are obsolete, since I pass server info in
185 # JS now, to work around a bug in winEmbed with document.cookie. But
186 # since I _was_ sending two cookies as part of the test, I have to keep
187 # sending two cookies (at least for now, and it's not a bad thing to test)
188 #XXX other headers to test/use?
189
190 $gResponseNow = [gettimeofday]; # for logging
191 { # turn on output autoflush, locally in this block
192 print "Set-Cookie: moztest_SomeRandomCookie1=somerandomstring\n";
193 print "Set-Cookie: moztest_SomeRandomCookie2=somerandomstring\n";
194 print $contentTypeHeader;
195 local $| = 1;
196 print $content;
197 }
198
199 return;
200 }
201
202
203 sub encodeHiResTime {
204 my $timeref = shift;
205 return unless ref($timeref);
206 return $$timeref[0] . "-" . $$timeref[1];
207 }
208
209
210 sub decodeHiResTime {
211 my $timestr = shift;
212 return [ split('-', $timestr) ];
213 }
214
215
216 sub elapsedMilliSeconds {
217 my ($r_time, $timestr) = @_;
218 return "NaN" unless $timestr;
219 my $delta = tv_interval( [ split('-', $timestr) ], $r_time );
220 my $delta = int(($delta*1000) - $params{delay}); # adjust for delay (in msec)
221 return $delta;
222 }
223
224
225 sub updateDataBase {
226 connectToDataBase(); # (may already be cached)
227 updateMetaTable();
228 updateDataSetTable() unless $params{c_part} == -1; # the initial request
229 }
230
231
232 sub connectToDataBase {
233 # don't reconnect if already connected. (Other drivers provide this
234 # for free I think, but not this one).
235 if (!ref($dbh)) {
236 $dbh = DBI->connect("DBI:CSV:f_dir=./db", {RaiseError => 1, AutoCommit => 1})
237 || die "Cannot connect: " . $DBI::errstr;
238 }
239 }
240
241
242 #
243 # Holds the individual page load data for this id.
244 #
245 # (Of course, this should really be a single table for all datasets, but
246 # that was becoming punitively slow with DBD::CSV. I could have moved to
247 # a "real" database, but I didn't want to make that a requirement for
248 # installing this on another server and using this test (e.g., install a
249 # few modules and you can run this; no sql installation/maintenance required).
250 # At some point though, I may switch to some sql db, but hopefully still allow
251 # this to be used with a simple flat file db. (Hmm, maybe I should try a *dbm
252 # as a compromise (disk based but indexed)).
253 #
254 sub createDataSetTable {
255 my $table = "t" . $params{id};
256 return if -f "db/$table"; # don't create it if it exists
257 logMessage("createDataSetTable:\tdb/$table");
258 connectToDataBase(); # cached
259
260 my ($sth, $sql);
261 $sql = qq{
262 CREATE TABLE $table
263 (DATETIME CHAR(14),
264 ID CHAR(10),
265 INDEX INTEGER,
266 CUR_IDX INTEGER,
267 CUR_CYC INTEGER,
268 C_PART INTEGER,
269 S_INTVL INTEGER,
270 C_INTVL INTEGER,
271 CONTENT CHAR(128)
272 )
273 };
274 $sth = $dbh->prepare($sql);
275 $sth->execute();
276 $sth->finish();
277 return 1;
278 }
279
280
281 #
282 # holds the information about all test runs
283 #
284 sub createMetaTable {
285 my $table = shift;
286 return if -f "db/$table"; # don't create it if it exists
287 logMessage("createMetaTable:\tdb/$table");
288
289 my ($sth, $sql);
290
291 $sql = qq{
292 CREATE TABLE $table
293 (DATETIME CHAR(14),
294 LASTPING CHAR(14),
295 ID CHAR(8),
296 INDEX INTEGER,
297 CUR_IDX INTEGER,
298 CUR_CYC INTEGER,
299 CUR_CONTENT CHAR(128),
300 STATE INTEGER,
301 BLESSED INTEGER,
302 MAXCYC INTEGER,
303 MAXIDX INTEGER,
304 REPLACE INTEGER,
305 NOCACHE INTEGER,
306 DELAY INTEGER,
307 REMOTE_USER CHAR(16),
308 HTTP_USER_AGENT CHAR(128),
309 REMOTE_ADDR CHAR(15),
310 USER_EMAIL CHAR(32),
311 USER_COMMENT CHAR(256)
312 )
313 };
314 $sth = $dbh->prepare($sql);
315 $sth->execute();
316 $sth->finish();
317 warn 'created meta table';
318 return 1;
319 }
320
321
322 sub updateMetaTable {
323
324 connectToDataBase(); # if not already connected
325
326 my $table = "tMetaTable";
327 createMetaTable($table); # just returns if already created
328
329 my ($sth, $sql);
330
331 $sql = qq{
332 SELECT INDEX, MAXCYC, MAXIDX, REPLACE, NOCACHE,
333 DELAY, REMOTE_USER, HTTP_USER_AGENT, REMOTE_ADDR
334 FROM $table
335 WHERE ID = '$params{id}'
336 };
337 $sth = $dbh->prepare($sql);
338 $sth->execute();
339
340 my @dataset = ();
341 while (my @data = $sth->fetchrow_array()) {
342 push @dataset, {index => shift @data,
343 maxcyc => shift @data,
344 maxidx => shift @data,
345 replace => shift @data,
346 nocache => shift @data,
347 delay => shift @data,
348 remote_user => shift @data,
349 http_user_agent => shift @data,
350 remote_addr => shift @data
351 };
352 }
353 $sth->finish();
354 warn "More than one ID: $params{id} ??" if scalar(@dataset) > 1;
355
356 if (scalar(@dataset) == 0) {
357 # this is a new dataset and id
358 initMetaTableRecord($table);
359 return;
360 }
361
362 #XXX need to check that values are sane, and not update if they don't
363 # match certain params. This should not happen in a normal test run.
364 # However, if a test url was bookmarked or in history, I might get bogus
365 # data collected after the fact. But I have a stale date set on the URL,
366 # so that is good enough for now.
367 # my $ref = shift @dataset; # check some $ref->{foo}
368
369 $sql = qq{
370 UPDATE $table
371 SET LASTPING = ?,
372 INDEX = ?,
373 CUR_IDX = ?,
374 CUR_CYC = ?,
375 CUR_CONTENT = ?,
376 STATE = ?
377 WHERE ID = '$params{id}'
378 };
379 $sth = $dbh->prepare($sql);
380 $sth->execute($gStartNowStr,
381 $params{index}-1, # (index-1) is complete; (index) in progress
382 ($params{curidx}-1) % $pagedata->length,
383 $params{curcyc},
384 $params{content},
385 'OPEN'
386 );
387 $sth->finish();
388
389 }
390
391
392 sub markTestAsComplete {
393 connectToDataBase(); # if not already connected
394 my $table = "tMetaTable";
395 createMetaTable($table); # just returns if already created
396 my ($sth, $sql);
397 #XXX should probably check if this ID exists first
398 $sql = qq{
399 UPDATE $table
400 SET STATE = "COMPLETE"
401 WHERE ID = '$params{id}'
402 };
403 $sth = $dbh->prepare($sql);
404 $sth->execute();
405 $sth->finish();
406 }
407
408
409 sub initMetaTableRecord {
410 # we know this record doesn't exist, so put in the initial values
411 my $table = shift;
412 my ($sth, $sql);
413 $sql = qq{
414 INSERT INTO $table
415 (DATETIME,
416 LASTPING,
417 ID,
418 INDEX,
419 CUR_IDX,
420 CUR_CYC,
421 CUR_CONTENT,
422 STATE,
423 BLESSED,
424 MAXCYC,
425 MAXIDX,
426 REPLACE,
427 NOCACHE,
428 DELAY,
429 REMOTE_USER,
430 HTTP_USER_AGENT,
431 REMOTE_ADDR,
432 USER_EMAIL,
433 USER_COMMENT
434 )
435 VALUES (?,?,?,?,
436 ?,?,?,?,
437 ?,?,?,?,
438 ?,?,?,?,
439 ?,?,?)
440 };
441 $sth = $dbh->prepare($sql);
442 $sth->execute($gStartNowStr,
443 $gStartNowStr,
444 $params{id},
445 $params{index}-1,
446 ($params{curidx}-1) % $pagedata->length,
447 $params{curcyc},
448 $params{content},
449 "INIT",
450 0,
451 $params{maxcyc},
452 $params{maxidx},
453 $params{replace},
454 $params{nocache},
455 $params{delay},
456 $cgi->var("REMOTE_USER"),
457 $cgi->var("HTTP_USER_AGENT"),
458 $cgi->var("REMOTE_ADDR"),
459 "",
460 ""
461 );
462 $sth->finish();
463 }
464
465
466 sub updateDataSetTable {
467 my $table = shift;
468 my $table = "t" . $params{id};
469
470 my ($sth, $sql);
471 $sql = qq{
472 INSERT INTO $table
473 (DATETIME,
474 ID,
475 INDEX,
476 CUR_IDX,
477 CUR_CYC,
478 C_PART,
479 S_INTVL,
480 C_INTVL,
481 CONTENT
482 )
483 VALUES (?,?,?,?,
484 ?,?,?,?,?)
485 };
486
487 my $s_intvl = elapsedMilliSeconds( $gStartNow, $params{s_ts} );
488
489 $sth = $dbh->prepare($sql);
490 $sth->execute($gStartNowStr,
491 $params{id},
492 $params{index}-1,
493 ($params{curidx}-1) % $pagedata->length,
494 $params{curcyc},
495 $params{c_part},
496 $s_intvl,
497 $params{c_intvl},
498 $req->param('content'),
499 );
500 $sth->finish();
501
502 }
503
504
505 sub outputForm {
506 my @prog = split('/', $0); my $prog = $prog[$#prog];
507 print "Content-type: text/html\n\n";
508 my $bgcolor = $ENV{SERVER_PORT} == 443 ? '#eebb66' : '#ffffff';
509 print <<"ENDOFHTML";
510 <html>
511 <head>
512 <title>Page Loading Times Test</title>
513 </head>
514 <body bgcolor="$bgcolor">
515 <h3>Page Loading Times Test</h3>
516
517 <p>Questions: <a href="mailto:jrgm\@netscape.com">John Morrison</a>
518
519 ENDOFHTML
520 print "&nbsp;&nbsp;-&nbsp;&nbsp;";
521 my $script = $cgi->var("SCRIPT_NAME");
522 my $server = $cgi->var("SERVER_NAME");
523 # pick the "other" protocol (i.e., test is inverted)
524 my $proto = $ENV{SERVER_PORT} == 443 ? 'http://' : 'https://';
525 my $other = $proto . $server . $script;
526 if ($ENV{SERVER_PORT} == 443) {
527 print "[&nbsp;<a href='$other'>With no SSL</a>&nbsp;|&nbsp;<b>With SSL</b>&nbsp;]<br>";
528 } else {
529 print "[&nbsp;<b>With no SSL</b>&nbsp;|&nbsp;<a href='$other'>With SSL</a>&nbsp;]<br>";
530 }
531 print <<"ENDOFHTML";
532
533 <form method="get" action="$prog" >
534 <table border="1" cellpadding="5" cellspacing="2">
535 <tr>
536 <td valign="top">
537 Page-load to Page-load Delay (msec):<br>
538 (Use 1000. Be nice.)
539 </td>
540 <td valign="top">
541 <select name="delay">
542 <option value="0">0
543 <option value="500">500
544 <option selected value="1000">1000
545 <option value="2000">2000
546 <option value="3000">3000
547 <option value="4000">4000
548 <option value="5000">5000
549 </select>
550 </td>
551 </tr>
552 <tr>
553 <td valign="top">
554 Number of test cycles to run:<br>
555 <br>
556 </td>
557 <td valign="top">
558 <select name="maxcyc">
559 <option value="0">1
560 <option value="1">2
561 <option value="2">3
562 <option value="3">4
563 <option value="4" selected>5
564 <option value="5">6
565 <option value="6">7
566 </select>
567 </td>
568 </tr>
569 <tr>
570 <td valign="top">
571 How long to wait before cancelling (msec):<br>
572 (Don't change this unless on a very slow link, or very slow machine.)
573 </td>
574 <td valign="top">
575 <select name="timeout">
576 <option value="15000">15000
577 <option selected value="30000">30000
578 <option value="45000">45000
579 <option value="60000">60000
580 <option value="90000">90000
581 </select>
582 </td>
583 </tr>
584 <tr>
585 <td valign="top">
586 <input type="reset" value="reset">
587 </td>
588 <td valign="top">
589 <input type="submit" value="submit">
590 </td>
591 </tr>
592 </table>
593
594 <hr>
595 <p>
596 You can visit the content that will be loaded, minus the embedded
597 javascript, by clicking on any of the links below.
598 </p>
599
600 <table border="1" cellpadding="5" cellspacing="2">
601 ENDOFHTML
602
603 my $i;
604 print "<tr>\n";
605 my $base = $pagedata->httpbase;
606 $base =~ s/^http:/https:/i
607 if $ENV{SERVER_PORT} == 443;
608 for ($i=0; $i<$pagedata->length; $i++) {
609 print "<td nowrap><a href='", $base, $pagedata->url($i), "'>";
610 print $pagedata->name($i);
611 print "</a>\n";
612 print "</tr><tr>\n" if (($i+1)%4 == 0);
613 }
614 print "</tr>" if (($i+1)%4 != 0);
615 print "</table></form></body></html>\n";
616 return;
617 }
618

Mercurial Repository: The Tor Browser

Europalab SCM Repository Server

mercurial