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