1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/tools/page-loader/dump.pl Wed Dec 31 06:09:35 2014 +0100
1.3 @@ -0,0 +1,269 @@
1.4 +#!/usr/bin/perl
1.5 +#
1.6 +# This Source Code Form is subject to the terms of the Mozilla Public
1.7 +# License, v. 2.0. If a copy of the MPL was not distributed with this
1.8 +# file, You can obtain one at http://mozilla.org/MPL/2.0/.
1.9 +use DBI;
1.10 +use CGI::Carp qw(fatalsToBrowser);
1.11 +use CGI::Request;
1.12 +use URLTimingDataSet;
1.13 +use File::Copy ();
1.14 +use strict;
1.15 +
1.16 +use vars qw($dbh $arc $dbroot); # current db, and db/archive
1.17 +
1.18 +use constant STALE_AGE => 5 * 60; # seconds
1.19 +
1.20 +# show a chart of this run; turned off in automated tests, and where
1.21 +# an installation hasn't set up the required modules and libraries
1.22 +use constant SHOW_CHART => 0;
1.23 +
1.24 +sub createArchiveMetaTable {
1.25 + my $table = "tMetaTable";
1.26 + return if -e "$dbroot/archive/$table"; # don't create it if it exists
1.27 + warn "createMetaTable:\t$dbroot/archive/$table";
1.28 + mkdir "$dbroot/archive" unless -d "$dbroot/archive";
1.29 + my ($sth, $sql);
1.30 + $sql = qq{
1.31 + CREATE TABLE tMetaTable
1.32 + (DATETIME CHAR(14), LASTPING CHAR(14),
1.33 + ID CHAR(8), INDEX INTEGER,
1.34 + CUR_IDX INTEGER, CUR_CYC INTEGER,
1.35 + CUR_CONTENT CHAR(128), STATE INTEGER,
1.36 + BLESSED INTEGER, MAXCYC INTEGER,
1.37 + MAXIDX INTEGER, REPLACE INTEGER,
1.38 + NOCACHE INTEGER, DELAY INTEGER,
1.39 + REMOTE_USER CHAR(16), HTTP_USER_AGENT CHAR(128),
1.40 + REMOTE_ADDR CHAR(15), USER_EMAIL CHAR(32),
1.41 + USER_COMMENT CHAR(256)
1.42 + )
1.43 + };
1.44 + $sth = $arc->prepare($sql);
1.45 + $sth->execute();
1.46 + $sth->finish();
1.47 + warn 'created archive meta table';
1.48 + return 1;
1.49 +}
1.50 +
1.51 +
1.52 +sub purgeStaleEntries {
1.53 + my $id = shift;
1.54 + my $metatable = "tMetaTable";
1.55 +
1.56 + # first, remove dead stuff
1.57 + my $sql = qq{SELECT * FROM $metatable
1.58 + WHERE STATE = "INIT" OR STATE = "OPEN"};
1.59 + my $sth = $dbh->prepare($sql);
1.60 + $sth->execute();
1.61 + my $now = time();
1.62 + my $status;
1.63 + while (my @data = $sth->fetchrow_array()) {
1.64 + my $age = $now - timestamp2Time($data[1]);
1.65 + # if OPEN or INIT, and not heard from in 10 minutes, then it's never coming
1.66 + # back here again. Delete the entry. Whine in the error_log.
1.67 + if ($age > STALE_AGE) {
1.68 + warn "deleting stale record+table, id = $data[2], last = $data[1], @data";
1.69 + $dbh->do( qq(DELETE FROM $metatable WHERE ID = "$data[2]") );
1.70 + $dbh->do("DROP TABLE t" . $data[2]);
1.71 + }
1.72 + $status .= "$age @data\n";
1.73 + }
1.74 + $sth->finish();
1.75 +
1.76 + # now move any COMPLETE records to archive
1.77 + $sql = qq{SELECT * FROM $metatable};
1.78 + $sth = $dbh->prepare($sql);
1.79 + $sth->execute();
1.80 + $now = time();
1.81 + while (my @data = $sth->fetchrow_array()) {
1.82 + my $age = $now - timestamp2Time($data[1]);
1.83 + # This keeps the "live" entries from growing too slow.
1.84 + # If COMPLETE and older than 10 minutes, move to archive.
1.85 + if ($age > STALE_AGE) {
1.86 + warn "moving COMPLETE record+table, id = $data[2], last = $data[1], @data";
1.87 + moveRecordToArchive($data[2], \@data);
1.88 + $dbh->do( qq(DELETE FROM $metatable WHERE ID = "$data[2]") );
1.89 + }
1.90 + }
1.91 + $sth->finish();
1.92 +
1.93 +
1.94 + if (!SHOW_CHART) {
1.95 + # Don't move it if showing a chart. (Otherwise, if showing a
1.96 + # a chart, I'd have to do a little extra work to make sure I
1.97 + # didn't yank the record away from the IMG request)
1.98 + $sql = qq{SELECT * FROM $metatable WHERE ID = "$id"};
1.99 + $sth = $dbh->prepare($sql);
1.100 + $sth->execute();
1.101 + while (my @data = $sth->fetchrow_array()) {
1.102 + warn "moving COMPLETE record+table, id = $id, @data\n";
1.103 + moveRecordToArchive($data[2], \@data);
1.104 + $dbh->do( qq(DELETE FROM $metatable WHERE ID = "$data[2]") );
1.105 + }
1.106 + }
1.107 + $sth->finish();
1.108 +}
1.109 +
1.110 +
1.111 +sub moveRecordToArchive {
1.112 + my $id = shift || die "no id";
1.113 + my $dataref = shift || die "no dataref";
1.114 + createArchiveMetaTable(); # if it doesn't exist
1.115 + insertIntoMetaTable($dataref);
1.116 + File::Copy::move("$dbroot/t$id", "$dbroot/archive/t$id");
1.117 +}
1.118 +
1.119 +
1.120 +sub insertIntoMetaTable {
1.121 + my $dataref = shift || die "no dataref";
1.122 + my $table = "tMetaTable";
1.123 + my ($sth, $sql);
1.124 + $sql = qq{
1.125 + INSERT INTO $table
1.126 + (DATETIME, LASTPING, ID,
1.127 + INDEX, CUR_IDX, CUR_CYC,
1.128 + CUR_CONTENT, STATE, BLESSED,
1.129 + MAXCYC, MAXIDX, REPLACE,
1.130 + NOCACHE, DELAY, REMOTE_USER,
1.131 + HTTP_USER_AGENT, REMOTE_ADDR, USER_EMAIL,
1.132 + USER_COMMENT
1.133 + )
1.134 + VALUES (?,?,?,?,
1.135 + ?,?,?,?,
1.136 + ?,?,?,?,
1.137 + ?,?,?,?,
1.138 + ?,?,?)
1.139 + };
1.140 + $sth = $arc->prepare($sql);
1.141 + $sth->execute(@$dataref);
1.142 + $sth->finish();
1.143 +}
1.144 +
1.145 +
1.146 +sub timestamp2Time ($) {
1.147 + my $str = shift;
1.148 + use Time::Local ();
1.149 + my @datetime = reverse unpack 'A4A2A2A2A2A2', $str;
1.150 + --$datetime[4]; # month: 0-11
1.151 + return Time::Local::timelocal(@datetime);
1.152 +}
1.153 +
1.154 +
1.155 +sub serializeDataSet {
1.156 + # package up this data for storage elsewhere
1.157 + my $rs = shift;
1.158 + my $data = "avgmedian|" . $rs->{avgmedian};
1.159 + $data .= "|average|" . $rs->{average};
1.160 + $data .= "|minimum|" . $rs->{minimum};
1.161 + $data .= "|maximum|" . $rs->{maximum};
1.162 + $_ = $rs->as_string;
1.163 + s/^\s+//gs;
1.164 + s/\s+\n$//gs;
1.165 + s/\s*\n/\|/gs; # fold newlines
1.166 + s/\|\s+/\|/gs;
1.167 + s/\s+/;/gs;
1.168 + return $data . ":" . $_;
1.169 +}
1.170 +
1.171 +#
1.172 +# handle the request
1.173 +#
1.174 +my $request = new CGI::Request;
1.175 +my $id = $request->param('id'); #XXX need to check for valid parameter id
1.176 +my $rs = URLTimingDataSet->new($id);
1.177 +
1.178 +print "Content-type: text/html\n\n";
1.179 +
1.180 +# This sucks: we'll let the test time out to avoid crash-on-shutdown bugs
1.181 +print "<html><body onload='window.close();'>";
1.182 +#
1.183 +# dump some stats for tinderbox to snarf
1.184 +#
1.185 +print "<script>\n";
1.186 +print "if (window.dump) dump('";
1.187 +print "Starting Page Load Test\\n\\\n";
1.188 +print "Test id: $id\\n\\\n";
1.189 +print "Avg. Median : ", $rs->{avgmedian}, " msec\\n\\\n";
1.190 +print "Average : ", $rs->{average}, " msec\\n\\\n";
1.191 +print "Minimum : ", $rs->{minimum}, " msec\\n\\\n";
1.192 +print "Maximum : ", $rs->{maximum}, " msec\\n\\\n";
1.193 +print "IDX PATH AVG MED MAX MIN TIMES ...\\n\\\n";
1.194 +if ($request->param('sort')) {
1.195 + $_ = $rs->as_string_sorted();
1.196 +} else {
1.197 + $_ = $rs->as_string();
1.198 +}
1.199 +#
1.200 +# Terminate raw newlines with '\n\' so we don't have an unterminated string literal.
1.201 +#
1.202 +s/\n/\\n\\\n/g;
1.203 +print $_;
1.204 +print "(tinderbox dropping follows)\\n\\\n";
1.205 +print "_x_x_mozilla_page_load," , $rs->{avgmedian}, ",", $rs->{maximum}, ",", $rs->{minimum}, "\\n\\\n";
1.206 +#
1.207 +# package up this data for storage elsewhere
1.208 +#
1.209 +my $data = serializeDataSet($rs);
1.210 +print "_x_x_mozilla_page_load_details,", $data, "\\n\\\n";
1.211 +#
1.212 +# average median
1.213 +#
1.214 +#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";
1.215 +print "');";
1.216 +print "</script></body></html>\n";
1.217 +
1.218 +
1.219 +#
1.220 +# If this is SurfingSafari, then catch a wave and you're sitting on top of the world!!
1.221 +# (and also blat this out to tegu, cause we got no 'dump' statement.
1.222 +#
1.223 +if ($request->cgi->var("HTTP_USER_AGENT") =~ /Safari/) {
1.224 + my %machineMap =
1.225 + (
1.226 + "10.169.105.26" => "boxset",
1.227 + "10.169.105.21" => "pawn"
1.228 + );
1.229 + my $ip = $request->cgi->var('REMOTE_ADDR');
1.230 + my $machine = $machineMap{$ip};
1.231 + my $res = eval q{
1.232 + use LWP::UserAgent;
1.233 + use HTTP::Request::Common qw(POST);
1.234 + my $ua = LWP::UserAgent->new;
1.235 + $ua->timeout(10); # seconds
1.236 + my $req = POST('http://tegu.mozilla.org/graph/collect.cgi',
1.237 + [testname => 'pageload',
1.238 + tbox => "$machine" . "-aux",
1.239 + value => $rs->{avgmedian},
1.240 + data => $data]);
1.241 + my $res = $ua->request($req);
1.242 + return $res;
1.243 + };
1.244 + if ($@) {
1.245 + warn "Failed to submit startup results: $@";
1.246 + } else {
1.247 + warn "Startup results submitted to server: \n",
1.248 + $res->status_line, "\n", $res->content, "\n";
1.249 + }
1.250 +}
1.251 +
1.252 +
1.253 +if ($request->param('purge')) {
1.254 + # now move any old stuff into archive and clean stale entries
1.255 + # just going with the simple approach of "whoever sees old entries
1.256 + # first, cleans em up, whether they 'own' them or not". Hopefully,
1.257 + # the default locking will be sufficient to prevent a race.
1.258 + close(STDOUT);
1.259 + sleep(1);
1.260 + $dbroot = "db";
1.261 + $dbh = DBI->connect("DBI:CSV:f_dir=./$dbroot",
1.262 + {RaiseError => 1, AutoCommit => 1})
1.263 + || die "Cannot connect: " . $DBI::errstr;
1.264 + $arc = DBI->connect("DBI:CSV:f_dir=./$dbroot/archive",
1.265 + {RaiseError => 1, AutoCommit => 1})
1.266 + || die "Cannot connect: " . $DBI::errstr;
1.267 + purgeStaleEntries($id);
1.268 + $dbh->disconnect();
1.269 + $arc->disconnect();
1.270 +}
1.271 +
1.272 +exit 0;
