cgi-bin/upgrade.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4
   5 use CGI;
   6 use Digest::SHA1  qw(sha1_hex);
   7 use MIME::Base64;
   8 use DBI;
   9 use DBD::Pg;
  10 use Data::Dumper;
  11
  12 use vars qw($dbhost $dbname $dbuser $dbpass $dbport);
  13
  14 my $query = new CGI;
  15
  16 my $sig = $query->path_info;
  17 $sig =~ s!^/!!;
  18
  19 my $animal = $query->param('animal');
  20 my $ts = $query->param('ts');
  21 my $os_version = $query->param('new_os');
  22 my $compiler_version = $query->param('new_compiler');
  23
  24 my $content = "animal=$animal\&ts=$ts";
  25 $content .= "\&new_os=$os_version" if $os_version;
  26 $content .= "\&new_compiler=$compiler_version" if $compiler_version;
  27
  28 require "$ENV{BFConfDir}/BuildFarmWeb.pl";
  29
  30 die "no dbname" unless $dbname;
  31 die "no dbuser" unless $dbuser;
  32
  33 my $dsn="dbi:Pg:dbname=$dbname";
  34 $dsn .= ";host=$dbhost" if $dbhost;
  35 $dsn .= ";port=$dbport" if $dbport;
  36
  37 unless ($animal && $ts && ($os_version || $compiler_version) && $sig)
  38 {
  39         print
  40             "Status: 490 bad parameters\nContent-Type: text/plain\n\n",
  41             "bad parameters for request\n";
  42         exit;
  43
  44 }
  45
  46
  47 my $db = DBI->connect($dsn,$dbuser,$dbpass);
  48
  49 die $DBI::errstr unless $db;
  50
  51 my $gethost=
  52     "select secret from buildsystems where name = ? and status = 'approved'";
  53 my $sth = $db->prepare($gethost);
  54 $sth->execute($animal);
  55 my ($secret)=$sth->fetchrow_array();
  56 $sth->finish;
  57
  58
  59 unless ($secret)
  60 {
  61         print
  62             "Status: 495 Unknown System\nContent-Type: text/plain\n\n",
  63             "System $animal is unknown\n";
  64         $db->disconnect;
  65         exit;
  66
  67 }
  68
  69
  70
  71
  72 my $calc_sig = sha1_hex($content,$secret);
  73
  74 if ($calc_sig ne $sig)
  75 {
  76
  77         print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n";
  78         print "$sig mismatches $calc_sig on content:\n$content";
  79         $db->disconnect;
  80         exit;
  81 }
  82
  83 # undo escape-proofing of base64 data and decode it
  84 map {tr/$@/+=/; $_ = decode_base64($_); }
  85     ($os_version, $compiler_version);
  86
  87 my $get_latest = q{
  88
  89     select coalesce(b.os_version, a.os_version) as os_version,
  90            coalesce(b.compiler_version, a.compiler_version) as compiler_version
  91     from buildsystems as a left join
  92          (  select distinct on (name) name, compiler_version, os_version
  93             from personality
  94             order by name, effective_date desc
  95          ) as b
  96          on (a.name = b.name)
  97     where a.name = ?
  98           and a.status = 'approved'
  99
 100 };
 101
 102 $sth = $db->prepare($get_latest);
 103 my $rv = $sth->execute($animal);
 104 unless($rv)
 105 {
 106         print "Status: 460 old data fetch\nContent-Type: text/plain\n\n";
 107         print "error: ",$db->errstr,"\n";
 108         $db->disconnect;
 109         exit;
 110 }
 111
 112 my ($old_os,$old_comp)=$sth->fetchrow_array();
 113 $sth->finish;
 114
 115
 116
 117 $os_version ||= $old_os;
 118 $compiler_version ||= $old_comp;
 119
 120 my $new_personality = q{
 121
 122     insert into personality (name, os_version, compiler_version)
 123         values (?,?,?)
 124
 125 };
 126
 127
 128 $sth = $db->prepare($new_personality);
 129 $rv = $sth->execute($animal,$os_version, $compiler_version);
 130
 131 unless($rv)
 132 {
 133         print "Status: 470 new data insert\nContent-Type: text/plain\n\n";
 134         print "error: $db->errstr\n";
 135         $db->disconnect;
 136         exit;
 137 }
 138
 139 $sth->finish;
 140
 141
 142
 143 $db->disconnect;
 144
 145 print "Content-Type: text/plain\n\n";
 146 print "request was on:\n$content\n";
 147
 148
 149