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