cgi-bin/upgrade.pl

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