tools/page-loader/loader.pl

   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