Add 4.next branch
[buildfarm-server.git] / 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";