From: Andrew Dunstan Date: Sat, 18 Dec 2010 22:11:45 +0000 (+0000) Subject: undo reorganization X-Git-Url: https://git.exim.org/buildfarm-server.git/commitdiff_plain/a59c49981887fdcc58a1c3b00ebfb1e9f80b9699 undo reorganization --- diff --git a/cgi-bin/addnotes.pl b/cgi-bin/addnotes.pl new file mode 100755 index 0000000..acab114 --- /dev/null +++ b/cgi-bin/addnotes.pl @@ -0,0 +1,116 @@ +#!/usr/bin/perl + +use strict; + +use CGI; +use Digest::SHA1 qw(sha1_hex); +use MIME::Base64; +use DBI; +use DBD::Pg; +use Data::Dumper; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport); + +my $query = new CGI; + +my $sig = $query->path_info; +$sig =~ s!^/!!; + +my $animal = $query->param('animal'); +my $sysnotes = $query->param('sysnotes'); + +my $content = "animal=$animal\&sysnotes=$sysnotes"; + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + +die "no dbname" unless $dbname; +die "no dbuser" unless $dbuser; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +unless ($animal && defined($sysnotes) && $sig) +{ + print + "Status: 490 bad parameters\nContent-Type: text/plain\n\n", + "bad parameters for request\n"; + exit; + +} + + +my $db = DBI->connect($dsn,$dbuser,$dbpass); + +die $DBI::errstr unless $db; + +my $gethost= + "select secret from buildsystems where name = ? and status = 'approved'"; +my $sth = $db->prepare($gethost); +$sth->execute($animal); +my ($secret)=$sth->fetchrow_array(); +$sth->finish; + + +unless ($secret) +{ + print + "Status: 495 Unknown System\nContent-Type: text/plain\n\n", + "System $animal is unknown\n"; + $db->disconnect; + exit; + +} + + + + +my $calc_sig = sha1_hex($content,$secret); + +if ($calc_sig ne $sig) +{ + + print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n"; + print "$sig mismatches $calc_sig on content:\n$content"; + $db->disconnect; + exit; +} + +# undo escape-proofing of base64 data and decode it +map {tr/$@/+=/; $_ = decode_base64($_); } + ($sysnotes); + +my $set_notes = q{ + + update buildsystems + set sys_notes = nullif($2,''), + sys_notes_ts = case + when coalesce($2,'') <> '' then now() + else null + end + where name = $1 + and status = 'approved' + +}; + +$sth = $db->prepare($set_notes); +my $rv = $sth->execute($animal,$sysnotes); +unless($rv) +{ + print "Status: 460 old data fetch\nContent-Type: text/plain\n\n"; + print "error: ",$db->errstr,"\n"; + $db->disconnect; + exit; +} + +$sth->finish; + + + +$db->disconnect; + +print "Content-Type: text/plain\n\n"; +print "request was on:\n$content\n"; + + + diff --git a/cgi-bin/envtest.pl b/cgi-bin/envtest.pl new file mode 100644 index 0000000..f86621f --- /dev/null +++ b/cgi-bin/envtest.pl @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +print "Content-Type: text/plain\n\n"; + +print "Conf: $ENV{BFConfDir}\n"; + +print `pwd`; + +print `id`; + +foreach my $key (sort keys %ENV) +{ + my $val = $ENV{$key}; + print "$key=$val\n"; +} diff --git a/cgi-bin/get_bf_status_soap.pl b/cgi-bin/get_bf_status_soap.pl new file mode 100755 index 0000000..02059e7 --- /dev/null +++ b/cgi-bin/get_bf_status_soap.pl @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +use lib "/home/community/pgbuildfarm/lib/lib/perl5/site_perl"; + +use SOAP::Lite +trace; + +my $obj = SOAP::Lite + ->uri('http://www.pgbuildfarm.org/PGBuildFarm') + ->proxy('http://127.0.0.1/cgi-bin/show_status_soap.pl') + ->request->header("Host" => "www.pgbuildfarm.org") + ; + +my $data = $obj->get_status->result; +my @fields = qw( branch sysname stage status + operating_system os_version + compiler compiler_version architecture + when_ago snapshot build_flags + ); + +print "Content-Type: text/plain\n\n"; + +my $head = join (' | ', @fields); +print $head,"\n"; + +foreach my $datum (@$data) +{ + my $line = join (' | ', @{$datum}{@fields}); + print $line,"\n"; +} + diff --git a/cgi-bin/pgstatus.pl b/cgi-bin/pgstatus.pl new file mode 100755 index 0000000..c9b0268 --- /dev/null +++ b/cgi-bin/pgstatus.pl @@ -0,0 +1,542 @@ +#!/usr/bin/perl + +use strict; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport + $all_stat $fail_stat $change_stat $green_stat + $server_time + $min_script_version $min_web_script_version + $default_host +); + +# force this before we do anything - even load modules +BEGIN { $server_time = time; } + +use CGI; +use Digest::SHA1 qw(sha1_hex); +use MIME::Base64; +use DBI; +use DBD::Pg; +use Data::Dumper; +use Mail::Send; +use Time::ParseDate; +use Storable qw(thaw); + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; +my $buildlogs = "$ENV{BFConfDir}/buildlogs"; + +die "no dbname" unless $dbname; +die "no dbuser" unless $dbuser; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +my $query = new CGI; + +my $sig = $query->path_info; +$sig =~ s!^/!!; + +my $stage = $query->param('stage'); +my $ts = $query->param('ts'); +my $animal = $query->param('animal'); +my $log = $query->param('log'); +my $res = $query->param('res'); +my $conf = $query->param('conf'); +my $branch = $query->param('branch'); +my $changed_since_success = $query->param('changed_since_success'); +my $changed_this_run = $query->param('changed_files'); +my $log_archive = $query->param('logtar'); +my $frozen_sconf = $query->param('frozen_sconf') || ''; + +my $content = + "branch=$branch&res=$res&stage=$stage&animal=$animal&". + "ts=$ts&log=$log&conf=$conf"; + +my $extra_content = + "changed_files=$changed_this_run&". + "changed_since_success=$changed_since_success&"; + +unless ($animal && $ts && $stage && $sig) +{ + print + "Status: 490 bad parameters\nContent-Type: text/plain\n\n", + "bad parameters for request\n"; + exit; + +} + +unless ($branch =~ /^(HEAD|REL\d+_\d+_STABLE)$/) +{ + print + "Status: 492 bad branch parameter $branch\nContent-Type: text/plain\n\n", + "bad branch parameter $branch\n"; + exit; + +} + + +my $db = DBI->connect($dsn,$dbuser,$dbpass); + +die $DBI::errstr unless $db; + +my $gethost= + "select secret from buildsystems where name = ? and status = 'approved'"; +my $sth = $db->prepare($gethost); +$sth->execute($animal); +my ($secret)=$sth->fetchrow_array(); +$sth->finish; + +my $tsdiff = time - $ts; + +my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($ts); +$year += 1900; $mon +=1; +my $date= + sprintf("%d-%.2d-%.2d_%.2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec); + +if ($ENV{BF_DEBUG} || ($ts > time) || ($ts + 86400 < time ) || (! $secret) ) +{ + open(TX,">$buildlogs/$animal.$date"); + print TX "sig=$sig\nlogtar-len=" , length($log_archive), + "\nstatus=$res\nstage=$stage\nconf:\n$conf\n", + "tsdiff:$tsdiff\n", + "changed_this_run:\n$changed_this_run\n", + "changed_since_success:\n$changed_since_success\n", + "frozen_sconf:$frozen_sconf\n", + "log:\n",$log; +# $query->save(\*TX); + close(TX); +} + +unless ($ts < time + 120) +{ + my $gmt = gmtime($ts); + print "Status: 491 bad ts parameter - $ts ($gmt GMT) is in the future.\n", + "Content-Type: text/plain\n\n bad ts parameter - $ts ($gmt GMT) is in the future\n"; + $db->disconnect; + exit; +} + +unless ($ts + 86400 > time) +{ + my $gmt = gmtime($ts); + print "Status: 491 bad ts parameter - $ts ($gmt GMT) is more than 24 hours ago.\n", + "Content-Type: text/plain\n\n bad ts parameter - $ts ($gmt GMT) is more than 24 hours ago.\n"; + $db->disconnect; + exit; +} + +unless ($secret) +{ + print + "Status: 495 Unknown System\nContent-Type: text/plain\n\n", + "System $animal is unknown\n"; + $db->disconnect; + exit; + +} + + + + +my $calc_sig = sha1_hex($content,$secret); +my $calc_sig2 = sha1_hex($extra_content,$content,$secret); + +if ($calc_sig ne $sig && $calc_sig2 ne $sig) +{ + + print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n"; + print "$sig mismatches $calc_sig($calc_sig2) on content:\n$content"; + $db->disconnect; + exit; +} + +# undo escape-proofing of base64 data and decode it +map {tr/$@/+=/; $_ = decode_base64($_); } + ($log, $conf,$changed_this_run,$changed_since_success,$log_archive, $frozen_sconf); + +if ($log =~/Last file mtime in snapshot: (.*)/) +{ + my $snaptime = parsedate($1); + if ($snaptime < (time - (10 * 86400))) + { + print "Status: 493 snapshot too old: $1\nContent-Type: text/plain\n\n"; + print "snapshot to old: $1\n"; + $db->disconnect; + exit; + } +} + +($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($ts); +$year += 1900; $mon +=1; +my $dbdate= + sprintf("%d-%.2d-%.2d %.2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec); + +my $log_file_names; +my @log_file_names; +my $dirname = "$buildlogs/tmp.$$.unpacklogs"; + +my $githeadref; + +if ($log_archive) +{ + my $log_handle; + my $archname = "$buildlogs/tmp.$$.tgz"; + open($log_handle,">$archname"); + binmode $log_handle; + print $log_handle $log_archive; + close $log_handle; + mkdir $dirname; + @log_file_names = `tar -z -C $dirname -xvf $archname 2>/dev/null`; + map {s/\s+//g; } @log_file_names; + my @qnames = grep { $_ ne 'githead.log' } @log_file_names; + map { $_ = qq("$_"); } @qnames; + $log_file_names = '{' . join(',',@qnames) . '}'; + if (-e "$dirname/githead.log" ) + { + open(my $githead,"$dirname/githead.log"); + $githeadref = <$githead>; + chomp $githeadref; + close $githead; + } + # unlink $archname; +} + +my $config_flags; +my $client_conf; +if ($frozen_sconf) +{ + $client_conf = thaw $frozen_sconf; +} + +if ($min_script_version) +{ + $client_conf->{script_version} ||= '0.0'; + my $cli_ver = $client_conf->{script_version} ; + $cli_ver =~ s/^REL_//; + my ($minmajor,$minminor) = split(/\./,$min_script_version); + my ($smajor,$sminor) = split(/\./,$cli_ver); + if ($minmajor > $smajor || ($minmajor == $smajor && $minminor > $sminor)) + { + print "Status: 460 script version too low\nContent-Type: text/plain\n\n"; + print + "Script version is below minimum required\n", + "Reported version: $client_conf->{script_version},", + "Minumum version required: $min_script_version\n"; + $db->disconnect; + exit; + } +} + +if ($min_web_script_version) +{ + $client_conf->{web_script_version} ||= '0.0'; + my $cli_ver = $client_conf->{web_script_version} ; + $cli_ver =~ s/^REL_//; + my ($minmajor,$minminor) = split(/\./,$min_web_script_version); + my ($smajor,$sminor) = split(/\./,$cli_ver); + if ($minmajor > $smajor || ($minmajor == $smajor && $minminor > $sminor)) + { + print "Status: 461 web script version too low\nContent-Type: text/plain\n\n"; + print + "Web Script version is below minimum required\n", + "Reported version: $client_conf->{web_script_version}, ", + "Minumum version required: $min_web_script_version\n" + ; + $db->disconnect; + exit; + } +} + +my @config_flags; +if (not exists $client_conf->{config_opts} ) +{ + @config_flags = (); +} +elsif (ref $client_conf->{config_opts} eq 'HASH') +{ + # leave out keys with false values + @config_flags = grep { $client_conf->{config_opts}->{$_} } + keys %{$client_conf->{config_opts}}; +} +elsif (ref $client_conf->{config_opts} eq 'ARRAY' ) +{ + @config_flags = @{$client_conf->{config_opts}}; +} + +if (@config_flags) +{ + @config_flags = grep {! m/=/ } @config_flags; + map {s/\s+//g; $_=qq("$_"); } @config_flags; + push @config_flags,'git' if $client_conf->{scm} eq 'git'; + $config_flags = '{' . join(',',@config_flags) . '}' ; +} + +my $scm = $client_conf->{scm} || 'cvs'; +my $scmurl = $client_conf->{scm_url}; + +my $logst = <begin_work; +$db->do("select set_local_error_terse()"); + + +$sth=$db->prepare($logst); + +$sth->bind_param(1,$animal); +$sth->bind_param(2,$dbdate); +$sth->bind_param(3,$res); +$sth->bind_param(4,$stage); +$sth->bind_param(5,$log); +$sth->bind_param(6,$conf); +$sth->bind_param(7,$branch); +$sth->bind_param(8,$changed_this_run); +$sth->bind_param(9,$changed_since_success); +$sth->bind_param(10,$log_file_names); +#$sth->bind_param(11,$log_archive,{ pg_type => DBD::Pg::PG_BYTEA }); +$sth->bind_param(11,undef,{ pg_type => DBD::Pg::PG_BYTEA }); +$sth->bind_param(12,$config_flags); +$sth->bind_param(13,$scm); +$sth->bind_param(14,$scmurl); +$sth->bind_param(15,$githeadref); +$sth->bind_param(16,$frozen_sconf,{ pg_type => DBD::Pg::PG_BYTEA }); + +$sth->execute; +$sth->finish; + + + +my $logst2 = <prepare($logst2); + +$/=undef; + +my $stage_start = $ts; + +foreach my $log_file( @log_file_names ) +{ + next if $log_file =~ /^githead/; + my $handle; + open($handle,"$dirname/$log_file"); + my $mtime = (stat $handle)[9]; + my $stage_interval = $mtime - $stage_start; + $stage_start = $mtime; + my $ltext = <$handle>; + close($handle); + $ltext =~ s/\x00/\\0/g; + $sth->execute($animal,$dbdate,$branch,$log_file,$ltext, + "$stage_interval seconds"); +} + +$sth->finish; + +$db->commit; + +my $prevst = <prepare($prevst); +$sth->execute($animal,$branch,$dbdate); +my $row=$sth->fetchrow_arrayref; +my $prev_stat=$row->[0]; +$sth->finish; + +my $det_st = <prepare($det_st); +$sth->execute($animal); +$row=$sth->fetchrow_arrayref; +my ($os, $compiler,$arch) = @$row; +$sth->finish; + +$db->begin_work; +# prevent occasional duplication by forcing serialization of this operation +$db->do("lock table dashboard_mat in share row exclusive mode"); +$db->do("delete from dashboard_mat"); +$db->do("insert into dashboard_mat select * from dashboard_mat_data"); +$db->commit; + +$db->disconnect; + +print "Content-Type: text/plain\n\n"; +print "request was on:\n"; +print "res=$res&stage=$stage&animal=$animal&ts=$ts"; + +my $client_events = $client_conf->{mail_events}; + +if ($ENV{BF_DEBUG}) +{ + my $client_time = $client_conf->{current_ts}; + open(TX,">>$buildlogs/$animal.$date"); + print TX "\n",Dumper(\$client_conf),"\n"; + print TX "server time: $server_time, client time: $client_time\n" if $client_time; + close(TX); +} + +my $bcc_stat = []; +my $bcc_chg=[]; +if (ref $client_events) +{ + my $cbcc = $client_events->{all}; + if (ref $cbcc) + { + push @$bcc_stat, @$cbcc; + } + elsif (defined $cbcc) + { + push @$bcc_stat, $cbcc; + } + if ($stage ne 'OK') + { + $cbcc = $client_events->{all}; + if (ref $cbcc) + { + push @$bcc_stat, @$cbcc; + } + elsif (defined $cbcc) + { + push @$bcc_stat, $cbcc; + } + } + $cbcc = $client_events->{change}; + if (ref $cbcc) + { + push @$bcc_chg, @$cbcc; + } + elsif (defined $cbcc) + { + push @$bcc_chg, $cbcc; + } + if ($stage eq 'OK' || $prev_stat eq 'OK') + { + $cbcc = $client_events->{green}; + if (ref $cbcc) + { + push @$bcc_chg, @$cbcc; + } + elsif (defined $cbcc) + { + push @$bcc_chg, $cbcc; + } + } +} + + +my $url = $query->url(-base => 1); + + +my $stat_type = $stage eq 'OK' ? 'Status' : 'Failed at Stage'; + +my $mailto = [@$all_stat]; +push(@$mailto,@$fail_stat) if $stage ne 'OK'; + +my $me = `id -un`; chomp($me); + +my $host = `hostname`; chomp ($host); +$host = $default_host unless ($host =~ m/[.]/ || !defined($default_host)); + +my $from_addr = "PG Build Farm <$me\@$host>"; +$from_addr =~ tr /\r\n//d; + +my $msg = new Mail::Send; + + +$msg->to(@$mailto); +$msg->bcc(@$bcc_stat) if (@$bcc_stat); +$msg->subject("PGBuildfarm member $animal Branch $branch $stat_type $stage"); +$msg->set('From',$from_addr); +my $fh = $msg->open; +print $fh <close; + +exit if ($stage eq $prev_stat); + +$mailto = [@$change_stat]; +push(@$mailto,@$green_stat) if ($stage eq 'OK' || $prev_stat eq 'OK'); + +$msg = new Mail::Send; + + +$msg->to(@$mailto); +$msg->bcc(@$bcc_chg) if (@$bcc_chg); + +$stat_type = $prev_stat ne 'OK' ? "changed from $prev_stat failure to $stage" : + "changed from OK to $stage"; +$stat_type = "New member: $stage" if $prev_stat eq 'NEW'; +$stat_type .= " failure" if $stage ne 'OK'; + +$msg->subject("PGBuildfarm member $animal Branch $branch Status $stat_type"); +$msg->set('From',$from_addr); +$fh = $msg->open; +print $fh <close; diff --git a/cgi-bin/register-form.pl b/cgi-bin/register-form.pl new file mode 100755 index 0000000..cf4621a --- /dev/null +++ b/cgi-bin/register-form.pl @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +use Template; +use Captcha::reCAPTCHA; + +use vars qw( $template_dir $captcha_pubkey ); +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + + +my $c = Captcha::reCAPTCHA->new; + +my $captcha = $c->get_html($captcha_pubkey); + +my $template_opts = { INCLUDE_PATH => $template_dir }; +my $template = new Template($template_opts); + +print "Content-Type: text/html\n\n"; + + +$template->process('register-form.tt',{captcha => $captcha}); + + + + + diff --git a/cgi-bin/register.pl b/cgi-bin/register.pl new file mode 100755 index 0000000..37290f8 --- /dev/null +++ b/cgi-bin/register.pl @@ -0,0 +1,149 @@ +#!/usr/bin/perl + +use strict; +use DBI; +use Template; +use CGI; +use Template; +use Captcha::reCAPTCHA; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport $notifyapp $captcha_pubkey $captcha_privkey $template_dir $default_host); + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +my $template_opts = { INCLUDE_PATH => $template_dir}; +my $template = new Template($template_opts); +my $query = new CGI; + +my $params = $query->Vars; + +my ($os, $osv, $comp, $compv, $arch, $email, $owner, $challenge, $response ) = @{$params}{ + qw(os osv comp compv arch email owner recaptcha_challenge_field recaptcha_response_field)}; + +my $captcha = Captcha::reCAPTCHA->new; +my $captcha_ok = $captcha->check_answer + ( + $captcha_privkey, + $ENV{'REMOTE_ADDR'}, + $challenge, $response + ); + + +unless ($os && $osv && $comp && $compv && $arch && $email && $owner && $captcha_ok->{is_valid}) +{ + print "Content-Type: text/html\n\n"; + $template->process('register-incomplete.tt'); + exit; +} + +# some idiot has a script that tries to talk to me +# this should catch and dispose of him +if ((grep {/rgergerger|\@pgbuildfarm\.org|Content-Type:|http:|mailto:|href=|None|Unknown/} $os,$osv,$comp,$compv,$arch,$email,$owner) + || ($email =~ /john.*\@aol.com/) ) +{ + print + "Status: 403 Forbidden - go away idiot\n", + "Content-Type: text/plain\n\n"; + exit; +} + +# count transitions to and from upper case +my $trans = 1; +my $counttrans = 0; +foreach (split "" ,"$os$osv$comp$compv$arch$owner") +{ + if (/[A-Z]/) + { + next if $trans; + $trans = 1; + $counttrans++; + } + else + { + next unless $trans; + $trans = 0; + $counttrans++; + } +} + +# reject junk with too many transitions into/outof upper case +if ($counttrans > 20) +{ + print + "Status: 403 Forbidden - go away idiot\n", + "Content-Type: text/plain\n\n"; + exit; +} + + + +my $secret = ""; +my $dummyname=""; # we'll select an animal name when we approve it. +foreach (1..8) +{ + # 8 random chars is enough for the dummy name + $secret .= substr("0123456789abcdefghijklmnopqrstuvwxyz",int(rand(36)),1); + $dummyname .= substr("0123456789abcdef",int(rand(16)),1); +} +foreach (9..32) +{ + $secret .= substr("0123456789abcdef",int(rand(16)),1); +} + +my $db = DBI->connect($dsn,$dbuser,$dbpass); + +my $statement = <prepare($statement); +my $rv=$sth->execute($dummyname,$secret,$os,$osv,$comp,$compv, + $arch,$owner,$email); +my $err=$db->errstr; + +# everything looks OK, so tell them so +print "Content-type: text/html\n\n"; +$template->process('register-ok.tt'); + +$sth->finish; +$db->disconnect; + + +use Mail::Send; + +my $msg = new Mail::Send; + +my $me = `id -un`; chomp($me); +my $host = `hostname`; chomp ($host); +$host = $default_host unless ($host =~ m/[.]/ || !defined($default_host)); + +my $from_addr = "PG Build Farm <$me\@$host>"; +$from_addr =~ tr /\r\n//d; + +$msg->set('From',$from_addr); + +$msg->to(@$notifyapp); +$msg->subject('New Buildfarm Application'); +my $fh = $msg->open; +print $fh "\n\nName: $dummyname\n", + "OS: $os: $osv\n", + "Arch: $arch\n", + "Comp: $comp: $compv\n", + "Owner: $owner <$email>\n"; +$fh->close; + + + + + + diff --git a/cgi-bin/show_history.pl b/cgi-bin/show_history.pl new file mode 100755 index 0000000..b55c381 --- /dev/null +++ b/cgi-bin/show_history.pl @@ -0,0 +1,91 @@ +#!/usr/bin/perl + +use strict; +use DBI; +use Template; +use CGI; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir); + + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; +#require "BuildFarmWeb.pl"; + +die "no dbname" unless $dbname; +die "no dbuser" unless $dbuser; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +my $db = DBI->connect($dsn,$dbuser,$dbpass); + +die $DBI::errstr unless $db; + +my $query = new CGI; +my $member = $query->param('nm'); $member =~ s/[^a-zA-Z0-9_ -]//g; +my $branch = $query->param('br'); $branch =~ s/[^a-zA-Z0-9_ -]//g; +my $hm = $query->param('hm'); $hm =~ s/[^a-zA-Z0-9_ -]//g; +$hm = '240' unless $hm =~ /^\d+$/; + +my $latest_personality = $db->selectrow_arrayref(q{ + select os_version, compiler_version + from personality + where name = ? + order by effective_date desc limit 1 + }, undef, $member); + +# we don't really need to do this join, since we only want +# one row from buildsystems. but it means we only have to run one +# query. If it gets heavy we'll split it up and run two + +my $statement = <prepare($statement); +$sth->execute($member,$branch); +while (my $row = $sth->fetchrow_hashref) +{ + $row->{owner_email} =~ s/\@/ [ a t ] /; + if ($latest_personality) + { + $row->{os_version} = $latest_personality->[0]; + $row->{compiler_version} = $latest_personality->[1]; + } + push(@$statrows,$row); +} + +$sth->finish; + +$db->disconnect; + +my $template_opts = { INCLUDE_PATH => $template_dir, EVAL_PERL => 1 }; +my $template = new Template($template_opts); + +print "Content-Type: text/html\n\n"; + +$template->process('history.tt', + {statrows=>$statrows, + branch=>$branch, + member => $member, + hm => $hm + }); + +exit; diff --git a/cgi-bin/show_log.pl b/cgi-bin/show_log.pl new file mode 100755 index 0000000..21c6ec5 --- /dev/null +++ b/cgi-bin/show_log.pl @@ -0,0 +1,134 @@ +#!/usr/bin/perl + +use strict; +use DBI; +use Template; +use CGI; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir @log_file_names); + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + +my $template_opts = { INCLUDE_PATH => $template_dir, EVAL_PERL => 1}; +my $template = new Template($template_opts); + +die "no dbname" unless $dbname; +die "no dbuser" unless $dbuser; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +my $query = new CGI; + +my $system = $query->param('nm'); $system =~ s/[^a-zA-Z0-9_ -]//g; +my $logdate = $query->param('dt'); $logdate =~ s/[^a-zA-Z0-9_ :-]//g; + +my $log = ""; +my $conf = ""; +my ($stage,$changed_this_run,$changed_since_success,$sysinfo,$branch,$scmurl); +my $scm; + +use vars qw($info_row); + +if ($system && $logdate) +{ + + my $db = DBI->connect($dsn,$dbuser,$dbpass,{pg_expand_array => 0}); + + die $DBI::errstr unless $db; + + my $statement = q{ + + select log,conf_sum,stage, changed_this_run, changed_since_success,branch, + log_archive_filenames, scm, scmurl + from build_status + where sysname = ? and snapshot = ? + + }; + my $sth=$db->prepare($statement); + $sth->execute($system,$logdate); + my $row=$sth->fetchrow_arrayref; + $log=$row->[0]; + $conf=$row->[1] || "not recorded" ; + $stage=$row->[2] || "unknown"; + $changed_this_run = $row->[3]; + $changed_since_success = $row->[4]; + $branch = $row->[5]; + my $log_file_names = $row->[6]; + $scm = $row->[7]; + $scm ||= 'cvs'; # legacy scripts + $scmurl = $row->[8]; + $log_file_names =~ s/^\{(.*)\}$/$1/; + @log_file_names=split(',',$log_file_names) + if $log_file_names; + $sth->finish; + + $statement = q{ + + select operating_system, os_version, + compiler, compiler_version, + architecture, + replace(owner_email,'\@',' [ a t ] ') as owner_email, + sys_notes_ts::date AS sys_notes_date, sys_notes + from buildsystems + where status = 'approved' + and name = ? + + }; + $sth=$db->prepare($statement); + $sth->execute($system); + $info_row=$sth->fetchrow_hashref; + + my $latest_personality = $db->selectrow_arrayref(q{ + select os_version, compiler_version + from personality + where effective_date < ? + and name = ? + order by effective_date desc limit 1 + }, undef, $logdate, $system); + # $sysinfo = join(" ",@$row); + if ($latest_personality) + { + $info_row->{os_version} = $latest_personality->[0]; + $info_row->{compiler_version} = $latest_personality->[1]; + } + $sth->finish; + $db->disconnect; +} + +foreach my $chgd ($changed_this_run,$changed_since_success) +{ + my $cvsurl = 'http://anoncvs.postgresql.org/cvsweb.cgi'; + my $giturl = $scmurl || 'http://git.postgresql.org/gitweb?p=postgresql.git;a=commit;h='; + my @lines = split(/!/,$chgd); + my $changed_rows = []; + foreach (@lines) + { + next if ($scm eq 'cvs' and ! m!^(pgsql|master|REL\d_\d_STABLE)/!); + push(@$changed_rows,[$1,$3]) if (m!(^\S+)(\s+)(\S+)!); + } + $chgd = $changed_rows; +} + +$conf =~ s/\@/ [ a t ] /g; + +print "Content-Type: text/html\n\n"; + +$template->process('log.tt', + { + scm => $scm, + scmurl => $scmurl, + system => $system, + branch => $branch, + stage => $stage, + urldt => $logdate, + log_file_names => \@log_file_names, + conf => $conf, + log => $log, + changed_this_run => $changed_this_run, + changed_since_success => $changed_since_success, + info_row => $info_row, + + }); + diff --git a/cgi-bin/show_members.pl b/cgi-bin/show_members.pl new file mode 100755 index 0000000..f6fb396 --- /dev/null +++ b/cgi-bin/show_members.pl @@ -0,0 +1,97 @@ +#!/usr/bin/perl + +use strict; +use CGI; +use DBI; +use Template; + + + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir $sort_by); + + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; +#require "BuildFarmWeb.pl"; + +my $query = new CGI; +my %sort_ok = ('name' => 'lower(name)' , + 'owner' => 'lower(owner_email)', + 'os' => 'lower(operating_system), os_version', + 'compiler' => 'lower(compiler), compiler_version' , + 'arch' => 'lower(architecture)' ); +$sort_by = $query->param('sort_by');$sort_by =~ s/[^a-zA-Z0-9_ -]//g; +$sort_by = $sort_ok{$sort_by} || $sort_ok{name}; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +my $db = DBI->connect($dsn,$dbuser,$dbpass,{pg_expand_array => 0}); + +# there is possibly some redundancy in this query, but it makes +# a lot of the processing simpler. + +my $statement = q{ + + select name, operating_system, os_version, compiler, compiler_version, owner_email, + sys_notes_ts::date AS sys_notes_date, sys_notes, + architecture as arch, ARRAY( + select branch || ':' || + extract(days from now() - l.snapshot) + from latest_snapshot l + where l.sysname = s.name + order by branch <> 'HEAD', branch desc + ) as branches, + ARRAY(select compiler_version || '\t' || os_version || '\t' || effective_date + from personality p + where p.name = s.name + order by effective_date + ) as personalities + from buildsystems s + where status = 'approved' +}; + +$statement .= "order by $sort_by"; + +my $statrows=[]; +my $sth=$db->prepare($statement); +$sth->execute; +while (my $row = $sth->fetchrow_hashref) +{ + $row->{branches} =~ s/^\{(.*)\}$/$1/; + my $personalities = $row->{personalities}; + $personalities =~ s/^\{(.*)\}$/$1/; + my @personalities = split(',',$personalities); + $row->{personalities} = []; + foreach my $personality (@personalities) + { + $personality =~ s/^"(.*)"$/$1/; + $personality =~ s/\\(.)/$1/g; + + my ($compiler_version, $os_version, $effective_date) = split(/\t/,$personality); + $effective_date =~ s/ .*//; + push(@{$row->{personalities}}, {compiler_version => $compiler_version, + os_version => $os_version, + effective_date => $effective_date }); + } + $row->{owner_email} =~ s/\@/ [ a t ] /; + push(@$statrows,$row); +} +$sth->finish; + + +$db->disconnect; + +# use Data::Dumper; print "Content-Type: text/plain\n\n",Dumper($statrows),"VERSION: ",$DBD::Pg::VERSION,"\n"; exit; + + +my $template_opts = { INCLUDE_PATH => $template_dir}; +my $template = new Template($template_opts); + +print "Content-Type: text/html\n\n"; + +$template->process('members.tt', + {statrows=>$statrows}); + +exit; + diff --git a/cgi-bin/show_stage_log.pl b/cgi-bin/show_stage_log.pl new file mode 100755 index 0000000..539d5a1 --- /dev/null +++ b/cgi-bin/show_stage_log.pl @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +use strict; +use DBI; +use Template; +use CGI; +use File::Temp qw(tempfile); + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport @log_file_names); + + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; +#require "BuildFarmWeb.pl"; + +die "no dbname" unless $dbname; +die "no dbuser" unless $dbuser; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +my $query = new CGI; + +my $system = $query->param('nm'); $system =~ s/[^a-zA-Z0-9_ -]//g; +my $logdate = $query->param('dt');$logdate =~ s/[^a-zA-Z0-9_ -]//g; +my $stage = $query->param('stg');$stage =~ s/[^a-zA-Z0-9._ -]//g; + +use vars qw($tgz); + +if ($system && $logdate && $stage) +{ + my $db = DBI->connect($dsn,$dbuser,$dbpass); + + die $DBI::errstr unless $db; + + my $statement = q( + + select branch, log_text + from build_status_log + where sysname = ? and snapshot = ? and log_stage = ? || '.log' + + ); + + + + my $sth=$db->prepare($statement); + $sth->execute($system,$logdate,$stage); + my $row=$sth->fetchrow_arrayref; + my ($branch, $logtext) = ("unknown","no log text found"); + if ($row) + { + $branch = $row->[0]; + $logtext =$row->[1]; + } + $sth->finish; + $db->disconnect; + + print "Content-Type: text/plain\n\n", $logtext, + + "-------------------------------------------------\n\n", + "Hosting for the PostgreSQL Buildfarm is generously ", + "provided by: CommandPrompt, The PostgreSQL Company"; + +} + +else +{ + print "Status: 460 bad parameters\n", + "Content-Type: text/plain\n\n"; +} + diff --git a/cgi-bin/show_status.pl b/cgi-bin/show_status.pl new file mode 100755 index 0000000..646195c --- /dev/null +++ b/cgi-bin/show_status.pl @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use strict; +use DBI; +use Template; +use CGI; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir); + + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + +my $query = new CGI; +my @members = $query->param('member'); +map { s/[^a-zA-Z0-9_ -]//g; } @members; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + + +my $sort_clause = ""; +my $sortby = $query->param('sortby') || 'nosort'; +if ($sortby eq 'name') +{ + $sort_clause = 'lower(sysname),'; +} +elsif ($sortby eq 'os') +{ + $sort_clause = 'lower(operating_system), os_version desc,'; +} +elsif ($sortby eq 'compiler') +{ + $sort_clause = "lower(compiler), compiler_version,"; +} + +my $db = DBI->connect($dsn,$dbuser,$dbpass,{pg_expand_array => 0}) + or die("$dsn,$dbuser,$dbpass,$!"); + +my $statement =<prepare($statement); +$sth->execute; +while (my $row = $sth->fetchrow_hashref) +{ + next if (@members && ! grep {$_ eq $row->{sysname} } @members); + $row->{build_flags} =~ s/^\{(.*)\}$/$1/; + $row->{build_flags} =~ s/,/ /g; + # enable-integer-datetimes is now the default + if ($row->{branch} eq 'HEAD' || $row->{branch} gt 'REL8_3_STABLE') + { + $row->{build_flags} .= " --enable-integer-datetimes " + unless ($row->{build_flags} =~ /--(en|dis)able-integer-datetimes/); + } + # enable-thread-safety is now the default + if ($row->{branch} eq 'HEAD' || $row->{branch} gt 'REL8_5_STABLE') + { + $row->{build_flags} .= " --enable-thread-safety " + unless ($row->{build_flags} =~ /--(en|dis)able-thread-safety/); + } + $row->{build_flags} =~ s/--((enable|with)-)?//g; + $row->{build_flags} =~ s/libxml/xml/; + $row->{build_flags} =~ s/\S+=\S+//g; + push(@$statrows,$row); +} +$sth->finish; + + +$db->disconnect; + + +my $template_opts = { INCLUDE_PATH => $template_dir }; +my $template = new Template($template_opts); + +print "Content-Type: text/html\n\n"; + +$template->process('status.tt', + {statrows=>$statrows}); + +exit; + diff --git a/cgi-bin/show_status_soap.pl b/cgi-bin/show_status_soap.pl new file mode 100755 index 0000000..5d12800 --- /dev/null +++ b/cgi-bin/show_status_soap.pl @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; + + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport); + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + +use lib "/home/community/pgbuildfarm/lib/lib/perl5/site_perl"; + +use SOAP::Transport::HTTP; + +SOAP::Transport::HTTP::CGI->dispatch_to('PGBuildFarm')->handle; + +exit; + +package PGBuildFarm; + +use DBI; + +sub get_status + +{ + my $class = shift; + my @members = @_; + + my $dsn="dbi:Pg:dbname=$::dbname"; + $dsn .= ";host=$::dbhost" if $::dbhost; + $dsn .= ";port=$::dbport" if $::dbport; + + my $db = DBI->connect($dsn,$::dbuser,$::dbpass) or + die("$dsn,$::dbuser,$::dbpass,$!"); + + # there is possibly some redundancy in this query, but it makes + # a lot of the processing simpler. + + my $statement =<prepare($statement); + $sth->execute; + while (my $row = $sth->fetchrow_hashref) + { + next if (@members && ! grep {$_ eq $row->{sysname} } @members); + $row->{build_flags} =~ s/^\{(.*)\}$/$1/; + $row->{build_flags} =~ s/,/ /g; + $row->{build_flags} =~ s/--((enable|with)-)?//g; + $row->{build_flags} =~ s/\S+=\S+//g; + push(@$statrows,$row); + } + $sth->finish; + + + $db->disconnect; + + return $statrows; + +} + +1; + + + + + diff --git a/cgi-bin/test.pl b/cgi-bin/test.pl new file mode 100755 index 0000000..9b179d2 --- /dev/null +++ b/cgi-bin/test.pl @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +#print "Content-Type: text/html\n\n"; +#print "

My quick perl hello

"; + +use CGI; + +my $query = new CGI; + +my $url = $query->url(); + +my $base = $query->url(-base=>1); + +print <connect($dsn,$dbuser,$dbpass) or die("$dsn,$dbuser,$dbpass,$!"); + +my %words; + +my $sql = q{ + select sysname, max(snapshot) as snapshot + from build_status_log + where branch = 'HEAD' and + log_stage = 'typedefs.log' and + snapshot > current_date::timestamp - interval '30 days' + group by sysname +}; +my $builds = $dbh->selectall_arrayref($sql, { Slice => {} }); + + +if ($query->param('show_list')) +{ + print "Content-Type: text/html\n\n", + "Typedefs URLs\n", + "

Typdefs URLs

\n", + "\n"; + + foreach my $build (@$builds) + { + print "\n"; + } + print "
member
$build->{sysname}
\n"; + exit; +} + +$sql = q{ + select log_text + from build_status_log + where sysname = ? + and snapshot = ? + and log_stage = 'typedefs.log' + and branch = 'HEAD' + }; + +my $sth = $dbh->prepare($sql); + +foreach my $build (@$builds) +{ + $sth->execute($build->{sysname},$build->{snapshot}); + my @row = $sth->fetchrow; + my @typedefs = split(/\s+/,$row[0]); + @words{@typedefs} = 1 x @typedefs; +} + +print "Content-Type: text/plain\n\n", + join("\n",sort keys %words), + "\n"; diff --git a/cgi-bin/upgrade.pl b/cgi-bin/upgrade.pl new file mode 100755 index 0000000..f4cbb99 --- /dev/null +++ b/cgi-bin/upgrade.pl @@ -0,0 +1,149 @@ +#!/usr/bin/perl + +use strict; + +use CGI; +use Digest::SHA1 qw(sha1_hex); +use MIME::Base64; +use DBI; +use DBD::Pg; +use Data::Dumper; + +use vars qw($dbhost $dbname $dbuser $dbpass $dbport); + +my $query = new CGI; + +my $sig = $query->path_info; +$sig =~ s!^/!!; + +my $animal = $query->param('animal'); +my $ts = $query->param('ts'); +my $os_version = $query->param('new_os'); +my $compiler_version = $query->param('new_compiler'); + +my $content = "animal=$animal\&ts=$ts"; +$content .= "\&new_os=$os_version" if $os_version; +$content .= "\&new_compiler=$compiler_version" if $compiler_version; + +require "$ENV{BFConfDir}/BuildFarmWeb.pl"; + +die "no dbname" unless $dbname; +die "no dbuser" unless $dbuser; + +my $dsn="dbi:Pg:dbname=$dbname"; +$dsn .= ";host=$dbhost" if $dbhost; +$dsn .= ";port=$dbport" if $dbport; + +unless ($animal && $ts && ($os_version || $compiler_version) && $sig) +{ + print + "Status: 490 bad parameters\nContent-Type: text/plain\n\n", + "bad parameters for request\n"; + exit; + +} + + +my $db = DBI->connect($dsn,$dbuser,$dbpass); + +die $DBI::errstr unless $db; + +my $gethost= + "select secret from buildsystems where name = ? and status = 'approved'"; +my $sth = $db->prepare($gethost); +$sth->execute($animal); +my ($secret)=$sth->fetchrow_array(); +$sth->finish; + + +unless ($secret) +{ + print + "Status: 495 Unknown System\nContent-Type: text/plain\n\n", + "System $animal is unknown\n"; + $db->disconnect; + exit; + +} + + + + +my $calc_sig = sha1_hex($content,$secret); + +if ($calc_sig ne $sig) +{ + + print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n"; + print "$sig mismatches $calc_sig on content:\n$content"; + $db->disconnect; + exit; +} + +# undo escape-proofing of base64 data and decode it +map {tr/$@/+=/; $_ = decode_base64($_); } + ($os_version, $compiler_version); + +my $get_latest = q{ + + select coalesce(b.os_version, a.os_version) as os_version, + coalesce(b.compiler_version, a.compiler_version) as compiler_version + from buildsystems as a left join + ( select distinct on (name) name, compiler_version, os_version + from personality + order by name, effective_date desc + ) as b + on (a.name = b.name) + where a.name = ? + and a.status = 'approved' + +}; + +$sth = $db->prepare($get_latest); +my $rv = $sth->execute($animal); +unless($rv) +{ + print "Status: 460 old data fetch\nContent-Type: text/plain\n\n"; + print "error: ",$db->errstr,"\n"; + $db->disconnect; + exit; +} + +my ($old_os,$old_comp)=$sth->fetchrow_array(); +$sth->finish; + + + +$os_version ||= $old_os; +$compiler_version ||= $old_comp; + +my $new_personality = q{ + + insert into personality (name, os_version, compiler_version) + values (?,?,?) + +}; + + +$sth = $db->prepare($new_personality); +$rv = $sth->execute($animal,$os_version, $compiler_version); + +unless($rv) +{ + print "Status: 470 new data insert\nContent-Type: text/plain\n\n"; + print "error: $db->errstr\n"; + $db->disconnect; + exit; +} + +$sth->finish; + + + +$db->disconnect; + +print "Content-Type: text/plain\n\n"; +print "request was on:\n$content\n"; + + + diff --git a/trunk/cgi-bin/addnotes.pl b/trunk/cgi-bin/addnotes.pl deleted file mode 100755 index acab114..0000000 --- a/trunk/cgi-bin/addnotes.pl +++ /dev/null @@ -1,116 +0,0 @@ -#!/usr/bin/perl - -use strict; - -use CGI; -use Digest::SHA1 qw(sha1_hex); -use MIME::Base64; -use DBI; -use DBD::Pg; -use Data::Dumper; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport); - -my $query = new CGI; - -my $sig = $query->path_info; -$sig =~ s!^/!!; - -my $animal = $query->param('animal'); -my $sysnotes = $query->param('sysnotes'); - -my $content = "animal=$animal\&sysnotes=$sysnotes"; - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - -die "no dbname" unless $dbname; -die "no dbuser" unless $dbuser; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -unless ($animal && defined($sysnotes) && $sig) -{ - print - "Status: 490 bad parameters\nContent-Type: text/plain\n\n", - "bad parameters for request\n"; - exit; - -} - - -my $db = DBI->connect($dsn,$dbuser,$dbpass); - -die $DBI::errstr unless $db; - -my $gethost= - "select secret from buildsystems where name = ? and status = 'approved'"; -my $sth = $db->prepare($gethost); -$sth->execute($animal); -my ($secret)=$sth->fetchrow_array(); -$sth->finish; - - -unless ($secret) -{ - print - "Status: 495 Unknown System\nContent-Type: text/plain\n\n", - "System $animal is unknown\n"; - $db->disconnect; - exit; - -} - - - - -my $calc_sig = sha1_hex($content,$secret); - -if ($calc_sig ne $sig) -{ - - print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n"; - print "$sig mismatches $calc_sig on content:\n$content"; - $db->disconnect; - exit; -} - -# undo escape-proofing of base64 data and decode it -map {tr/$@/+=/; $_ = decode_base64($_); } - ($sysnotes); - -my $set_notes = q{ - - update buildsystems - set sys_notes = nullif($2,''), - sys_notes_ts = case - when coalesce($2,'') <> '' then now() - else null - end - where name = $1 - and status = 'approved' - -}; - -$sth = $db->prepare($set_notes); -my $rv = $sth->execute($animal,$sysnotes); -unless($rv) -{ - print "Status: 460 old data fetch\nContent-Type: text/plain\n\n"; - print "error: ",$db->errstr,"\n"; - $db->disconnect; - exit; -} - -$sth->finish; - - - -$db->disconnect; - -print "Content-Type: text/plain\n\n"; -print "request was on:\n$content\n"; - - - diff --git a/trunk/cgi-bin/envtest.pl b/trunk/cgi-bin/envtest.pl deleted file mode 100644 index f86621f..0000000 --- a/trunk/cgi-bin/envtest.pl +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/perl - -print "Content-Type: text/plain\n\n"; - -print "Conf: $ENV{BFConfDir}\n"; - -print `pwd`; - -print `id`; - -foreach my $key (sort keys %ENV) -{ - my $val = $ENV{$key}; - print "$key=$val\n"; -} diff --git a/trunk/cgi-bin/get_bf_status_soap.pl b/trunk/cgi-bin/get_bf_status_soap.pl deleted file mode 100755 index 02059e7..0000000 --- a/trunk/cgi-bin/get_bf_status_soap.pl +++ /dev/null @@ -1,30 +0,0 @@ -#!/usr/bin/perl - -use lib "/home/community/pgbuildfarm/lib/lib/perl5/site_perl"; - -use SOAP::Lite +trace; - -my $obj = SOAP::Lite - ->uri('http://www.pgbuildfarm.org/PGBuildFarm') - ->proxy('http://127.0.0.1/cgi-bin/show_status_soap.pl') - ->request->header("Host" => "www.pgbuildfarm.org") - ; - -my $data = $obj->get_status->result; -my @fields = qw( branch sysname stage status - operating_system os_version - compiler compiler_version architecture - when_ago snapshot build_flags - ); - -print "Content-Type: text/plain\n\n"; - -my $head = join (' | ', @fields); -print $head,"\n"; - -foreach my $datum (@$data) -{ - my $line = join (' | ', @{$datum}{@fields}); - print $line,"\n"; -} - diff --git a/trunk/cgi-bin/pgstatus.pl b/trunk/cgi-bin/pgstatus.pl deleted file mode 100755 index c9b0268..0000000 --- a/trunk/cgi-bin/pgstatus.pl +++ /dev/null @@ -1,542 +0,0 @@ -#!/usr/bin/perl - -use strict; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport - $all_stat $fail_stat $change_stat $green_stat - $server_time - $min_script_version $min_web_script_version - $default_host -); - -# force this before we do anything - even load modules -BEGIN { $server_time = time; } - -use CGI; -use Digest::SHA1 qw(sha1_hex); -use MIME::Base64; -use DBI; -use DBD::Pg; -use Data::Dumper; -use Mail::Send; -use Time::ParseDate; -use Storable qw(thaw); - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; -my $buildlogs = "$ENV{BFConfDir}/buildlogs"; - -die "no dbname" unless $dbname; -die "no dbuser" unless $dbuser; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -my $query = new CGI; - -my $sig = $query->path_info; -$sig =~ s!^/!!; - -my $stage = $query->param('stage'); -my $ts = $query->param('ts'); -my $animal = $query->param('animal'); -my $log = $query->param('log'); -my $res = $query->param('res'); -my $conf = $query->param('conf'); -my $branch = $query->param('branch'); -my $changed_since_success = $query->param('changed_since_success'); -my $changed_this_run = $query->param('changed_files'); -my $log_archive = $query->param('logtar'); -my $frozen_sconf = $query->param('frozen_sconf') || ''; - -my $content = - "branch=$branch&res=$res&stage=$stage&animal=$animal&". - "ts=$ts&log=$log&conf=$conf"; - -my $extra_content = - "changed_files=$changed_this_run&". - "changed_since_success=$changed_since_success&"; - -unless ($animal && $ts && $stage && $sig) -{ - print - "Status: 490 bad parameters\nContent-Type: text/plain\n\n", - "bad parameters for request\n"; - exit; - -} - -unless ($branch =~ /^(HEAD|REL\d+_\d+_STABLE)$/) -{ - print - "Status: 492 bad branch parameter $branch\nContent-Type: text/plain\n\n", - "bad branch parameter $branch\n"; - exit; - -} - - -my $db = DBI->connect($dsn,$dbuser,$dbpass); - -die $DBI::errstr unless $db; - -my $gethost= - "select secret from buildsystems where name = ? and status = 'approved'"; -my $sth = $db->prepare($gethost); -$sth->execute($animal); -my ($secret)=$sth->fetchrow_array(); -$sth->finish; - -my $tsdiff = time - $ts; - -my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($ts); -$year += 1900; $mon +=1; -my $date= - sprintf("%d-%.2d-%.2d_%.2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec); - -if ($ENV{BF_DEBUG} || ($ts > time) || ($ts + 86400 < time ) || (! $secret) ) -{ - open(TX,">$buildlogs/$animal.$date"); - print TX "sig=$sig\nlogtar-len=" , length($log_archive), - "\nstatus=$res\nstage=$stage\nconf:\n$conf\n", - "tsdiff:$tsdiff\n", - "changed_this_run:\n$changed_this_run\n", - "changed_since_success:\n$changed_since_success\n", - "frozen_sconf:$frozen_sconf\n", - "log:\n",$log; -# $query->save(\*TX); - close(TX); -} - -unless ($ts < time + 120) -{ - my $gmt = gmtime($ts); - print "Status: 491 bad ts parameter - $ts ($gmt GMT) is in the future.\n", - "Content-Type: text/plain\n\n bad ts parameter - $ts ($gmt GMT) is in the future\n"; - $db->disconnect; - exit; -} - -unless ($ts + 86400 > time) -{ - my $gmt = gmtime($ts); - print "Status: 491 bad ts parameter - $ts ($gmt GMT) is more than 24 hours ago.\n", - "Content-Type: text/plain\n\n bad ts parameter - $ts ($gmt GMT) is more than 24 hours ago.\n"; - $db->disconnect; - exit; -} - -unless ($secret) -{ - print - "Status: 495 Unknown System\nContent-Type: text/plain\n\n", - "System $animal is unknown\n"; - $db->disconnect; - exit; - -} - - - - -my $calc_sig = sha1_hex($content,$secret); -my $calc_sig2 = sha1_hex($extra_content,$content,$secret); - -if ($calc_sig ne $sig && $calc_sig2 ne $sig) -{ - - print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n"; - print "$sig mismatches $calc_sig($calc_sig2) on content:\n$content"; - $db->disconnect; - exit; -} - -# undo escape-proofing of base64 data and decode it -map {tr/$@/+=/; $_ = decode_base64($_); } - ($log, $conf,$changed_this_run,$changed_since_success,$log_archive, $frozen_sconf); - -if ($log =~/Last file mtime in snapshot: (.*)/) -{ - my $snaptime = parsedate($1); - if ($snaptime < (time - (10 * 86400))) - { - print "Status: 493 snapshot too old: $1\nContent-Type: text/plain\n\n"; - print "snapshot to old: $1\n"; - $db->disconnect; - exit; - } -} - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($ts); -$year += 1900; $mon +=1; -my $dbdate= - sprintf("%d-%.2d-%.2d %.2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec); - -my $log_file_names; -my @log_file_names; -my $dirname = "$buildlogs/tmp.$$.unpacklogs"; - -my $githeadref; - -if ($log_archive) -{ - my $log_handle; - my $archname = "$buildlogs/tmp.$$.tgz"; - open($log_handle,">$archname"); - binmode $log_handle; - print $log_handle $log_archive; - close $log_handle; - mkdir $dirname; - @log_file_names = `tar -z -C $dirname -xvf $archname 2>/dev/null`; - map {s/\s+//g; } @log_file_names; - my @qnames = grep { $_ ne 'githead.log' } @log_file_names; - map { $_ = qq("$_"); } @qnames; - $log_file_names = '{' . join(',',@qnames) . '}'; - if (-e "$dirname/githead.log" ) - { - open(my $githead,"$dirname/githead.log"); - $githeadref = <$githead>; - chomp $githeadref; - close $githead; - } - # unlink $archname; -} - -my $config_flags; -my $client_conf; -if ($frozen_sconf) -{ - $client_conf = thaw $frozen_sconf; -} - -if ($min_script_version) -{ - $client_conf->{script_version} ||= '0.0'; - my $cli_ver = $client_conf->{script_version} ; - $cli_ver =~ s/^REL_//; - my ($minmajor,$minminor) = split(/\./,$min_script_version); - my ($smajor,$sminor) = split(/\./,$cli_ver); - if ($minmajor > $smajor || ($minmajor == $smajor && $minminor > $sminor)) - { - print "Status: 460 script version too low\nContent-Type: text/plain\n\n"; - print - "Script version is below minimum required\n", - "Reported version: $client_conf->{script_version},", - "Minumum version required: $min_script_version\n"; - $db->disconnect; - exit; - } -} - -if ($min_web_script_version) -{ - $client_conf->{web_script_version} ||= '0.0'; - my $cli_ver = $client_conf->{web_script_version} ; - $cli_ver =~ s/^REL_//; - my ($minmajor,$minminor) = split(/\./,$min_web_script_version); - my ($smajor,$sminor) = split(/\./,$cli_ver); - if ($minmajor > $smajor || ($minmajor == $smajor && $minminor > $sminor)) - { - print "Status: 461 web script version too low\nContent-Type: text/plain\n\n"; - print - "Web Script version is below minimum required\n", - "Reported version: $client_conf->{web_script_version}, ", - "Minumum version required: $min_web_script_version\n" - ; - $db->disconnect; - exit; - } -} - -my @config_flags; -if (not exists $client_conf->{config_opts} ) -{ - @config_flags = (); -} -elsif (ref $client_conf->{config_opts} eq 'HASH') -{ - # leave out keys with false values - @config_flags = grep { $client_conf->{config_opts}->{$_} } - keys %{$client_conf->{config_opts}}; -} -elsif (ref $client_conf->{config_opts} eq 'ARRAY' ) -{ - @config_flags = @{$client_conf->{config_opts}}; -} - -if (@config_flags) -{ - @config_flags = grep {! m/=/ } @config_flags; - map {s/\s+//g; $_=qq("$_"); } @config_flags; - push @config_flags,'git' if $client_conf->{scm} eq 'git'; - $config_flags = '{' . join(',',@config_flags) . '}' ; -} - -my $scm = $client_conf->{scm} || 'cvs'; -my $scmurl = $client_conf->{scm_url}; - -my $logst = <begin_work; -$db->do("select set_local_error_terse()"); - - -$sth=$db->prepare($logst); - -$sth->bind_param(1,$animal); -$sth->bind_param(2,$dbdate); -$sth->bind_param(3,$res); -$sth->bind_param(4,$stage); -$sth->bind_param(5,$log); -$sth->bind_param(6,$conf); -$sth->bind_param(7,$branch); -$sth->bind_param(8,$changed_this_run); -$sth->bind_param(9,$changed_since_success); -$sth->bind_param(10,$log_file_names); -#$sth->bind_param(11,$log_archive,{ pg_type => DBD::Pg::PG_BYTEA }); -$sth->bind_param(11,undef,{ pg_type => DBD::Pg::PG_BYTEA }); -$sth->bind_param(12,$config_flags); -$sth->bind_param(13,$scm); -$sth->bind_param(14,$scmurl); -$sth->bind_param(15,$githeadref); -$sth->bind_param(16,$frozen_sconf,{ pg_type => DBD::Pg::PG_BYTEA }); - -$sth->execute; -$sth->finish; - - - -my $logst2 = <prepare($logst2); - -$/=undef; - -my $stage_start = $ts; - -foreach my $log_file( @log_file_names ) -{ - next if $log_file =~ /^githead/; - my $handle; - open($handle,"$dirname/$log_file"); - my $mtime = (stat $handle)[9]; - my $stage_interval = $mtime - $stage_start; - $stage_start = $mtime; - my $ltext = <$handle>; - close($handle); - $ltext =~ s/\x00/\\0/g; - $sth->execute($animal,$dbdate,$branch,$log_file,$ltext, - "$stage_interval seconds"); -} - -$sth->finish; - -$db->commit; - -my $prevst = <prepare($prevst); -$sth->execute($animal,$branch,$dbdate); -my $row=$sth->fetchrow_arrayref; -my $prev_stat=$row->[0]; -$sth->finish; - -my $det_st = <prepare($det_st); -$sth->execute($animal); -$row=$sth->fetchrow_arrayref; -my ($os, $compiler,$arch) = @$row; -$sth->finish; - -$db->begin_work; -# prevent occasional duplication by forcing serialization of this operation -$db->do("lock table dashboard_mat in share row exclusive mode"); -$db->do("delete from dashboard_mat"); -$db->do("insert into dashboard_mat select * from dashboard_mat_data"); -$db->commit; - -$db->disconnect; - -print "Content-Type: text/plain\n\n"; -print "request was on:\n"; -print "res=$res&stage=$stage&animal=$animal&ts=$ts"; - -my $client_events = $client_conf->{mail_events}; - -if ($ENV{BF_DEBUG}) -{ - my $client_time = $client_conf->{current_ts}; - open(TX,">>$buildlogs/$animal.$date"); - print TX "\n",Dumper(\$client_conf),"\n"; - print TX "server time: $server_time, client time: $client_time\n" if $client_time; - close(TX); -} - -my $bcc_stat = []; -my $bcc_chg=[]; -if (ref $client_events) -{ - my $cbcc = $client_events->{all}; - if (ref $cbcc) - { - push @$bcc_stat, @$cbcc; - } - elsif (defined $cbcc) - { - push @$bcc_stat, $cbcc; - } - if ($stage ne 'OK') - { - $cbcc = $client_events->{all}; - if (ref $cbcc) - { - push @$bcc_stat, @$cbcc; - } - elsif (defined $cbcc) - { - push @$bcc_stat, $cbcc; - } - } - $cbcc = $client_events->{change}; - if (ref $cbcc) - { - push @$bcc_chg, @$cbcc; - } - elsif (defined $cbcc) - { - push @$bcc_chg, $cbcc; - } - if ($stage eq 'OK' || $prev_stat eq 'OK') - { - $cbcc = $client_events->{green}; - if (ref $cbcc) - { - push @$bcc_chg, @$cbcc; - } - elsif (defined $cbcc) - { - push @$bcc_chg, $cbcc; - } - } -} - - -my $url = $query->url(-base => 1); - - -my $stat_type = $stage eq 'OK' ? 'Status' : 'Failed at Stage'; - -my $mailto = [@$all_stat]; -push(@$mailto,@$fail_stat) if $stage ne 'OK'; - -my $me = `id -un`; chomp($me); - -my $host = `hostname`; chomp ($host); -$host = $default_host unless ($host =~ m/[.]/ || !defined($default_host)); - -my $from_addr = "PG Build Farm <$me\@$host>"; -$from_addr =~ tr /\r\n//d; - -my $msg = new Mail::Send; - - -$msg->to(@$mailto); -$msg->bcc(@$bcc_stat) if (@$bcc_stat); -$msg->subject("PGBuildfarm member $animal Branch $branch $stat_type $stage"); -$msg->set('From',$from_addr); -my $fh = $msg->open; -print $fh <close; - -exit if ($stage eq $prev_stat); - -$mailto = [@$change_stat]; -push(@$mailto,@$green_stat) if ($stage eq 'OK' || $prev_stat eq 'OK'); - -$msg = new Mail::Send; - - -$msg->to(@$mailto); -$msg->bcc(@$bcc_chg) if (@$bcc_chg); - -$stat_type = $prev_stat ne 'OK' ? "changed from $prev_stat failure to $stage" : - "changed from OK to $stage"; -$stat_type = "New member: $stage" if $prev_stat eq 'NEW'; -$stat_type .= " failure" if $stage ne 'OK'; - -$msg->subject("PGBuildfarm member $animal Branch $branch Status $stat_type"); -$msg->set('From',$from_addr); -$fh = $msg->open; -print $fh <close; diff --git a/trunk/cgi-bin/register-form.pl b/trunk/cgi-bin/register-form.pl deleted file mode 100755 index cf4621a..0000000 --- a/trunk/cgi-bin/register-form.pl +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/perl - -use strict; -use Template; -use Captcha::reCAPTCHA; - -use vars qw( $template_dir $captcha_pubkey ); -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - - -my $c = Captcha::reCAPTCHA->new; - -my $captcha = $c->get_html($captcha_pubkey); - -my $template_opts = { INCLUDE_PATH => $template_dir }; -my $template = new Template($template_opts); - -print "Content-Type: text/html\n\n"; - - -$template->process('register-form.tt',{captcha => $captcha}); - - - - - diff --git a/trunk/cgi-bin/register.pl b/trunk/cgi-bin/register.pl deleted file mode 100755 index 37290f8..0000000 --- a/trunk/cgi-bin/register.pl +++ /dev/null @@ -1,149 +0,0 @@ -#!/usr/bin/perl - -use strict; -use DBI; -use Template; -use CGI; -use Template; -use Captcha::reCAPTCHA; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport $notifyapp $captcha_pubkey $captcha_privkey $template_dir $default_host); - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -my $template_opts = { INCLUDE_PATH => $template_dir}; -my $template = new Template($template_opts); -my $query = new CGI; - -my $params = $query->Vars; - -my ($os, $osv, $comp, $compv, $arch, $email, $owner, $challenge, $response ) = @{$params}{ - qw(os osv comp compv arch email owner recaptcha_challenge_field recaptcha_response_field)}; - -my $captcha = Captcha::reCAPTCHA->new; -my $captcha_ok = $captcha->check_answer - ( - $captcha_privkey, - $ENV{'REMOTE_ADDR'}, - $challenge, $response - ); - - -unless ($os && $osv && $comp && $compv && $arch && $email && $owner && $captcha_ok->{is_valid}) -{ - print "Content-Type: text/html\n\n"; - $template->process('register-incomplete.tt'); - exit; -} - -# some idiot has a script that tries to talk to me -# this should catch and dispose of him -if ((grep {/rgergerger|\@pgbuildfarm\.org|Content-Type:|http:|mailto:|href=|None|Unknown/} $os,$osv,$comp,$compv,$arch,$email,$owner) - || ($email =~ /john.*\@aol.com/) ) -{ - print - "Status: 403 Forbidden - go away idiot\n", - "Content-Type: text/plain\n\n"; - exit; -} - -# count transitions to and from upper case -my $trans = 1; -my $counttrans = 0; -foreach (split "" ,"$os$osv$comp$compv$arch$owner") -{ - if (/[A-Z]/) - { - next if $trans; - $trans = 1; - $counttrans++; - } - else - { - next unless $trans; - $trans = 0; - $counttrans++; - } -} - -# reject junk with too many transitions into/outof upper case -if ($counttrans > 20) -{ - print - "Status: 403 Forbidden - go away idiot\n", - "Content-Type: text/plain\n\n"; - exit; -} - - - -my $secret = ""; -my $dummyname=""; # we'll select an animal name when we approve it. -foreach (1..8) -{ - # 8 random chars is enough for the dummy name - $secret .= substr("0123456789abcdefghijklmnopqrstuvwxyz",int(rand(36)),1); - $dummyname .= substr("0123456789abcdef",int(rand(16)),1); -} -foreach (9..32) -{ - $secret .= substr("0123456789abcdef",int(rand(16)),1); -} - -my $db = DBI->connect($dsn,$dbuser,$dbpass); - -my $statement = <prepare($statement); -my $rv=$sth->execute($dummyname,$secret,$os,$osv,$comp,$compv, - $arch,$owner,$email); -my $err=$db->errstr; - -# everything looks OK, so tell them so -print "Content-type: text/html\n\n"; -$template->process('register-ok.tt'); - -$sth->finish; -$db->disconnect; - - -use Mail::Send; - -my $msg = new Mail::Send; - -my $me = `id -un`; chomp($me); -my $host = `hostname`; chomp ($host); -$host = $default_host unless ($host =~ m/[.]/ || !defined($default_host)); - -my $from_addr = "PG Build Farm <$me\@$host>"; -$from_addr =~ tr /\r\n//d; - -$msg->set('From',$from_addr); - -$msg->to(@$notifyapp); -$msg->subject('New Buildfarm Application'); -my $fh = $msg->open; -print $fh "\n\nName: $dummyname\n", - "OS: $os: $osv\n", - "Arch: $arch\n", - "Comp: $comp: $compv\n", - "Owner: $owner <$email>\n"; -$fh->close; - - - - - - diff --git a/trunk/cgi-bin/show_history.pl b/trunk/cgi-bin/show_history.pl deleted file mode 100755 index b55c381..0000000 --- a/trunk/cgi-bin/show_history.pl +++ /dev/null @@ -1,91 +0,0 @@ -#!/usr/bin/perl - -use strict; -use DBI; -use Template; -use CGI; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir); - - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; -#require "BuildFarmWeb.pl"; - -die "no dbname" unless $dbname; -die "no dbuser" unless $dbuser; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -my $db = DBI->connect($dsn,$dbuser,$dbpass); - -die $DBI::errstr unless $db; - -my $query = new CGI; -my $member = $query->param('nm'); $member =~ s/[^a-zA-Z0-9_ -]//g; -my $branch = $query->param('br'); $branch =~ s/[^a-zA-Z0-9_ -]//g; -my $hm = $query->param('hm'); $hm =~ s/[^a-zA-Z0-9_ -]//g; -$hm = '240' unless $hm =~ /^\d+$/; - -my $latest_personality = $db->selectrow_arrayref(q{ - select os_version, compiler_version - from personality - where name = ? - order by effective_date desc limit 1 - }, undef, $member); - -# we don't really need to do this join, since we only want -# one row from buildsystems. but it means we only have to run one -# query. If it gets heavy we'll split it up and run two - -my $statement = <prepare($statement); -$sth->execute($member,$branch); -while (my $row = $sth->fetchrow_hashref) -{ - $row->{owner_email} =~ s/\@/ [ a t ] /; - if ($latest_personality) - { - $row->{os_version} = $latest_personality->[0]; - $row->{compiler_version} = $latest_personality->[1]; - } - push(@$statrows,$row); -} - -$sth->finish; - -$db->disconnect; - -my $template_opts = { INCLUDE_PATH => $template_dir, EVAL_PERL => 1 }; -my $template = new Template($template_opts); - -print "Content-Type: text/html\n\n"; - -$template->process('history.tt', - {statrows=>$statrows, - branch=>$branch, - member => $member, - hm => $hm - }); - -exit; diff --git a/trunk/cgi-bin/show_log.pl b/trunk/cgi-bin/show_log.pl deleted file mode 100755 index 21c6ec5..0000000 --- a/trunk/cgi-bin/show_log.pl +++ /dev/null @@ -1,134 +0,0 @@ -#!/usr/bin/perl - -use strict; -use DBI; -use Template; -use CGI; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir @log_file_names); - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - -my $template_opts = { INCLUDE_PATH => $template_dir, EVAL_PERL => 1}; -my $template = new Template($template_opts); - -die "no dbname" unless $dbname; -die "no dbuser" unless $dbuser; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -my $query = new CGI; - -my $system = $query->param('nm'); $system =~ s/[^a-zA-Z0-9_ -]//g; -my $logdate = $query->param('dt'); $logdate =~ s/[^a-zA-Z0-9_ :-]//g; - -my $log = ""; -my $conf = ""; -my ($stage,$changed_this_run,$changed_since_success,$sysinfo,$branch,$scmurl); -my $scm; - -use vars qw($info_row); - -if ($system && $logdate) -{ - - my $db = DBI->connect($dsn,$dbuser,$dbpass,{pg_expand_array => 0}); - - die $DBI::errstr unless $db; - - my $statement = q{ - - select log,conf_sum,stage, changed_this_run, changed_since_success,branch, - log_archive_filenames, scm, scmurl - from build_status - where sysname = ? and snapshot = ? - - }; - my $sth=$db->prepare($statement); - $sth->execute($system,$logdate); - my $row=$sth->fetchrow_arrayref; - $log=$row->[0]; - $conf=$row->[1] || "not recorded" ; - $stage=$row->[2] || "unknown"; - $changed_this_run = $row->[3]; - $changed_since_success = $row->[4]; - $branch = $row->[5]; - my $log_file_names = $row->[6]; - $scm = $row->[7]; - $scm ||= 'cvs'; # legacy scripts - $scmurl = $row->[8]; - $log_file_names =~ s/^\{(.*)\}$/$1/; - @log_file_names=split(',',$log_file_names) - if $log_file_names; - $sth->finish; - - $statement = q{ - - select operating_system, os_version, - compiler, compiler_version, - architecture, - replace(owner_email,'\@',' [ a t ] ') as owner_email, - sys_notes_ts::date AS sys_notes_date, sys_notes - from buildsystems - where status = 'approved' - and name = ? - - }; - $sth=$db->prepare($statement); - $sth->execute($system); - $info_row=$sth->fetchrow_hashref; - - my $latest_personality = $db->selectrow_arrayref(q{ - select os_version, compiler_version - from personality - where effective_date < ? - and name = ? - order by effective_date desc limit 1 - }, undef, $logdate, $system); - # $sysinfo = join(" ",@$row); - if ($latest_personality) - { - $info_row->{os_version} = $latest_personality->[0]; - $info_row->{compiler_version} = $latest_personality->[1]; - } - $sth->finish; - $db->disconnect; -} - -foreach my $chgd ($changed_this_run,$changed_since_success) -{ - my $cvsurl = 'http://anoncvs.postgresql.org/cvsweb.cgi'; - my $giturl = $scmurl || 'http://git.postgresql.org/gitweb?p=postgresql.git;a=commit;h='; - my @lines = split(/!/,$chgd); - my $changed_rows = []; - foreach (@lines) - { - next if ($scm eq 'cvs' and ! m!^(pgsql|master|REL\d_\d_STABLE)/!); - push(@$changed_rows,[$1,$3]) if (m!(^\S+)(\s+)(\S+)!); - } - $chgd = $changed_rows; -} - -$conf =~ s/\@/ [ a t ] /g; - -print "Content-Type: text/html\n\n"; - -$template->process('log.tt', - { - scm => $scm, - scmurl => $scmurl, - system => $system, - branch => $branch, - stage => $stage, - urldt => $logdate, - log_file_names => \@log_file_names, - conf => $conf, - log => $log, - changed_this_run => $changed_this_run, - changed_since_success => $changed_since_success, - info_row => $info_row, - - }); - diff --git a/trunk/cgi-bin/show_members.pl b/trunk/cgi-bin/show_members.pl deleted file mode 100755 index f6fb396..0000000 --- a/trunk/cgi-bin/show_members.pl +++ /dev/null @@ -1,97 +0,0 @@ -#!/usr/bin/perl - -use strict; -use CGI; -use DBI; -use Template; - - - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir $sort_by); - - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; -#require "BuildFarmWeb.pl"; - -my $query = new CGI; -my %sort_ok = ('name' => 'lower(name)' , - 'owner' => 'lower(owner_email)', - 'os' => 'lower(operating_system), os_version', - 'compiler' => 'lower(compiler), compiler_version' , - 'arch' => 'lower(architecture)' ); -$sort_by = $query->param('sort_by');$sort_by =~ s/[^a-zA-Z0-9_ -]//g; -$sort_by = $sort_ok{$sort_by} || $sort_ok{name}; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -my $db = DBI->connect($dsn,$dbuser,$dbpass,{pg_expand_array => 0}); - -# there is possibly some redundancy in this query, but it makes -# a lot of the processing simpler. - -my $statement = q{ - - select name, operating_system, os_version, compiler, compiler_version, owner_email, - sys_notes_ts::date AS sys_notes_date, sys_notes, - architecture as arch, ARRAY( - select branch || ':' || - extract(days from now() - l.snapshot) - from latest_snapshot l - where l.sysname = s.name - order by branch <> 'HEAD', branch desc - ) as branches, - ARRAY(select compiler_version || '\t' || os_version || '\t' || effective_date - from personality p - where p.name = s.name - order by effective_date - ) as personalities - from buildsystems s - where status = 'approved' -}; - -$statement .= "order by $sort_by"; - -my $statrows=[]; -my $sth=$db->prepare($statement); -$sth->execute; -while (my $row = $sth->fetchrow_hashref) -{ - $row->{branches} =~ s/^\{(.*)\}$/$1/; - my $personalities = $row->{personalities}; - $personalities =~ s/^\{(.*)\}$/$1/; - my @personalities = split(',',$personalities); - $row->{personalities} = []; - foreach my $personality (@personalities) - { - $personality =~ s/^"(.*)"$/$1/; - $personality =~ s/\\(.)/$1/g; - - my ($compiler_version, $os_version, $effective_date) = split(/\t/,$personality); - $effective_date =~ s/ .*//; - push(@{$row->{personalities}}, {compiler_version => $compiler_version, - os_version => $os_version, - effective_date => $effective_date }); - } - $row->{owner_email} =~ s/\@/ [ a t ] /; - push(@$statrows,$row); -} -$sth->finish; - - -$db->disconnect; - -# use Data::Dumper; print "Content-Type: text/plain\n\n",Dumper($statrows),"VERSION: ",$DBD::Pg::VERSION,"\n"; exit; - - -my $template_opts = { INCLUDE_PATH => $template_dir}; -my $template = new Template($template_opts); - -print "Content-Type: text/html\n\n"; - -$template->process('members.tt', - {statrows=>$statrows}); - -exit; - diff --git a/trunk/cgi-bin/show_stage_log.pl b/trunk/cgi-bin/show_stage_log.pl deleted file mode 100755 index 539d5a1..0000000 --- a/trunk/cgi-bin/show_stage_log.pl +++ /dev/null @@ -1,71 +0,0 @@ -#!/usr/bin/perl - -use strict; -use DBI; -use Template; -use CGI; -use File::Temp qw(tempfile); - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport @log_file_names); - - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; -#require "BuildFarmWeb.pl"; - -die "no dbname" unless $dbname; -die "no dbuser" unless $dbuser; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -my $query = new CGI; - -my $system = $query->param('nm'); $system =~ s/[^a-zA-Z0-9_ -]//g; -my $logdate = $query->param('dt');$logdate =~ s/[^a-zA-Z0-9_ -]//g; -my $stage = $query->param('stg');$stage =~ s/[^a-zA-Z0-9._ -]//g; - -use vars qw($tgz); - -if ($system && $logdate && $stage) -{ - my $db = DBI->connect($dsn,$dbuser,$dbpass); - - die $DBI::errstr unless $db; - - my $statement = q( - - select branch, log_text - from build_status_log - where sysname = ? and snapshot = ? and log_stage = ? || '.log' - - ); - - - - my $sth=$db->prepare($statement); - $sth->execute($system,$logdate,$stage); - my $row=$sth->fetchrow_arrayref; - my ($branch, $logtext) = ("unknown","no log text found"); - if ($row) - { - $branch = $row->[0]; - $logtext =$row->[1]; - } - $sth->finish; - $db->disconnect; - - print "Content-Type: text/plain\n\n", $logtext, - - "-------------------------------------------------\n\n", - "Hosting for the PostgreSQL Buildfarm is generously ", - "provided by: CommandPrompt, The PostgreSQL Company"; - -} - -else -{ - print "Status: 460 bad parameters\n", - "Content-Type: text/plain\n\n"; -} - diff --git a/trunk/cgi-bin/show_status.pl b/trunk/cgi-bin/show_status.pl deleted file mode 100755 index 646195c..0000000 --- a/trunk/cgi-bin/show_status.pl +++ /dev/null @@ -1,92 +0,0 @@ -#!/usr/bin/perl - -use strict; -use DBI; -use Template; -use CGI; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport $template_dir); - - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - -my $query = new CGI; -my @members = $query->param('member'); -map { s/[^a-zA-Z0-9_ -]//g; } @members; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - - -my $sort_clause = ""; -my $sortby = $query->param('sortby') || 'nosort'; -if ($sortby eq 'name') -{ - $sort_clause = 'lower(sysname),'; -} -elsif ($sortby eq 'os') -{ - $sort_clause = 'lower(operating_system), os_version desc,'; -} -elsif ($sortby eq 'compiler') -{ - $sort_clause = "lower(compiler), compiler_version,"; -} - -my $db = DBI->connect($dsn,$dbuser,$dbpass,{pg_expand_array => 0}) - or die("$dsn,$dbuser,$dbpass,$!"); - -my $statement =<prepare($statement); -$sth->execute; -while (my $row = $sth->fetchrow_hashref) -{ - next if (@members && ! grep {$_ eq $row->{sysname} } @members); - $row->{build_flags} =~ s/^\{(.*)\}$/$1/; - $row->{build_flags} =~ s/,/ /g; - # enable-integer-datetimes is now the default - if ($row->{branch} eq 'HEAD' || $row->{branch} gt 'REL8_3_STABLE') - { - $row->{build_flags} .= " --enable-integer-datetimes " - unless ($row->{build_flags} =~ /--(en|dis)able-integer-datetimes/); - } - # enable-thread-safety is now the default - if ($row->{branch} eq 'HEAD' || $row->{branch} gt 'REL8_5_STABLE') - { - $row->{build_flags} .= " --enable-thread-safety " - unless ($row->{build_flags} =~ /--(en|dis)able-thread-safety/); - } - $row->{build_flags} =~ s/--((enable|with)-)?//g; - $row->{build_flags} =~ s/libxml/xml/; - $row->{build_flags} =~ s/\S+=\S+//g; - push(@$statrows,$row); -} -$sth->finish; - - -$db->disconnect; - - -my $template_opts = { INCLUDE_PATH => $template_dir }; -my $template = new Template($template_opts); - -print "Content-Type: text/html\n\n"; - -$template->process('status.tt', - {statrows=>$statrows}); - -exit; - diff --git a/trunk/cgi-bin/show_status_soap.pl b/trunk/cgi-bin/show_status_soap.pl deleted file mode 100755 index 5d12800..0000000 --- a/trunk/cgi-bin/show_status_soap.pl +++ /dev/null @@ -1,78 +0,0 @@ -#!/usr/bin/perl - -use strict; - - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport); - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - -use lib "/home/community/pgbuildfarm/lib/lib/perl5/site_perl"; - -use SOAP::Transport::HTTP; - -SOAP::Transport::HTTP::CGI->dispatch_to('PGBuildFarm')->handle; - -exit; - -package PGBuildFarm; - -use DBI; - -sub get_status - -{ - my $class = shift; - my @members = @_; - - my $dsn="dbi:Pg:dbname=$::dbname"; - $dsn .= ";host=$::dbhost" if $::dbhost; - $dsn .= ";port=$::dbport" if $::dbport; - - my $db = DBI->connect($dsn,$::dbuser,$::dbpass) or - die("$dsn,$::dbuser,$::dbpass,$!"); - - # there is possibly some redundancy in this query, but it makes - # a lot of the processing simpler. - - my $statement =<prepare($statement); - $sth->execute; - while (my $row = $sth->fetchrow_hashref) - { - next if (@members && ! grep {$_ eq $row->{sysname} } @members); - $row->{build_flags} =~ s/^\{(.*)\}$/$1/; - $row->{build_flags} =~ s/,/ /g; - $row->{build_flags} =~ s/--((enable|with)-)?//g; - $row->{build_flags} =~ s/\S+=\S+//g; - push(@$statrows,$row); - } - $sth->finish; - - - $db->disconnect; - - return $statrows; - -} - -1; - - - - - diff --git a/trunk/cgi-bin/test.pl b/trunk/cgi-bin/test.pl deleted file mode 100755 index 9b179d2..0000000 --- a/trunk/cgi-bin/test.pl +++ /dev/null @@ -1,24 +0,0 @@ -#!/usr/bin/perl - -#print "Content-Type: text/html\n\n"; -#print "

My quick perl hello

"; - -use CGI; - -my $query = new CGI; - -my $url = $query->url(); - -my $base = $query->url(-base=>1); - -print <connect($dsn,$dbuser,$dbpass) or die("$dsn,$dbuser,$dbpass,$!"); - -my %words; - -my $sql = q{ - select sysname, max(snapshot) as snapshot - from build_status_log - where branch = 'HEAD' and - log_stage = 'typedefs.log' and - snapshot > current_date::timestamp - interval '30 days' - group by sysname -}; -my $builds = $dbh->selectall_arrayref($sql, { Slice => {} }); - - -if ($query->param('show_list')) -{ - print "Content-Type: text/html\n\n", - "Typedefs URLs\n", - "

Typdefs URLs

\n", - "\n"; - - foreach my $build (@$builds) - { - print "\n"; - } - print "
member
$build->{sysname}
\n"; - exit; -} - -$sql = q{ - select log_text - from build_status_log - where sysname = ? - and snapshot = ? - and log_stage = 'typedefs.log' - and branch = 'HEAD' - }; - -my $sth = $dbh->prepare($sql); - -foreach my $build (@$builds) -{ - $sth->execute($build->{sysname},$build->{snapshot}); - my @row = $sth->fetchrow; - my @typedefs = split(/\s+/,$row[0]); - @words{@typedefs} = 1 x @typedefs; -} - -print "Content-Type: text/plain\n\n", - join("\n",sort keys %words), - "\n"; diff --git a/trunk/cgi-bin/upgrade.pl b/trunk/cgi-bin/upgrade.pl deleted file mode 100755 index f4cbb99..0000000 --- a/trunk/cgi-bin/upgrade.pl +++ /dev/null @@ -1,149 +0,0 @@ -#!/usr/bin/perl - -use strict; - -use CGI; -use Digest::SHA1 qw(sha1_hex); -use MIME::Base64; -use DBI; -use DBD::Pg; -use Data::Dumper; - -use vars qw($dbhost $dbname $dbuser $dbpass $dbport); - -my $query = new CGI; - -my $sig = $query->path_info; -$sig =~ s!^/!!; - -my $animal = $query->param('animal'); -my $ts = $query->param('ts'); -my $os_version = $query->param('new_os'); -my $compiler_version = $query->param('new_compiler'); - -my $content = "animal=$animal\&ts=$ts"; -$content .= "\&new_os=$os_version" if $os_version; -$content .= "\&new_compiler=$compiler_version" if $compiler_version; - -require "$ENV{BFConfDir}/BuildFarmWeb.pl"; - -die "no dbname" unless $dbname; -die "no dbuser" unless $dbuser; - -my $dsn="dbi:Pg:dbname=$dbname"; -$dsn .= ";host=$dbhost" if $dbhost; -$dsn .= ";port=$dbport" if $dbport; - -unless ($animal && $ts && ($os_version || $compiler_version) && $sig) -{ - print - "Status: 490 bad parameters\nContent-Type: text/plain\n\n", - "bad parameters for request\n"; - exit; - -} - - -my $db = DBI->connect($dsn,$dbuser,$dbpass); - -die $DBI::errstr unless $db; - -my $gethost= - "select secret from buildsystems where name = ? and status = 'approved'"; -my $sth = $db->prepare($gethost); -$sth->execute($animal); -my ($secret)=$sth->fetchrow_array(); -$sth->finish; - - -unless ($secret) -{ - print - "Status: 495 Unknown System\nContent-Type: text/plain\n\n", - "System $animal is unknown\n"; - $db->disconnect; - exit; - -} - - - - -my $calc_sig = sha1_hex($content,$secret); - -if ($calc_sig ne $sig) -{ - - print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n"; - print "$sig mismatches $calc_sig on content:\n$content"; - $db->disconnect; - exit; -} - -# undo escape-proofing of base64 data and decode it -map {tr/$@/+=/; $_ = decode_base64($_); } - ($os_version, $compiler_version); - -my $get_latest = q{ - - select coalesce(b.os_version, a.os_version) as os_version, - coalesce(b.compiler_version, a.compiler_version) as compiler_version - from buildsystems as a left join - ( select distinct on (name) name, compiler_version, os_version - from personality - order by name, effective_date desc - ) as b - on (a.name = b.name) - where a.name = ? - and a.status = 'approved' - -}; - -$sth = $db->prepare($get_latest); -my $rv = $sth->execute($animal); -unless($rv) -{ - print "Status: 460 old data fetch\nContent-Type: text/plain\n\n"; - print "error: ",$db->errstr,"\n"; - $db->disconnect; - exit; -} - -my ($old_os,$old_comp)=$sth->fetchrow_array(); -$sth->finish; - - - -$os_version ||= $old_os; -$compiler_version ||= $old_comp; - -my $new_personality = q{ - - insert into personality (name, os_version, compiler_version) - values (?,?,?) - -}; - - -$sth = $db->prepare($new_personality); -$rv = $sth->execute($animal,$os_version, $compiler_version); - -unless($rv) -{ - print "Status: 470 new data insert\nContent-Type: text/plain\n\n"; - print "error: $db->errstr\n"; - $db->disconnect; - exit; -} - -$sth->finish; - - - -$db->disconnect; - -print "Content-Type: text/plain\n\n"; -print "request was on:\n$content\n"; - - -