#!/usr/bin/perl -wT

# FEX CGI for user control
#
# 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);
use Digest::MD5	qw(md5_hex);

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

our ($mdomain,$admin,$hostname,$sendmail);

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

my $error = 'F*EX user config ERROR';
my $head = "$ENV{SERVER_NAME} F*EX user config";

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

my $akeydir = "$spooldir/.akeys"; 
my $ra = untaint($ENV{REMOTE_ADDR});
my ($CASE,$ESAC);

my $user = my $id = my $nid = my $ssid = '';

my $qs = $ENV{QUERY_STRING};
if ($qs) {
  if ($qs =~ /akey=(\w+)/i) { 
    $akey = $1;
    if (open $akey,'<',"$akeydir/$ra:$akey/@" and $id = <$akey>) {
      chomp $id;
      close $akey;
      $user = readlink "$akeydir/$ra:$akey"
        or http_die("internal server error: no $akey symlink");
      $user =~ s:.*/::;
      $user = untaint($user);
      if ($akey ne md5_hex("$user:$id")) {
        $user = $id = '';
      }
    }
  }
  if ($qs =~ /ab=load/) { 
    $ab = 'load';
  }
  if ($user and $akey and $qs =~ /info=(.+?)&skey=(.+)/) { 
    $subuser = $1;
    $skey = $2;
    notify_subuser($user,$subuser,
                   "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?skey=$skey");
    http_header("200 OK");
    print html_header($head);
    print "An information e-mail has been sent to your sub-user $subuser .\n";
    print "</body></html>\n";
    exit;
  }
}

# look for CGI POST parameters
foreach my $v (param) {
  $vv = param($v);
  $CASE =
    $v =~ /^user$/i 	? $user = fuc_normalize($vv):
    $v =~ /^subuser$/i	? $subuser = fuc_normalize($vv):
    $v =~ /^id$/i   	? $id = $vv:
    $v =~ /^nid$/i  	? $nid = $vv:
    $v =~ /^ssid$/i	? $ssid = $vv:
    $v =~ /^ab$/i	? $ab = $vv:
  $ESAC;
}

$user .= '@'.$mdomain if $user !~ /@/;

if ($user and $id) {
  open $idf,'<',"$user/@" or html_error($error,"wrong user or auth-ID");
  $rid = <$idf> || '';
  close $idf;
  chomp $rid;
  if ($id eq $rid) {
    unless ($akey) {
      $akey = untaint(md5_hex("$user:$id"));
      symlink "../$user","$akeydir/$ra:$akey";
    }
  } else {
    html_error($error,"wrong user or auth-ID");
  }
}

http_header("200 OK");
print html_header($head);
# foreach $v (keys %ENV) { print $v,' = "',$ENV{$v},"\"<br>\n" };

# direct single subuser entry
if ($user and $id and $subuser) {
  if (-f "$subuser/@") {
    print "<tt>$subuser</tt> is already a registered F*EX full user\n",
          "</body></html>\n";
    exit;
  }
  if ($subuser !~ /^[^@]+@[\w.-]+[a-z]$/) {
    print "<tt>$subuser</tt> is not a valid e-mail address\n",
          "</body></html>\n";
    exit;
  }
  if (open $idf,'<',"$user/@") {
    $_ = <$idf>;
    while (<$idf>) {
      chomp;
      if (s/^\Q$subuser://) {
        $sid = $_;
        last;
      }
    }
    close $idf;
  }
  if ($sid) {
    my $skey = md5_hex("$subuser:$sid");
    $url = "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?skey=$skey";
#   $url = "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?to=$user&from=$subuser&id=$sid";
    pq(qq(
      'Your sub-user upload URL is:'
      '<p>'
      '<tt>$url</tt>'
      '</body></html>'
    ));
  } else {
    my $sid = randstring(8);
    my $skey = mkskey($user,$subuser,$sid);
    $url = "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?skey=$skey";
    open $idf,'>>',"$user/@" or die "$user/@ - $!\n";
    print {$idf} "$subuser:$sid\n";
    close $idf;
    &notify_subuser($user,$subuser,$url);
    pq(qq(
      'Your sub-user upload URL is:'
      '<p>'
      '<tt>$url</tt>'
      '<p>'
      'An information e-mail has been sent to $subuser'
      '<p>'
      '<a href="/foc/?akey=$akey">add more sub-users</a>'
      '</body></html>'
    ));
  }
  exit;
}

# modify addressbook
if ($user and $akey and defined $ab) {
  if ($ab eq 'load') {
    $ab = '';
    if (open $ab,'<',"$user/\@ADDRESS_BOOK") {
      undef $/;
      $_ = <$ab>;
      s/\s*$/\n/;
      close $ab;
      $ab = $_;
    }
    my $rows = ($ab =~ tr/\n//) + 5;
    pq(qq(
      '<h2>edit address book</h2>'
      '<table border=1>'
      '  <tr align="left"><th>Entry:<th>alias<th>e-mail address<th># optional comment</tr>'
      '  <tr align="left"><td>Example:<td><tt>Framstag</tt><td><tt>framstag\@rus.uni-stuttgart.de</tt><td><tt># Ulli Horlacher</tt></tr>'
      '</table>'
      '<form action="$ENV{SCRIPT_NAME}?akey=$akey"'
      '      method="post"'
      '      accept-charset="UTF-8"'
      '      enctype="multipart/form-data">'
      '  <textarea name="ab" cols="80" rows="$rows">$ab</textarea><br>'
      '  <input type="submit" value="submit">'
      '</form>'
      '<p>'
      'You may use these alias names as F*EX recipient addresses on '
      '<a href ="/fup?akey=$akey">fup</a>.'
      '<p>'
      'Alternatively you can fex a file ADDRESS_BOOK to yourself '
      '($user) containing your alias definitions.'
      '</body></html>'
    ));
  } else {
    $ab =~ s/[\r<>]//g;
    $ab =~ s/\s*$/\n/;
    open my $AB,'>',"$user/\@ADDRESS_BOOK" 
      or http_die("cannot open $user/\@ADDRESS_BOOK - $!\n");
    print {$AB} $ab;
    close $AB;
    pq(qq(
      '<h2><a href ="/fuc?AB=load&akey=$akey">address book</a></h2>'
      '<table border=1>'
      '<tr><th>alias<th>e-mail address<th>options<th>comment</tr>'
    ));
    foreach (split(/\n/,$ab)) {
      s/^\s+//;
      s/\s+$//;
      if (s/\s*(#.*)//) { $comment = $1 }
      else              { $comment = '' }
      @options = ();
      push @options,$1 if s/(autodelete=\w+)//i;
      push @options,$1 if s/(keep=\d+)//i;
      s/[,\s]+$//;
      if (s/([\S]+)\s+([\S]+\@[\w.-]+)//) {
        $alias = $1;
        $address = $2;
        $options = join(',',@options);
        print "<tr><td>$alias<td>$address<td>$options<td>$comment</tr>\n";
      }
    }
    pq(qq(
      '</table>'
      '<p>'
      '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
      '<p>'
      '<a href="/fup?akey=$akey">back to fup (F*EX upload)</a>'
      '</body></html>'
    ));
  }
  exit;
}

# update data set
if ($user and $id and $nid) {
  my ($subuser,$subid,$skey);
  
  # delete old skeys
  if (open $idf,"$user/@") {
    while (<$idf>) {
      if (/(.+\@.+):(.+)/) {
        ($subuser,$subid) = ($1,$2);
        $skey = md5_hex("$subuser:$subid");
        unlink ".skeys/$skey";
      }
    }
    close $idf;
  }

  $nid =~ s/^\s+//;
  $nid =~ s/\s+$//;
  
  open $idf,'>',"$user/@" or die "$user/@ - $!\n";
  print {$idf} $nid,"\n";
  
  print "<h3>FEX config updated for $user</h3>\n";
  $ssid = strip($ssid);
  if ($ssid =~ /\@.+:/) {
    print "Your subusers upload URLs are:<p><tt>\n";
    print "<table>\n";
    foreach (split("\n",$ssid)) {
      if (/(.+\@.+):(.+)/) {
        ($subuser,$subid) = ($1,$2);
        print {$idf} "$subuser:$subid\n";
        unless (/^#/) {
          if ($subuser =~ /\*/) {
            print "  <tr><td>$subuser :",
                    "<td>$ENV{PROTO}://$ENV{HTTP_HOST}/fup?",
                        "to=$user&id=$subid</tr>\n";
          } else {
            $skey = mkskey($user,$subuser,$subid);
            print "  <tr><td><a href=\"/fuc?akey=$akey&info=$subuser&skey=$skey\">$subuser</a> :",
                    "<td>$ENV{PROTO}://$ENV{HTTP_HOST}/fup?skey=$skey</tr>\n";
          }
        }
      }
    }
    print "</table>\n</tt><p>\n";
    print "You have to give these URLs to your subusers for fexing files to you.",
          " Or click on the subuser's e-mail address link to send him an",
          " information e-mail by the F*EX server.<p>\n";
  }
  print "<a href=\"/foc?akey=$akey\">back to F*EX operation control</a>\n";
  print "</body></html>\n"; 
  close $idf;
  exit;
}

if (open F,'<',"$user/@") {
  $_ = <F>;
  local $/;
  $ssid = <F> || '';
  close F;
}

# display HTML form and request user data
pq(qq(
  '<form action="$ENV{SCRIPT_NAME}"'
  '      method="post"'
  '      accept-charset="UTF-8"'
  '      enctype="multipart/form-data">'
));

# not authentificated yet?
unless ($user and $id) {
  $user = '' if $user =~ /^@/;
  pq(qq(
    '  <table>'
    '    <tr><td>user:'
    '        <td><input type="text"     name="user" size="40" value="$user"></tr>'
    '    <tr><td>auth-ID:'
    '        <td><input type="password" name="id"   size="16" value="$id"></tr>'
    '  </table>'
    '  <p>'
    '  <b>Beware!</b> On the next page, all IDs will be displayed in clear text!'
    '  <p>'
    '  <input type="submit" value="continue">'
    '</form>'
    '</body></html>'
  ));
  exit;
}

$ssid = strip($ssid) if $ssid;

pq(qq(
  '  <input type="hidden" name="user" value="$user">'
  '  <input type="hidden" name="id"   value="$id">'
));
pq(qq(
  '  Your F*EX account: <b>$user:$id</b><p>'
  '  New auth-ID: <input type="text" name="nid" value="$id">'
  '  (Remember your auth-ID when you change it!)'
));
pq(qq(
  '  <p>'
  '  Allow special senders (= subusers) to fex files to you:<br>'
  '  <textarea name="ssid" cols="60" rows="10">$ssid</textarea><br>'
  '  <input type="submit" value="submit and continue">'
  '</form>'
  '<p>'
  'This table consists of extries of type SENDER-E-MAIL-ADDRESS:SENDER-AUTH-ID<br>'
  'You define the SENDER-AUTH-ID (pseudo password).<br>'
  '<p>'
  'Example: <tt>sender\@example.org:schwuppdiwupp</tt>'
  '<p>'
  'These special senders may fex files <em>only</em> to you!<br>'
  'It is not necessary to add regular fex users to your list,'
  'because they already can fex.'
  '</body></html>'
));

exit;


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

sub notify_subuser {
  my ($from,$subuser,$url) = @_;
  my $server = $hostname || $mdomain;
  
  $from .= '@'.$mdomain if $from !~ /@/;
  open my $mail,"|$sendmail -f '$from' $subuser,fex" 
    or http_die("cannot start sendmail - $!\n");
  pq($mail,qq(
    'From: $from ($from via F*EX service $server)'
    'To: $subuser'
    'Subject: your F*EX account'
    ''
    'A F*EX account has been created for you. Use'
    ''
    '$url'
    ''
    'to upload files to $from'
    ''
    'See http://$ENV{HTTP_HOST}/ for more information about F*EX.'
    ''
    'Questions? ==> F*EX admin: $admin'
  ));
  close $mail
    or http_die("cannot send notification e-mail (sendmail error $!)\n");
}

sub fuc_normalize {
  local $_ = shift;
  
  s/\s//g;
  s/[^\w_.+=\@\-]//g;
  /(.*)/;
  return $1;
}

sub mkskey {
  my ($user,$subuser,$id) = @_;
  my $skey = md5_hex("$subuser:$id");
  
  mkdirp("$spooldir/.skeys");
  open $skf,'>',".skeys/$skey" or die ".skeys/$skey - $!\n";
  print {$skf} "from=$subuser\n",
               "to=$user\n",
               "id=$id\n";
  close $skf or die ".skeys/$skey - $!\n";
  return $skey;
}
