(no commit message)
[buildfarm-server.git] / 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