#!/usr/bin/perl -wT

# FEX CGI for user registration
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: GNU General Public License

use CGI         qw(:standard);
use CGI::Carp	qw(fatalsToBrowser);
use Fcntl 	qw(:flock :seek :mode);

# import from fex.pp
our ($mdomain,$logdir,$spooldir,$fra,$hostname,$sendmail);

our $error = 'F*EX user registration ERROR';

# add fex lib
our $FEXLIB =
  $0 =~ m:(/.+)/.+/: ? "$1/lib":
  $0 =~ m:(.*/):     ? "$1/../lib":
                       "../lib";
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

# load common code, local config: $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";

my $log = "$logdir/fur.log";
my $head = "$ENV{SERVER_NAME} F*EX user registration";

chdir $spooldir or die "$spooldir - $!\n";

my $user = my $id = my $verify = '';
my ($CASE,$ESAC);

# look for CGI parameters
foreach my $v (param) {
  my $vv = strip(param($v));
  $CASE =
    $v =~ /^user$/i    ? $user = lc($vv):
    $v =~ /^verify$/i  ? $verify = lc($vv):
    $v =~ /^confirm$/i ? $confirm = $vv:
    $v =~ /^domain$/i  ? $domain = lc($vv):
  $ESAC;
}

if ($confirm) {
  if ($confirm =~ /^(\w+)$/i) {
    $confirm = $1;
  } else {
    http_die("illegal registration key");
  }
  open $confirm,'<',".reg/$confirm" or http_die("no registration key $confirm");
  chomp ($user = <$confirm>||'');
  chomp ($id   = <$confirm>||'');
  close $confirm;
  unlink ".reg/$confirm";
  unless ($user and $id) {
    http_die("no registration data for key $confirm");
  }
  &checkuser;
  unless (-d $user) {
    mkdir $user,0770 or http_die("mkdir $user - $!\n");
  }
  if (-f "$user/@") {
    http_die("$user is already activated");
  }
  open $user,'>',"$user/@" or http_die("open $user/@ - $!\n");
  print {$user} $id,"\n";  
  close $user or http_die("close $user/@ - $!\n");
  
  if (open $user,'>',"$user/.auto") {
    print {$user} "fur\n";  
    close $user;
  }
  
  http_header("200 OK");
  print html_header($head);
  pq(qq(
    '<h3>Your registration was successful. Your new F*EX account is:</h3><p>'
    ''
    '<table>'
    '  <tr><td>URL:         <td><a href="$ENV{PROTO}://$ENV{HTTP_HOST}/fup">$ENV{PROTO}://$ENV{HTTP_HOST}/fup</a></tr>'
    '  <tr><td>user/sender: <td>$user</tr>'
    '  <tr><td>auth-ID:     <td>$id</tr>'
    '</table>'
    ''
    '</body></html>'
  ));
  furlog("confirm: account $user created");
  exit;
}

unless (@local_hosts and ipin($ENV{REMOTE_ADDR}||0,@local_hosts)) {
  http_die("registrations from your host ($ENV{REMOTE_ADDR}) are not allowed");
}

unless ($user) {
  http_header("200 OK");
  print html_header($head);
  unshift @local_domains,$mdomain unless grep /^\Q$mdomain\E$/i,@local_domains;
  my @mydomains = map { "\t<option>$_</option>\n" } @local_domains;
  pq(qq(
    '<form action="$ENV{SCRIPT_NAME}"'
    '      method="post"'
    '      accept-charset="UTF-8"'
    '      enctype="multipart/form-data">'
    '  new user: <input type="text" name="user" size="40" value="$user">\@'
    '    <select name="domain" size="1">@mydomains</select><p>'
    ''
    '  (must be a valid e-mail address!)'
    '  <p><input type="submit" value="submit"><p>'
    '</form>'
    '</body></html>'
  ));
  exit;
}

&checkuser;

if (-f "$user/@") {
  html_error($error,"you are already registered");
}

unless (-d $user) {
  mkdir $user,0770 or http_die("mkdir $user - $!\n");
}

$id = randstring(6);
  
if ($verify eq 'no') {
  open $id,'>',"$user/@" or http_die("open $user/@ - $!\n");
  print {$id} $id,"\n";  
  close $id or http_die("close $user/@ - $!\n");
  http_header("200 OK",'Content-Type: text/plain');
  print "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$user&ID=$id\n";
  furlog("direct: account $user created");
  if (open my $mail,"|$sendmail fex 2>>$log") {
    pq($mail,qq(
      'From: fex'
      'To: fex'
      'Subject: F*EX user registration'
      ''
      '$user has been auto-registrated with verify=no'
    ));
    close $mail;
  } else {
    furlog("ERROR: cannot run sendmail - $!\n");
  }
  exit;
}

unless (-d '.reg') {
  mkdir '.reg',0770 or http_die("mkdir .reg - $!\n");
}
$reg = randstring(8);
open $reg,'>',".reg/$reg" or http_die("open .reg/$reg - $!\n");
print {$reg} $user,"\n",$id,"\n";
close $reg or http_die("close .reg/$reg - $!\n");

open my $mail,"|$sendmail $user,fex 2>>$log" 
  or http_die("cannot start sendmail - $!\n");
pq($mail,qq(
  'From: fex\@$hostname'
  'To: $user'
  'Subject: F*EX user registration request'
  ''
  'To activate your new F*EX account go to this URL:'
  ''
  '$ENV{PROTO}://$ENV{HTTP_HOST}/fur?confirm=$reg'
  ''
));
close $mail or http_die("cannot send mail - $!\n");

http_header("200 OK");
print html_header($head);
print "confirmation e-mail has been sent to $user\n";
print "</body></html>\n"; 
furlog("confirmation request mailed to $user");
exit;


sub strip {
  local $_ = shift;
  s/[ \t]+//g;
  s/\s*[\r\n]+\s*/\n/g;
  return $_;
}

sub checkuser {
  my $mydomains = join('|',$mdomain,@local_domains);
  $user .= '@'.$domain  if $domain and $user !~ /@/;
  $user .= '@'.$mdomain if $user !~ /@/;
  
  if ($user !~ /^[\w_=:.+-]+@/ or $user =~ /^[@.]|[<>|]|@.*@/) {
    html_error($error,"illegal character in username");
  }

  if ($user !~ /[@.]$mydomains$/) {
    html_error($error,"illegal domain for username");
  }
  
  $user = untaint($user);
}

# standard log
sub furlog {
  my $msg = "@_";
  
  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  
  if (open $log,'>>',$log) {
    flock $log,LOCK_EX;
    seek $log,0,SEEK_END;
    printf {$log} "%s %s %s\n",isodate(time),$fra,$msg;
    close $log;
  }
}
