michael@0: #!/usr/bin/perl
michael@0: #
michael@0: # This Source Code Form is subject to the terms of the Mozilla Public
michael@0: # License, v. 2.0. If a copy of the MPL was not distributed with this
michael@0: # file, You can obtain one at http://mozilla.org/MPL/2.0/.
michael@0:
michael@0: use strict;
michael@0: use CGI::Request;
michael@0: use CGI::Carp qw(fatalsToBrowser);
michael@0: use Time::HiRes qw(gettimeofday tv_interval);
michael@0: use POSIX qw(strftime);
michael@0: use DBI;
michael@0:
michael@0: # list of test pages, JS to insert, httpbase, filebase, etc.
michael@0: use PageData;
michael@0:
michael@0: use vars qw(%params $req $cgi $dbh $pagedata
michael@0: $gStartNow $gStartNowStr
michael@0: $gResponseNow $gLogging);
michael@0:
michael@0: $gStartNow = [gettimeofday]; # checkpoint the time
michael@0: $gStartNowStr = strftime "%Y%m%d%H%M%S", localtime;
michael@0: $gLogging = 1;
michael@0:
michael@0: $req = new CGI::Request; # get the HTTP/CGI request
michael@0: $cgi = $req->cgi;
michael@0:
michael@0: $pagedata = PageData->new;
michael@0:
michael@0: setDefaultParams();
michael@0:
michael@0: #XXXdebugcrap
michael@0: #warn $params{index}, " ", $params{maxidx};
michael@0:
michael@0: if (!defined($req->param('delay'))) {
michael@0: # give the user a form to pick options (but note that going
michael@0: # to "loader.pl?delay=1000" immediately starts the test run
michael@0: outputForm();
michael@0: }
michael@0: elsif (!$req->param('id')) {
michael@0: initialize(); # do redirect to start the cycle
michael@0: }
michael@0: elsif ($params{index} > $params{maxidx}) {
michael@0: redirectToReport(); # the test is over; spit out a summary
michael@0: markTestAsComplete(); # close the meta table entry
michael@0: }
michael@0: elsif (!isRequestStale()) {
michael@0: outputPage(); # otherwise, keep dishing out pages
michael@0: updateDataBase(); # client has the response; now write out stats to db
michael@0: }
michael@0:
michael@0: # cleanup
michael@0: $req = undef;
michael@0: $dbh->disconnect() if $dbh; # not strictly required (ignored in some cases anyways)
michael@0:
michael@0: #logMessage(sprintf("Page load server responded in %3d msec, total time %3d msec, pid: %d",
michael@0: # 1000*tv_interval($gStartNow, $gResponseNow), 1000*tv_interval($gStartNow), $$))
michael@0: # if $gResponseNow; # log only when a test page has been dished out
michael@0:
michael@0: exit 0;
michael@0:
michael@0: #######################################################################
michael@0:
michael@0: sub logMessage {
michael@0: print STDERR strftime("[%a %b %d %H:%M:%S %Y] ", localtime), @_, "\n"
michael@0: if $gLogging;
michael@0: }
michael@0:
michael@0:
michael@0: sub isRequestStale {
michael@0: my $limit = 30*60; # 30 minutes, although if we never stalled on mac I'd make it 3 minutes
michael@0: my $ts = decodeHiResTime($params{s_ts});
michael@0: my $delta = tv_interval($ts, $gStartNow);
michael@0: return undef if $delta < $limit;
michael@0: # otherwise, punt this request
michael@0: print "Content-type: text/html\n\n";
michael@0: print <<"ENDOFHTML";
michael@0: Page Loading Times Test
michael@0: The timestamp on the request is too old to continue:
michael@0: s_ts=$params{s_ts} was $delta seconds ago. Limit is $limit seconds.
michael@0:
michael@0: ENDOFHTML
michael@0: return 1; # it's stale
michael@0: }
michael@0:
michael@0:
michael@0: sub initialize {
michael@0: updateMetaTable();
michael@0: createDataSetTable();
michael@0:
michael@0: # start the test by bouncing off of an echo page
michael@0: my $script = $cgi->var("SCRIPT_NAME");
michael@0: my $server = $cgi->var("SERVER_NAME");
michael@0: my $proto = $ENV{SERVER_PORT} == 443 ? 'https://' : 'http://';
michael@0: my $me = $proto . $server . $script;
michael@0: $script =~ /^(.*\/).*$/;
michael@0: my $loc = "Location: ". $proto . $server . $1 . "echo.pl?";
michael@0: for (qw(id index maxcyc delay replace nocache timeout)) {
michael@0: $loc .= "$_=$params{$_}\&";
michael@0: }
michael@0: $loc .= "url=" . $me;
michael@0: print $loc, "\n\n";
michael@0: }
michael@0:
michael@0:
michael@0: sub redirectToReport {
michael@0: # n.b., can also add '&sort=1' to get a time sorted list
michael@0: my $proto = $ENV{SERVER_PORT} == 443 ? 'https://' : 'http://';
michael@0: my $loc = "Location: " . $proto . $cgi->var("SERVER_NAME");
michael@0: $cgi->var("SCRIPT_NAME") =~ /^(.*\/).*$/;
michael@0: $loc .= $1 . "report.pl?id=" . $params{id};
michael@0: # To use for a tinderbox, comment out the line above and uncomment this:
michael@0: # $loc .= $1 . "dump.pl?id=" . $params{id} . "&purge=1";
michael@0: print $loc, "\n\n";
michael@0: }
michael@0:
michael@0:
michael@0: sub generateTestId {
michael@0: # use the epoch time, in hex, plus a two-character random.
michael@0: return sprintf "%8X%02X", time(), int(256*rand());
michael@0: }
michael@0:
michael@0:
michael@0: sub setDefaultParams {
michael@0: $params{id} = $req->param('id') || generateTestId(); # "unique" id for this run
michael@0: $params{index} = $req->param('index') || 0; # request index for the test
michael@0: $params{maxcyc} = defined($req->param('maxcyc')) ?
michael@0: $req->param('maxcyc') : 3; # max visits (zero-based count)
michael@0: $params{delay} = $req->param('delay') || 1000; # setTimeout on the next request (msec)
michael@0: $params{replace} = $req->param('replace') || 0; # use Location.replace (1) or Location.href (0)
michael@0: $params{nocache} = $req->param('nocache') || 0; # serve content via uncacheable path
michael@0: $params{c_part} = $req->param('c_part') || 0; # client time elapsed; page head to onload (msec)
michael@0: $params{c_intvl} = $req->param('c_intvl') || 0; # client time elapsed; onload to onload event (msec)
michael@0: $params{c_ts} = $req->param('c_ts') || 0; # client timestamp (.getTime()) (msec)
michael@0: $params{content} = $req->param('content') || "UNKNOWN"; # name of content page for this data
michael@0: $params{s_ts} = $req->param('s_ts') || undef; # server timestamp; no default
michael@0: $params{timeout} = $req->param('timeout') || 30000; # msec; timer will cancel stalled page loading
michael@0: $params{maxidx} = ($params{maxcyc}+1) * $pagedata->length; # total pages loads to be done
michael@0: $params{curidx} = $params{index} % $pagedata->length; # current request index into page list
michael@0: $params{curcyc} = int(($params{index}-1) / $pagedata->length); # current "cycle" (visit)
michael@0: }
michael@0:
michael@0:
michael@0: sub outputPage {
michael@0: my $relpath = $pagedata->url($params{curidx});
michael@0: my $file = $pagedata->filebase . $relpath;
michael@0: open (HTML, "<$file") ||
michael@0: die "Can't open file: $file, $!";
michael@0:
michael@0: my $hook = "\n";
michael@0:
michael@0: my $basepath = $pagedata->httpbase;
michael@0: $basepath =~ s/^http:/https:/i
michael@0: if $ENV{SERVER_PORT} == 443;
michael@0: #warn "basepath: $basepath";
michael@0: $basepath =~ s#^(.*?)(/base/)$#$1/nocache$2# if ($params{nocache});
michael@0: $hook .= "";
michael@0:
michael@0: my $magic = $pagedata->magicString;
michael@0: my $content = "";
michael@0: while () {
michael@0: s/$magic/$hook/;
michael@0: $content .= $_;
michael@0: }
michael@0:
michael@0: my $contentTypeHeader;
michael@0: my $mimetype = $pagedata->mimetype($params{curidx});
michael@0: my $charset = $pagedata->charset($params{curidx});
michael@0: if ($charset) {
michael@0: $contentTypeHeader = qq{Content-type: $mimetype; charset="$charset"\n\n};
michael@0: } else {
michael@0: $contentTypeHeader = qq{Content-type: $mimetype\n\n};
michael@0: }
michael@0: #warn $contentTypeHeader; #XXXjrgm testing...
michael@0:
michael@0: # N.B., these two cookie headers are obsolete, since I pass server info in
michael@0: # JS now, to work around a bug in winEmbed with document.cookie. But
michael@0: # since I _was_ sending two cookies as part of the test, I have to keep
michael@0: # sending two cookies (at least for now, and it's not a bad thing to test)
michael@0: #XXX other headers to test/use?
michael@0:
michael@0: $gResponseNow = [gettimeofday]; # for logging
michael@0: { # turn on output autoflush, locally in this block
michael@0: print "Set-Cookie: moztest_SomeRandomCookie1=somerandomstring\n";
michael@0: print "Set-Cookie: moztest_SomeRandomCookie2=somerandomstring\n";
michael@0: print $contentTypeHeader;
michael@0: local $| = 1;
michael@0: print $content;
michael@0: }
michael@0:
michael@0: return;
michael@0: }
michael@0:
michael@0:
michael@0: sub encodeHiResTime {
michael@0: my $timeref = shift;
michael@0: return unless ref($timeref);
michael@0: return $$timeref[0] . "-" . $$timeref[1];
michael@0: }
michael@0:
michael@0:
michael@0: sub decodeHiResTime {
michael@0: my $timestr = shift;
michael@0: return [ split('-', $timestr) ];
michael@0: }
michael@0:
michael@0:
michael@0: sub elapsedMilliSeconds {
michael@0: my ($r_time, $timestr) = @_;
michael@0: return "NaN" unless $timestr;
michael@0: my $delta = tv_interval( [ split('-', $timestr) ], $r_time );
michael@0: my $delta = int(($delta*1000) - $params{delay}); # adjust for delay (in msec)
michael@0: return $delta;
michael@0: }
michael@0:
michael@0:
michael@0: sub updateDataBase {
michael@0: connectToDataBase(); # (may already be cached)
michael@0: updateMetaTable();
michael@0: updateDataSetTable() unless $params{c_part} == -1; # the initial request
michael@0: }
michael@0:
michael@0:
michael@0: sub connectToDataBase {
michael@0: # don't reconnect if already connected. (Other drivers provide this
michael@0: # for free I think, but not this one).
michael@0: if (!ref($dbh)) {
michael@0: $dbh = DBI->connect("DBI:CSV:f_dir=./db", {RaiseError => 1, AutoCommit => 1})
michael@0: || die "Cannot connect: " . $DBI::errstr;
michael@0: }
michael@0: }
michael@0:
michael@0:
michael@0: #
michael@0: # Holds the individual page load data for this id.
michael@0: #
michael@0: # (Of course, this should really be a single table for all datasets, but
michael@0: # that was becoming punitively slow with DBD::CSV. I could have moved to
michael@0: # a "real" database, but I didn't want to make that a requirement for
michael@0: # installing this on another server and using this test (e.g., install a
michael@0: # few modules and you can run this; no sql installation/maintenance required).
michael@0: # At some point though, I may switch to some sql db, but hopefully still allow
michael@0: # this to be used with a simple flat file db. (Hmm, maybe I should try a *dbm
michael@0: # as a compromise (disk based but indexed)).
michael@0: #
michael@0: sub createDataSetTable {
michael@0: my $table = "t" . $params{id};
michael@0: return if -f "db/$table"; # don't create it if it exists
michael@0: logMessage("createDataSetTable:\tdb/$table");
michael@0: connectToDataBase(); # cached
michael@0:
michael@0: my ($sth, $sql);
michael@0: $sql = qq{
michael@0: CREATE TABLE $table
michael@0: (DATETIME CHAR(14),
michael@0: ID CHAR(10),
michael@0: INDEX INTEGER,
michael@0: CUR_IDX INTEGER,
michael@0: CUR_CYC INTEGER,
michael@0: C_PART INTEGER,
michael@0: S_INTVL INTEGER,
michael@0: C_INTVL INTEGER,
michael@0: CONTENT CHAR(128)
michael@0: )
michael@0: };
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute();
michael@0: $sth->finish();
michael@0: return 1;
michael@0: }
michael@0:
michael@0:
michael@0: #
michael@0: # holds the information about all test runs
michael@0: #
michael@0: sub createMetaTable {
michael@0: my $table = shift;
michael@0: return if -f "db/$table"; # don't create it if it exists
michael@0: logMessage("createMetaTable:\tdb/$table");
michael@0:
michael@0: my ($sth, $sql);
michael@0:
michael@0: $sql = qq{
michael@0: CREATE TABLE $table
michael@0: (DATETIME CHAR(14),
michael@0: LASTPING CHAR(14),
michael@0: ID CHAR(8),
michael@0: INDEX INTEGER,
michael@0: CUR_IDX INTEGER,
michael@0: CUR_CYC INTEGER,
michael@0: CUR_CONTENT CHAR(128),
michael@0: STATE INTEGER,
michael@0: BLESSED INTEGER,
michael@0: MAXCYC INTEGER,
michael@0: MAXIDX INTEGER,
michael@0: REPLACE INTEGER,
michael@0: NOCACHE INTEGER,
michael@0: DELAY INTEGER,
michael@0: REMOTE_USER CHAR(16),
michael@0: HTTP_USER_AGENT CHAR(128),
michael@0: REMOTE_ADDR CHAR(15),
michael@0: USER_EMAIL CHAR(32),
michael@0: USER_COMMENT CHAR(256)
michael@0: )
michael@0: };
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute();
michael@0: $sth->finish();
michael@0: warn 'created meta table';
michael@0: return 1;
michael@0: }
michael@0:
michael@0:
michael@0: sub updateMetaTable {
michael@0:
michael@0: connectToDataBase(); # if not already connected
michael@0:
michael@0: my $table = "tMetaTable";
michael@0: createMetaTable($table); # just returns if already created
michael@0:
michael@0: my ($sth, $sql);
michael@0:
michael@0: $sql = qq{
michael@0: SELECT INDEX, MAXCYC, MAXIDX, REPLACE, NOCACHE,
michael@0: DELAY, REMOTE_USER, HTTP_USER_AGENT, REMOTE_ADDR
michael@0: FROM $table
michael@0: WHERE ID = '$params{id}'
michael@0: };
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute();
michael@0:
michael@0: my @dataset = ();
michael@0: while (my @data = $sth->fetchrow_array()) {
michael@0: push @dataset, {index => shift @data,
michael@0: maxcyc => shift @data,
michael@0: maxidx => shift @data,
michael@0: replace => shift @data,
michael@0: nocache => shift @data,
michael@0: delay => shift @data,
michael@0: remote_user => shift @data,
michael@0: http_user_agent => shift @data,
michael@0: remote_addr => shift @data
michael@0: };
michael@0: }
michael@0: $sth->finish();
michael@0: warn "More than one ID: $params{id} ??" if scalar(@dataset) > 1;
michael@0:
michael@0: if (scalar(@dataset) == 0) {
michael@0: # this is a new dataset and id
michael@0: initMetaTableRecord($table);
michael@0: return;
michael@0: }
michael@0:
michael@0: #XXX need to check that values are sane, and not update if they don't
michael@0: # match certain params. This should not happen in a normal test run.
michael@0: # However, if a test url was bookmarked or in history, I might get bogus
michael@0: # data collected after the fact. But I have a stale date set on the URL,
michael@0: # so that is good enough for now.
michael@0: # my $ref = shift @dataset; # check some $ref->{foo}
michael@0:
michael@0: $sql = qq{
michael@0: UPDATE $table
michael@0: SET LASTPING = ?,
michael@0: INDEX = ?,
michael@0: CUR_IDX = ?,
michael@0: CUR_CYC = ?,
michael@0: CUR_CONTENT = ?,
michael@0: STATE = ?
michael@0: WHERE ID = '$params{id}'
michael@0: };
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute($gStartNowStr,
michael@0: $params{index}-1, # (index-1) is complete; (index) in progress
michael@0: ($params{curidx}-1) % $pagedata->length,
michael@0: $params{curcyc},
michael@0: $params{content},
michael@0: 'OPEN'
michael@0: );
michael@0: $sth->finish();
michael@0:
michael@0: }
michael@0:
michael@0:
michael@0: sub markTestAsComplete {
michael@0: connectToDataBase(); # if not already connected
michael@0: my $table = "tMetaTable";
michael@0: createMetaTable($table); # just returns if already created
michael@0: my ($sth, $sql);
michael@0: #XXX should probably check if this ID exists first
michael@0: $sql = qq{
michael@0: UPDATE $table
michael@0: SET STATE = "COMPLETE"
michael@0: WHERE ID = '$params{id}'
michael@0: };
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute();
michael@0: $sth->finish();
michael@0: }
michael@0:
michael@0:
michael@0: sub initMetaTableRecord {
michael@0: # we know this record doesn't exist, so put in the initial values
michael@0: my $table = shift;
michael@0: my ($sth, $sql);
michael@0: $sql = qq{
michael@0: INSERT INTO $table
michael@0: (DATETIME,
michael@0: LASTPING,
michael@0: ID,
michael@0: INDEX,
michael@0: CUR_IDX,
michael@0: CUR_CYC,
michael@0: CUR_CONTENT,
michael@0: STATE,
michael@0: BLESSED,
michael@0: MAXCYC,
michael@0: MAXIDX,
michael@0: REPLACE,
michael@0: NOCACHE,
michael@0: DELAY,
michael@0: REMOTE_USER,
michael@0: HTTP_USER_AGENT,
michael@0: REMOTE_ADDR,
michael@0: USER_EMAIL,
michael@0: USER_COMMENT
michael@0: )
michael@0: VALUES (?,?,?,?,
michael@0: ?,?,?,?,
michael@0: ?,?,?,?,
michael@0: ?,?,?,?,
michael@0: ?,?,?)
michael@0: };
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute($gStartNowStr,
michael@0: $gStartNowStr,
michael@0: $params{id},
michael@0: $params{index}-1,
michael@0: ($params{curidx}-1) % $pagedata->length,
michael@0: $params{curcyc},
michael@0: $params{content},
michael@0: "INIT",
michael@0: 0,
michael@0: $params{maxcyc},
michael@0: $params{maxidx},
michael@0: $params{replace},
michael@0: $params{nocache},
michael@0: $params{delay},
michael@0: $cgi->var("REMOTE_USER"),
michael@0: $cgi->var("HTTP_USER_AGENT"),
michael@0: $cgi->var("REMOTE_ADDR"),
michael@0: "",
michael@0: ""
michael@0: );
michael@0: $sth->finish();
michael@0: }
michael@0:
michael@0:
michael@0: sub updateDataSetTable {
michael@0: my $table = shift;
michael@0: my $table = "t" . $params{id};
michael@0:
michael@0: my ($sth, $sql);
michael@0: $sql = qq{
michael@0: INSERT INTO $table
michael@0: (DATETIME,
michael@0: ID,
michael@0: INDEX,
michael@0: CUR_IDX,
michael@0: CUR_CYC,
michael@0: C_PART,
michael@0: S_INTVL,
michael@0: C_INTVL,
michael@0: CONTENT
michael@0: )
michael@0: VALUES (?,?,?,?,
michael@0: ?,?,?,?,?)
michael@0: };
michael@0:
michael@0: my $s_intvl = elapsedMilliSeconds( $gStartNow, $params{s_ts} );
michael@0:
michael@0: $sth = $dbh->prepare($sql);
michael@0: $sth->execute($gStartNowStr,
michael@0: $params{id},
michael@0: $params{index}-1,
michael@0: ($params{curidx}-1) % $pagedata->length,
michael@0: $params{curcyc},
michael@0: $params{c_part},
michael@0: $s_intvl,
michael@0: $params{c_intvl},
michael@0: $req->param('content'),
michael@0: );
michael@0: $sth->finish();
michael@0:
michael@0: }
michael@0:
michael@0:
michael@0: sub outputForm {
michael@0: my @prog = split('/', $0); my $prog = $prog[$#prog];
michael@0: print "Content-type: text/html\n\n";
michael@0: my $bgcolor = $ENV{SERVER_PORT} == 443 ? '#eebb66' : '#ffffff';
michael@0: print <<"ENDOFHTML";
michael@0:
michael@0:
michael@0: Page Loading Times Test
michael@0:
michael@0:
michael@0: Page Loading Times Test
michael@0:
michael@0: Questions: John Morrison
michael@0:
michael@0: ENDOFHTML
michael@0: print " - ";
michael@0: my $script = $cgi->var("SCRIPT_NAME");
michael@0: my $server = $cgi->var("SERVER_NAME");
michael@0: # pick the "other" protocol (i.e., test is inverted)
michael@0: my $proto = $ENV{SERVER_PORT} == 443 ? 'http://' : 'https://';
michael@0: my $other = $proto . $server . $script;
michael@0: if ($ENV{SERVER_PORT} == 443) {
michael@0: print "[ With no SSL | With SSL ]
";
michael@0: } else {
michael@0: print "[ With no SSL | With SSL ]
";
michael@0: }
michael@0: print <<"ENDOFHTML";
michael@0:
michael@0:
\n";
michael@0: return;
michael@0: }
michael@0: