trunk/cgi-bin/register.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use DBI;
   5 use Template;
   6 use CGI;
   7 use Template;
   8 use Captcha::reCAPTCHA;
   9
  10 use vars qw($dbhost $dbname $dbuser $dbpass $dbport $notifyapp $captcha_pubkey $captcha_privkey $template_dir $default_host);
  11
  12 require "$ENV{BFConfDir}/BuildFarmWeb.pl";
  13
  14 my $dsn="dbi:Pg:dbname=$dbname";
  15 $dsn .= ";host=$dbhost" if $dbhost;
  16 $dsn .= ";port=$dbport" if $dbport;
  17
  18 my $template_opts = { INCLUDE_PATH => $template_dir};
  19 my $template = new Template($template_opts);
  20 my $query = new CGI;
  21
  22 my $params = $query->Vars;
  23
  24 my ($os, $osv, $comp, $compv, $arch, $email, $owner, $challenge, $response ) = @{$params}{
  25         qw(os osv comp compv arch email owner recaptcha_challenge_field recaptcha_response_field)};
  26
  27 my $captcha = Captcha::reCAPTCHA->new;
  28 my $captcha_ok = $captcha->check_answer
  29     (
  30      $captcha_privkey,
  31      $ENV{'REMOTE_ADDR'},
  32      $challenge, $response
  33      );
  34
  35
  36 unless ($os && $osv && $comp && $compv && $arch && $email && $owner && $captcha_ok->{is_valid})
  37 {
  38     print "Content-Type: text/html\n\n";
  39     $template->process('register-incomplete.tt');
  40     exit;
  41 }
  42
  43 # some idiot has a script that tries to talk to me
  44 # this should catch and dispose of him
  45 if ((grep {/rgergerger|\@pgbuildfarm\.org|Content-Type:|http:|mailto:|href=|None|Unknown/} $os,$osv,$comp,$compv,$arch,$email,$owner)
  46     || ($email =~ /john.*\@aol.com/) )
  47 {
  48     print
  49         "Status: 403 Forbidden - go away idiot\n",
  50         "Content-Type: text/plain\n\n";
  51     exit;
  52 }
  53
  54 # count transitions to and from upper case
  55 my $trans = 1;
  56 my $counttrans = 0;
  57 foreach (split "" ,"$os$osv$comp$compv$arch$owner")
  58 {
  59         if (/[A-Z]/)
  60         {
  61                 next if $trans;
  62                 $trans = 1;
  63                 $counttrans++;
  64         }
  65         else
  66         {
  67                 next unless $trans;
  68                 $trans = 0;
  69                 $counttrans++;
  70         }
  71 }
  72
  73 # reject junk with too many transitions into/outof upper case
  74 if ($counttrans > 20)
  75 {
  76     print
  77         "Status: 403 Forbidden - go away idiot\n",
  78         "Content-Type: text/plain\n\n";
  79     exit;
  80 }
  81
  82
  83
  84 my $secret = "";
  85 my $dummyname=""; # we'll select an animal name when we approve it.
  86 foreach (1..8)
  87 {
  88         # 8 random chars is enough for the dummy name
  89         $secret .= substr("0123456789abcdefghijklmnopqrstuvwxyz",int(rand(36)),1);
  90         $dummyname .= substr("0123456789abcdef",int(rand(16)),1);
  91 }
  92 foreach (9..32)
  93 {
  94         $secret .= substr("0123456789abcdef",int(rand(16)),1);
  95 }
  96
  97 my $db = DBI->connect($dsn,$dbuser,$dbpass);
  98
  99 my $statement = <<EOS;
 100
 101   insert into buildsystems
 102     (name, secret, operating_system, os_version, compiler, compiler_version,
 103      architecture, status, sys_owner, owner_email)
 104   values(?,?,?,?,?,?,?,'pending',?,?)
 105
 106 EOS
 107 ;
 108
 109 my $sth=$db->prepare($statement);
 110 my $rv=$sth->execute($dummyname,$secret,$os,$osv,$comp,$compv,
 111                           $arch,$owner,$email);
 112 my $err=$db->errstr;
 113
 114 # everything looks OK, so tell them so
 115 print "Content-type: text/html\n\n";
 116 $template->process('register-ok.tt');
 117
 118 $sth->finish;
 119 $db->disconnect;
 120
 121
 122 use Mail::Send;
 123
 124 my $msg = new Mail::Send;
 125
 126 my $me = `id -un`; chomp($me);
 127 my $host = `hostname`; chomp ($host);
 128 $host = $default_host unless ($host =~ m/[.]/ || !defined($default_host));
 129
 130 my $from_addr = "PG Build Farm <$me\@$host>";
 131 $from_addr =~ tr /\r\n//d;
 132
 133 $msg->set('From',$from_addr);
 134
 135 $msg->to(@$notifyapp);
 136 $msg->subject('New Buildfarm Application');
 137 my $fh = $msg->open;
 138 print $fh "\n\nName: $dummyname\n",
 139     "OS: $os: $osv\n",
 140     "Arch: $arch\n",
 141     "Comp: $comp: $compv\n",
 142     "Owner: $owner <$email>\n";
 143 $fh->close;
 144
 145
 146
 147
 148
 149