27c9cbe5f64eba5201e303d7b081e2e4a8f3befa
[buildfarm-client.git] / EximBuild / WebTxn.pm
1 package EximBuild::WebTxn;
2
3 =comment
4
5 Copyright (c) 2003-2013, Andrew Dunstan
6
7 See accompanying License file for license details
8
9
10 Most of this code is imported from the older standalone script run_web_txn.pl
11 which is now just a shell that calls the function below. It is now only 
12 needed on older Msys installations (i.e. things running perl < 5.8).
13
14 =cut 
15
16 use strict;
17 use URI::Escape;
18
19 use vars qw($VERSION); $VERSION = 'REL_0.1';
20
21 use vars qw($changed_this_run $changed_since_success $branch $status $stage
22   $animal $ts $log_data $confsum $target $verbose $secret);
23
24 sub run_web_txn
25 {
26
27     my $lrname = shift || 'lastrun-logs';
28
29     # make these runtime imports so they are loaded by the perl that's running
30     # the procedure. On older Msys it won't be the same as the one that's
31     # running run_build.pl.
32
33     require LWP;
34     import LWP;
35     require HTTP::Request::Common;
36     import HTTP::Request::Common;
37     require MIME::Base64;
38     import MIME::Base64;
39     require Digest::SHA;
40     import Digest::SHA  qw(sha1_hex);
41     require Storable;
42     import Storable qw(nfreeze);
43
44     my $txfname = "$lrname/web-txn.data";
45     my $txdhandle;
46     $/=undef;
47     open($txdhandle,"$txfname") or die "opening $txfname: $!";
48     my $txdata = <$txdhandle>;
49     close($txdhandle);
50
51     eval $txdata;
52     if ($@)
53     {
54         warn $@;
55         return undef;
56     }
57
58     my $tarname = "$lrname/runlogs.tgz";
59     my $tardata="";
60     if (open($txdhandle,$tarname))
61     {
62         # This creates the tarball to send to the buildfarm server
63         binmode $txdhandle;
64         $tardata=<$txdhandle>;
65         close($txdhandle);
66     }
67
68     # add our own version string and time
69     my $current_ts = time;
70     my $webscriptversion = "'web_script_version' => '$VERSION',\n";
71     my $cts     = "'current_ts' => $current_ts,\n";
72
73     # $2 here helps us to preserve the nice spacing from Data::Dumper
74     my $scriptline = "((.*)'script_version' => '(REL_)?\\d+\\.\\d+',\n)";
75     $confsum =~ s/$scriptline/$1$2$webscriptversion$2$cts/;
76     my $sconf = $confsum;
77     $sconf =~ s/.*(\$Script_Config)/$1/ms;
78     my $Script_Config;
79     eval $sconf;
80
81     # very modern Storable modules choke on regexes
82     # the server has no need of them anyway, so just chop them out
83     # they are still there in the text version used for reporting
84     foreach my $k ( keys %$Script_Config )
85     {
86         delete $Script_Config->{$k}
87           if ref($Script_Config->{$k}) eq q(Regexp);
88     }
89     my $frozen_sconf = nfreeze($Script_Config);
90
91     # make the base64 data escape-proof; = is probably ok but no harm done
92     # this ensures that what is seen at the other end is EXACTLY what we
93     # see when we calculate the signature
94
95     map{ $_=encode_base64($_,""); tr/+=/$@/; }(
96         $log_data,$confsum,$changed_this_run,$changed_since_success,$tardata,
97         $frozen_sconf
98     );
99
100     my $content =
101         "changed_files=$changed_this_run&"
102       . "changed_since_success=$changed_since_success&"
103       . 'branch=' . uri_escape($branch) . "&res=$status&stage=$stage&animal=$animal&ts=$ts"
104       ."&log=$log_data&conf=$confsum";
105     my $sig = sha1_hex($content,$secret);
106
107     $content .= "&frozen_sconf=$frozen_sconf";
108
109     if ($tardata)
110     {
111         $content .= "&logtar=$tardata";
112     }
113
114     my $ua = new LWP::UserAgent;
115     $ua->agent("Exim Build Farm Reporter");
116     if (my $proxy = $ENV{BF_PROXY})
117     {
118         $ua->proxy('http',$proxy);
119     }
120
121     my $request=HTTP::Request->new(POST => "$target/$sig");
122     $request->content_type("application/x-www-form-urlencoded");
123     $request->content($content);
124
125     my $response=$ua->request($request);
126
127     unless ($response->is_success)
128     {
129         print
130           "Query for: stage=$stage&animal=$animal&ts=$ts\n",
131           "Target: $target/$sig\n";
132         print "Status Line: ",$response->status_line,"\n";
133         print "Content: \n", $response->content,"\n"
134           if ($verbose && $response->content);
135         return undef;
136     }
137
138     return 1;
139 }
140
141 1;