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: use DBI;    
michael@0: use CGI::Carp qw(fatalsToBrowser);
michael@0: use CGI::Request;
michael@0: use URLTimingDataSet;
michael@0: use File::Copy ();
michael@0: use strict;
michael@0: 
michael@0: use vars qw($dbh $arc $dbroot); # current db, and db/archive
michael@0: 
michael@0: use constant STALE_AGE => 5 * 60; # seconds
michael@0: 
michael@0: # show a chart of this run; turned off in automated tests, and where
michael@0: # an installation hasn't set up the required modules and libraries
michael@0: use constant SHOW_CHART => 0;
michael@0: 
michael@0: sub createArchiveMetaTable {
michael@0:     my $table = "tMetaTable";
michael@0:     return if -e "$dbroot/archive/$table"; # don't create it if it exists
michael@0:     warn "createMetaTable:\t$dbroot/archive/$table";
michael@0:     mkdir "$dbroot/archive" unless -d "$dbroot/archive";
michael@0:     my ($sth, $sql);
michael@0:     $sql = qq{
michael@0: 	CREATE TABLE tMetaTable
michael@0: 	    (DATETIME CHAR(14),      LASTPING CHAR(14),
michael@0: 	     ID CHAR(8),             INDEX INTEGER,
michael@0: 	     CUR_IDX INTEGER,        CUR_CYC INTEGER,
michael@0: 	     CUR_CONTENT CHAR(128),  STATE INTEGER,
michael@0: 	     BLESSED INTEGER,        MAXCYC INTEGER,
michael@0: 	     MAXIDX INTEGER,         REPLACE INTEGER,
michael@0: 	     NOCACHE INTEGER,        DELAY INTEGER,
michael@0: 	     REMOTE_USER CHAR(16),   HTTP_USER_AGENT CHAR(128),
michael@0: 	     REMOTE_ADDR CHAR(15),   USER_EMAIL CHAR(32),
michael@0: 	     USER_COMMENT CHAR(256)
michael@0: 	     )
michael@0: 	    };
michael@0:     $sth = $arc->prepare($sql);
michael@0:     $sth->execute();
michael@0:     $sth->finish();
michael@0:     warn 'created archive meta table';
michael@0:     return 1;
michael@0: }
michael@0: 
michael@0: 
michael@0: sub purgeStaleEntries {
michael@0:     my $id = shift;
michael@0:     my $metatable = "tMetaTable";
michael@0: 
michael@0:     # first, remove dead stuff
michael@0:     my $sql = qq{SELECT * FROM $metatable 
michael@0:                    WHERE STATE = "INIT" OR STATE = "OPEN"};
michael@0:     my $sth = $dbh->prepare($sql);
michael@0:     $sth->execute();
michael@0:     my $now = time();
michael@0:     my $status;
michael@0:     while (my @data = $sth->fetchrow_array()) {
michael@0: 	my $age = $now - timestamp2Time($data[1]);
michael@0: 	# if OPEN or INIT, and not heard from in 10 minutes, then it's never coming
michael@0: 	# back here again. Delete the entry. Whine in the error_log.
michael@0: 	if ($age > STALE_AGE) {
michael@0: 	    warn "deleting stale record+table, id = $data[2], last = $data[1], @data";
michael@0: 	    $dbh->do( qq(DELETE FROM $metatable WHERE ID = "$data[2]") );
michael@0: 	    $dbh->do("DROP TABLE t" . $data[2]);
michael@0: 	}
michael@0: 	$status .= "$age @data\n";
michael@0:     }
michael@0:     $sth->finish();
michael@0: 
michael@0:     # now move any COMPLETE records to archive
michael@0:     $sql = qq{SELECT * FROM $metatable};
michael@0:     $sth = $dbh->prepare($sql);
michael@0:     $sth->execute();
michael@0:     $now = time();
michael@0:     while (my @data = $sth->fetchrow_array()) {
michael@0: 	my $age = $now - timestamp2Time($data[1]);
michael@0: 	# This keeps the "live" entries from growing too slow. 
michael@0: 	# If COMPLETE and older than 10 minutes, move to archive.
michael@0: 	if ($age > STALE_AGE) {
michael@0: 	    warn "moving COMPLETE record+table, id = $data[2], last = $data[1], @data";
michael@0: 	    moveRecordToArchive($data[2], \@data);
michael@0: 	    $dbh->do( qq(DELETE FROM $metatable WHERE ID = "$data[2]") );
michael@0: 	}
michael@0:     }
michael@0:     $sth->finish();
michael@0: 
michael@0: 
michael@0:     if (!SHOW_CHART) {
michael@0: 	# Don't move it if showing a chart. (Otherwise, if showing a 
michael@0: 	# a chart, I'd have to do a little extra work to make sure I 
michael@0: 	# didn't yank the record away from the IMG request)
michael@0: 	$sql = qq{SELECT * FROM $metatable WHERE ID = "$id"};
michael@0: 	$sth = $dbh->prepare($sql);
michael@0: 	$sth->execute();
michael@0: 	while (my @data = $sth->fetchrow_array()) {
michael@0: 	    warn "moving COMPLETE record+table, id = $id, @data\n";
michael@0: 	    moveRecordToArchive($data[2], \@data);
michael@0: 	    $dbh->do( qq(DELETE FROM $metatable WHERE ID = "$data[2]") );
michael@0: 	}
michael@0:     }
michael@0:     $sth->finish();
michael@0: }
michael@0: 
michael@0: 
michael@0: sub moveRecordToArchive {
michael@0:     my $id      = shift || die "no id";
michael@0:     my $dataref = shift || die "no dataref";
michael@0:     createArchiveMetaTable(); # if it doesn't exist
michael@0:     insertIntoMetaTable($dataref);
michael@0:     File::Copy::move("$dbroot/t$id", "$dbroot/archive/t$id");
michael@0: }
michael@0: 
michael@0: 
michael@0: sub insertIntoMetaTable {
michael@0:     my $dataref = shift || die "no dataref";
michael@0:     my $table = "tMetaTable";
michael@0:     my ($sth, $sql);
michael@0:     $sql = qq{
michael@0:         INSERT INTO $table
michael@0:              (DATETIME,         LASTPING,     ID,
michael@0:               INDEX,            CUR_IDX,      CUR_CYC,
michael@0:               CUR_CONTENT,      STATE,        BLESSED,
michael@0:               MAXCYC,           MAXIDX,       REPLACE,
michael@0:               NOCACHE,          DELAY,        REMOTE_USER,
michael@0:               HTTP_USER_AGENT,  REMOTE_ADDR,  USER_EMAIL,
michael@0:               USER_COMMENT
michael@0:               )
michael@0:           VALUES (?,?,?,?,
michael@0:                   ?,?,?,?,
michael@0:                   ?,?,?,?,
michael@0:                   ?,?,?,?,
michael@0:                   ?,?,?)
michael@0:         };
michael@0:     $sth = $arc->prepare($sql);
michael@0:     $sth->execute(@$dataref);
michael@0:     $sth->finish();
michael@0: }
michael@0: 
michael@0: 
michael@0: sub timestamp2Time ($) {
michael@0:     my $str = shift;
michael@0:     use Time::Local ();
michael@0:     my @datetime = reverse unpack 'A4A2A2A2A2A2', $str;
michael@0:     --$datetime[4]; # month: 0-11
michael@0:     return Time::Local::timelocal(@datetime);
michael@0: }
michael@0: 
michael@0: 
michael@0: sub serializeDataSet {
michael@0:     # package up this data for storage elsewhere
michael@0:     my $rs = shift;
michael@0:     my $data = "avgmedian|" . $rs->{avgmedian};
michael@0:     $data .=   "|average|"  . $rs->{average};
michael@0:     $data .=   "|minimum|"  . $rs->{minimum};
michael@0:     $data .=   "|maximum|"  . $rs->{maximum};
michael@0:     $_ = $rs->as_string;
michael@0:     s/^\s+//gs;
michael@0:     s/\s+\n$//gs;
michael@0:     s/\s*\n/\|/gs; # fold newlines
michael@0:     s/\|\s+/\|/gs; 
michael@0:     s/\s+/;/gs;
michael@0:     return $data . ":" . $_;
michael@0: }
michael@0: 
michael@0: #
michael@0: # handle the request
michael@0: #
michael@0: my $request = new CGI::Request;
michael@0: my $id = $request->param('id'); #XXX need to check for valid parameter id
michael@0: my $rs = URLTimingDataSet->new($id);
michael@0: 
michael@0: print "Content-type: text/html\n\n";
michael@0: 
michael@0: # This sucks: we'll let the test time out to avoid crash-on-shutdown bugs
michael@0: print "<html><body onload='window.close();'>";
michael@0: #
michael@0: # dump some stats for tinderbox to snarf
michael@0: #
michael@0: print "<script>\n";
michael@0: print "if (window.dump) dump('";
michael@0: print "Starting Page Load Test\\n\\\n";
michael@0: print "Test id: $id\\n\\\n";
michael@0: print "Avg. Median : ", $rs->{avgmedian}, " msec\\n\\\n";
michael@0: print "Average     : ", $rs->{average}, " msec\\n\\\n";
michael@0: print "Minimum     : ", $rs->{minimum}, " msec\\n\\\n";
michael@0: print "Maximum     : ", $rs->{maximum}, " msec\\n\\\n";
michael@0: print "IDX PATH                           AVG    MED    MAX    MIN  TIMES ...\\n\\\n";
michael@0: if ($request->param('sort')) {
michael@0:     $_ = $rs->as_string_sorted();
michael@0: } else {
michael@0:     $_ = $rs->as_string();
michael@0: }
michael@0: #
michael@0: # Terminate raw newlines with '\n\' so we don't have an unterminated string literal.
michael@0: #
michael@0: s/\n/\\n\\\n/g;
michael@0: print $_;
michael@0: print "(tinderbox dropping follows)\\n\\\n";
michael@0: print "_x_x_mozilla_page_load," , $rs->{avgmedian}, ",", $rs->{maximum}, ",", $rs->{minimum}, "\\n\\\n";
michael@0: #
michael@0: # package up this data for storage elsewhere
michael@0: #
michael@0: my $data = serializeDataSet($rs);
michael@0: print "_x_x_mozilla_page_load_details,", $data, "\\n\\\n";
michael@0: #
michael@0: # average median
michael@0: #
michael@0: #print "TinderboxPrint:<a title=\"Avg. of the median per url pageload time.\" href=\"http://tegu.mozilla.org/graph/query.cgi?tbox=spider&testname=pageload&autoscale=1&days=7&avg=1\">Tp:", $rs->{avgmedian}, "ms</a>", "\\n\\\n";
michael@0: print "');";
michael@0: print "</script></body></html>\n";
michael@0: 
michael@0: 
michael@0: #
michael@0: # If this is SurfingSafari, then catch a wave and you're sitting on top of the world!!
michael@0: # (and also blat this out to tegu, cause we got no 'dump' statement.
michael@0: #
michael@0: if ($request->cgi->var("HTTP_USER_AGENT") =~ /Safari/) {
michael@0:     my %machineMap = 
michael@0: 	(
michael@0: 	 "10.169.105.26" => "boxset",
michael@0: 	 "10.169.105.21" => "pawn"
michael@0: 	 );
michael@0:     my $ip = $request->cgi->var('REMOTE_ADDR');
michael@0:     my $machine = $machineMap{$ip};
michael@0:     my $res = eval q{
michael@0: 	use LWP::UserAgent;
michael@0: 	use HTTP::Request::Common qw(POST);
michael@0: 	my $ua = LWP::UserAgent->new;
michael@0: 	$ua->timeout(10); # seconds
michael@0: 	my $req = POST('http://tegu.mozilla.org/graph/collect.cgi',
michael@0: 		       [testname => 'pageload',
michael@0: 			tbox     => "$machine" . "-aux",
michael@0: 			value    => $rs->{avgmedian},
michael@0: 			data     => $data]);
michael@0: 	my $res = $ua->request($req);
michael@0: 	return $res;
michael@0:     };
michael@0:     if ($@) {
michael@0: 	warn "Failed to submit startup results: $@";
michael@0:     } else {
michael@0: 	warn "Startup results submitted to server: \n",
michael@0: 	$res->status_line, "\n", $res->content, "\n";
michael@0:     }
michael@0: }
michael@0: 
michael@0: 
michael@0: if ($request->param('purge')) {
michael@0:     # now move any old stuff into archive and clean stale entries
michael@0:     # just going with the simple approach of "whoever sees old entries
michael@0:     # first, cleans em up, whether they 'own' them or not". Hopefully,
michael@0:     # the default locking will be sufficient to prevent a race.
michael@0:     close(STDOUT);
michael@0:     sleep(1);
michael@0:     $dbroot = "db";
michael@0:     $dbh = DBI->connect("DBI:CSV:f_dir=./$dbroot", 
michael@0:                         {RaiseError => 1, AutoCommit => 1})
michael@0: 	|| die "Cannot connect: " . $DBI::errstr;
michael@0:     $arc = DBI->connect("DBI:CSV:f_dir=./$dbroot/archive", 
michael@0:                         {RaiseError => 1, AutoCommit => 1})
michael@0: 	|| die "Cannot connect: " . $DBI::errstr;
michael@0:     purgeStaleEntries($id);
michael@0:     $dbh->disconnect();
michael@0:     $arc->disconnect();
michael@0: }
michael@0: 
michael@0: exit 0;