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 use FindBin qw($RealBin);
  37 require "$RealBin/../BuildFarmWeb.pl";
  38
  39 die "no dbname" unless $dbname;
  40 die "no dbuser" unless $dbuser;
  41
  42 my $dsn="dbi:Pg:dbname=$dbname";
  43 $dsn .= ";host=$dbhost" if $dbhost;
  44 $dsn .= ";port=$dbport" if $dbport;
  45
  46 unless ($animal && $ts && ($os_version || $compiler_version) && $sig)
  47 {
  48         print
  49             "Status: 490 bad parameters\nContent-Type: text/plain\n\n",
  50             "bad parameters for request\n";
  51         exit;
  52
  53 }
  54
  55
  56 my $db = DBI->connect($dsn,$dbuser,$dbpass);
  57
  58 die $DBI::errstr unless $db;
  59
  60 my $gethost=
  61     "select secret from buildsystems where name = ? and status = 'approved'";
  62 my $sth = $db->prepare($gethost);
  63 $sth->execute($animal);
  64 my ($secret)=$sth->fetchrow_array();
  65 $sth->finish;
  66
  67
  68 unless ($secret)
  69 {
  70         print
  71             "Status: 495 Unknown System\nContent-Type: text/plain\n\n",
  72             "System $animal is unknown\n";
  73         $db->disconnect;
  74         exit;
  75
  76 }
  77
  78
  79
  80
  81 my $calc_sig = sha1_hex($content,$secret);
  82
  83 if ($calc_sig ne $sig)
  84 {
  85
  86         print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n";
  87         print "$sig mismatches $calc_sig on content:\n$content";
  88         $db->disconnect;
  89         exit;
  90 }
  91
  92 # undo escape-proofing of base64 data and decode it
  93 map {tr/$@/+=/; $_ = decode_base64($_); }
  94     ($os_version, $compiler_version);
  95
  96 my $get_latest = q{
  97
  98     select coalesce(b.os_version, a.os_version) as os_version,
  99            coalesce(b.compiler_version, a.compiler_version) as compiler_version
 100     from buildsystems as a left join
 101          (  select distinct on (name) name, compiler_version, os_version
 102             from personality
 103             order by name, effective_date desc
 104          ) as b
 105          on (a.name = b.name)
 106     where a.name = ?
 107           and a.status = 'approved'
 108
 109 };
 110
 111 $sth = $db->prepare($get_latest);
 112 my $rv = $sth->execute($animal);
 113 unless($rv)
 114 {
 115         print "Status: 460 old data fetch\nContent-Type: text/plain\n\n";
 116         print "error: ",$db->errstr,"\n";
 117         $db->disconnect;
 118         exit;
 119 }
 120
 121 my ($old_os,$old_comp)=$sth->fetchrow_array();
 122 $sth->finish;
 123
 124
 125
 126 $os_version ||= $old_os;
 127 $compiler_version ||= $old_comp;
 128
 129 my $new_personality = q{
 130
 131     insert into personality (name, os_version, compiler_version)
 132         values (?,?,?)
 133
 134 };
 135
 136
 137 $sth = $db->prepare($new_personality);
 138 $rv = $sth->execute($animal,$os_version, $compiler_version);
 139
 140 unless($rv)
 141 {
 142         print "Status: 470 new data insert\nContent-Type: text/plain\n\n";
 143         print "error: $db->errstr\n";
 144         $db->disconnect;
 145         exit;
 146 }
 147
 148 $sth->finish;
 149
 150
 151
 152 $db->disconnect;
 153
 154 print "Content-Type: text/plain\n\n";
 155 print "request was on:\n$content\n";