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         # untested. Please notify hs@schlittermann.de, if you
 119         # encounter any problem here:
 120         $ua->proxy(URI->new($target)->scheme, $proxy);
 121     }
 122
 123     my $request=HTTP::Request->new(POST => "$target/$sig");
 124     $request->content_type("application/x-www-form-urlencoded");
 125     $request->content($content);
 126
 127     my $response=$ua->request($request);
 128
 129     unless ($response->is_success)
 130     {
 131         print
 132           "Query for: stage=$stage&animal=$animal&ts=$ts\n",
 133           "Target: $target/$sig\n";
 134         print "Status Line: ",$response->status_line,"\n";
 135         print "Content: \n", $response->content,"\n"
 136           if ($verbose && $response->content);
 137         return undef;
 138     }
 139
 140     return 1;
 141 }
 142
 143 1;