The Tor Browser: tools/page-loader/loader.pl@925c144e1f1f

     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/.

     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;

    14 # list of test pages, JS to insert, httpbase, filebase, etc.

    15 use PageData;

    17 use vars qw(%params $req $cgi $dbh $pagedata

    18             $gStartNow $gStartNowStr

    19             $gResponseNow $gLogging);

    21 $gStartNow    = [gettimeofday];  # checkpoint the time

    22 $gStartNowStr = strftime "%Y%m%d%H%M%S", localtime;

    23 $gLogging     = 1;

    25 $req = new CGI::Request; # get the HTTP/CGI request

    26 $cgi = $req->cgi;

    28 $pagedata = PageData->new;

    30 setDefaultParams();

    32 #XXXdebugcrap

    33 #warn $params{index}, " ", $params{maxidx};

    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 }

    52 # cleanup

    53 $req = undef;

    54 $dbh->disconnect() if $dbh; # not strictly required (ignored in some cases anyways)

    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

    60 exit 0;

    62 #######################################################################

    64 sub logMessage {

    65     print STDERR strftime("[%a %b %d %H:%M:%S %Y] ", localtime), @_, "\n"

    66          if $gLogging;

    67 }

    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 }

    87 sub initialize {

    88     updateMetaTable();

    89     createDataSetTable();

    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 }

   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 }

   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 }

   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 }

   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,  $!";

   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";

   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' />";

   167     my $magic   = $pagedata->magicString;

   168     my $content = "";

   169     while (<HTML>) {

   170         s/$magic/$hook/;

   171         $content .= $_;

   172     }

   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...

   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?

   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     }

   199     return;

   200 }

   203 sub encodeHiResTime {

   204     my $timeref = shift;

   205     return unless ref($timeref);

   206     return $$timeref[0] . "-" . $$timeref[1];

   207 }

   210 sub decodeHiResTime {

   211     my $timestr = shift;

   212     return [ split('-', $timestr) ];

   213 }

   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 }

   225 sub updateDataBase {

   226     connectToDataBase(); # (may already be cached)

   227     updateMetaTable();

   228     updateDataSetTable() unless $params{c_part} == -1; # the initial request

   229 }

   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 }

   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

   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 }

   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");

   289   my ($sth, $sql);

   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 }

   322 sub updateMetaTable {

   324     connectToDataBase(); # if not already connected

   326     my $table = "tMetaTable";

   327     createMetaTable($table); # just returns if already created

   329     my ($sth, $sql);

   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();

   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;

   356     if (scalar(@dataset) == 0) {

   357         # this is a new dataset and id

   358         initMetaTableRecord($table);

   359         return;

   360     }

   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}

   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();

   389 }

   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 }

   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 }

   466 sub updateDataSetTable {

   467     my $table = shift;

   468     my $table = "t" . $params{id};

   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         };

   487     my $s_intvl = elapsedMilliSeconds( $gStartNow, $params{s_ts} );

   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();

   502 }

   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>

   517 <p>Questions: <a href="mailto:jrgm\@netscape.com">John Morrison</a>

   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";

   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>

   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>

   600     <table border="1" cellpadding="5" cellspacing="2">

   601 ENDOFHTML

   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 }

The Tor Browser / file revision

tools/page-loader/loader.pl@925c144e1f1f

tools/page-loader/loader.pl