#!/usr/bin/perl -wT

# FEX CGI F&uuml;r Benutzer control
# (subuser, groups, address book, one time upload key, auth-ID, etc)
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#

BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }

use utf8;
use Fcntl 	qw(:flock);
use Digest::MD5	qw(md5_hex);

# add fex lib
($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

# import from fex.pp
our ($FEXHOME);
our ($mdomain,$admin,$hostname,$sendmail,$akeydir,$skeydir,$docdir,$durl,$bcc);
our ($nomail,$faillog);
our $akey = '';

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

my ($CASE,$ESAC);

my $error = 'F*EX ERROR Benutzer-Einstellungen';
my $head = "$ENV{SERVER_NAME} F*EX Benutzer-Einstellungen";

my $fup = $durl;
$fup =~ s:/fop:/fup:;

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

my $user = my $id = my $nid = my $ssid = my $comment = '';
my $notification = my $reminder = my $disclaimer = '';
my $encryption = my $pubkey = my $mime = '';

$akey = ''; # delete akey cookie

my $qs = $ENV{QUERY_STRING};
if ($qs) {
  if ($qs =~ /akey=(\w+)/i) { $akey = $1 }
  if ($qs =~ /ab=load/)     { $ab = 'load' }
}

# look for CGI parameters
our %PARAM;
&parse_parameters;
foreach my $v (keys %PARAM) {
  my $vv = $PARAM{$v};
  # debuglog("Param: $v=\"$vv\"");
  if ($v =~ /^akey$/i) {
    $akey = $1 if $vv =~ /^(\w+)$/;
    next;
  }
  $CASE =
    $v =~ /^user$/i 		? $user		= normalize_email($vv):
    $v =~ /^subuser$/i		? $subuser	= normalize_email($vv):
    $v =~ /^otuser$/i		? $otuser	= normalize_email($vv):
    $v =~ /^notify$/i		? $notify	= normalize_email($vv):
    $v =~ /^notification$/i	? $notification	= checkchars('parameter',$vv):
    $v =~ /^disclaimer$/i	? $disclaimer	= $vv:
    $v =~ /^encryption$/i	? $encryption	= checkchars('parameter',$vv):
    $v =~ /^pubkey$/i		? $pubkey	= $PARAM{$v}{data}:
    $v =~ /^reminder$/i		? $reminder	= checkchars('parameter',$vv):
    $v =~ /^mime$/i		? $mime		= checkchars('parameter',$vv):
    $v =~ /^comment$/i  	? $comment	= decode_utf8(normalize($vv)):
    $v =~ /^id$/i   		? $id		= checkchars('auth-ID',$vv):
    $v =~ /^nid$/i  		? $nid		= checkchars('auth-ID',$vv):
    $v =~ /^ssid$/i		? $ssid		= $vv:
    $v =~ /^group$/i		? $group	= checkchars('group',$vv):
    $v =~ /^ab$/i		? $ab		= $vv:
    $v =~ /^gm$/i		? $gm		= $vv:
    $v =~ /^show$/i		? $show		= checkchars('parameter',$vv):
  $ESAC;
}

if ($group and $group ne 'NEW') {
  $group = lc $group;
  $group =~ s/[^\w\*%^+=:,.!-]/_/g;
}
$group = '' if $nomail;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;

$nomail = $comment if $comment =~ /NOMAIL|!#!/;

if ($show and $show eq 'tools') {
  nvt_print(
    "HTTP/1.1 302 Found",
    "Location: /tools.html",
    'Expires: 0',
    'Content-Length: 0',
    ''
  );
  &reexec;
  
  if (open $tools,"$docdir/tools.html") {
    while (<$tools>) {
      while (/\$([\w_]+)\$/) {
        my $var = $1;
        my $env = $ENV{$var} || '';
        s/\$$var\$/$env/g;
      };
      print;
    }
  }
  exit;
}


if ($akey) {

  # sid is not set with web browser
  my $idf = "$akeydir/$akey/@";

  if (open $akey,'<',$idf and $id = getline($akey)) {
    close $akey;
    $idf =~ /(.*)\/\@/;
    $user = readlink $1
      or http_die("internal server error: no $akey symlink $1");
    $user =~ s:.*/::;
    $user = untaint($user);
    if ($akey ne md5_hex("$user:$id")) {
      $user = $id = '';
    }
  }
}

&check_status($user) if $user;

if ($user and $akey and $qs and $qs =~ /info=(.+?)&skey=(.+)/) {
  $subuser = $1;
  $skey = $2;
  notify_subuser($user,$subuser,"$fup?skey=$skey",$comment);
  http_header("200 OK");
  print html_header($head);
  pq(qq(
    'Eine Benachrichtiguns-E-Mail wurde gesendet zu Ihrem Subuser $subuser'
    '<p><a href="javascript:history.back()">Zur&uuml;ck</a>'
    '</body></html>'
  ));
  exit;
}


if ($user and $id) {
  if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") }
  unless (open $idf,'<',"$user/@") {
    faillog("user $from, id $id");
    html_error($error,"Falscher Benutzer oder falsche auth-ID");
  }
  $rid = getline($idf);
  close $idf;
  if ($id eq $rid) {
    unless ($akey) {
      $akey = untaint(md5_hex("$user:$id"));
      unlink "$akeydir/$akey";
      symlink "../$user","$akeydir/$akey";
    }
  } else {
    faillog("user $from, id $id");
    html_error($error,"Falscher Benutzer oder falsche auth-ID");
  }
} else {
  my $login = -x "$FEXHOME/login" ? 'login' : 'fup';
  nvt_print(
    "HTTP/1.1 302 Found",
    "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$login",
    'Expires: 0',
    'Content-Length: 0',
    ''
  );
  &reexec;
}

# empty POST? ==> back to foc
if ($ENV{REQUEST_METHOD} eq 'POST' and not
    ($subuser or $notify or $nid or $ssid or $group or $ab or $gm
     or $disclaimer or $encryption or $pubkey))
{
  nvt_print(
    "HTTP/1.1 302 Found",
    "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/foc",
    'Expires: 0',
    'Content-Length: 0',
    ''
  );
  &reexec;
}

unlink $faillog if $faillog;

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

if ($gm and not $group) {
  pq(qq(
    '<h2>ERROR: kein Gruppen-Name angegeben</h2>'
    '</body></html>'
  ));
  exit;
}

if ($group) {
  &handle_group;
}

# create one time upload key
if ($subuser and $otuser) {
  $otuser = $subuser;
  if ($otuser !~ /^[^@]+@[\w.-]+[a-z]$/) {
    pq(qq(
      '<code>$otuser</code> ist keine g&uuml;ltige E-Mail Adresse'
      '<p><a href="javascript:history.back()">Zur&uuml;ck</a>'
      '</body></html>'
    ));
    exit;
  }
  my $okey = randstring(8);
  my $okeyd = "$user/\@OKEY";
  mkdir $okeyd;
  symlink $otuser,"$okeyd/$okey"
    or http_die("cannot create OKEY $okeyd/$okey : $!\n");
  my $url = "$fup?to=$user&okey=$okey";
  pq(qq(
    'Eine einmal g&uuml;ltige upload URL f&uuml;r <code>$otuser</code> wurde angelegt:'
    '<p>'
    '<code>$url</code>'
  ));
  unless ($nomail) {
    &notify_otuser($user,$otuser,$url,$comment);
    pq(qq(
      '<p>'
      'und eine Informations-E-Mail wurde an diese Adresse verschickt.'
      '<p>'
    ));
  }
  pq(qq(
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  exit;
}

# direct single subuser entry
if ($subuser and not $otuser) {
  if (-f "$subuser/@") {
    pq(qq(
      '<code>$subuser</code> ist bereits ein registrierter F*EX Voll-Benutzer'
      '<p><a href="javascript:history.back()">Zur&uuml;ck</a>'
      '</body></html>'
    ));
    exit;
  }
  if ($subuser !~ /^[^@]+@[\w.-]+[a-z]$/) {
    pq(qq(
      '<code>$subuser</code> ist keine g&uuml;ltige E-Mail Adresse'
      '<p><a href="javascript:history.back()">Zur&uuml;ck</a>'
      '</body></html>'
    ));
    exit;
  }
  $skey = '';
  if (open $idf,'<',"$user/\@SUBUSER") {
    while (<$idf>) {
      chomp;
      if (/^\Q$subuser:/) {
        $skey = md5_hex("$user:$_");
        last;
      }
    }
    close $idf;
  }
  if ($skey) {
    my $url = "$fup?skey=$skey";
    if ($nomail) {
      pq(qq(
        '$subuser is already your subuser and has access URL:'
        '<p>'
        '<code>$url</code>'
      ));
    } else {
      pq(qq(
        '<a href=\"/fuc?akey=$akey&info=$subuser&skey=$skey\">$subuser</a>'
        'is already your subuser and has access URL:'
        '<p>'
        '<code>$url</code>'
        '<p>'
        "Click on the subuser's e-mail address link to send him an"
        "Benachrichtigungs-E-Mail mit Hilfe des F*EX-Servers zu senden.<p>"
      ));
    }
  } else {
    my $sid = randstring(8);
    my $skey = mkskey($user,$subuser,$sid);
    $url = "$fup?skey=$skey";
    open $idf,'>>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
    print {$idf} "$subuser:$sid\n";
    close $idf;
    pq(qq(
      'Ihr Subuser Upload-URL ist:'
      '<p>'
      '<code>$url</code>'
    ));
    unless ($nomail) {
      &notify_subuser($user,$subuser,$url,$comment);
      pq(qq(
        '<p>'
        'Eine Benachrichtigungs-E-Mail wurde gesendet an $subuser'
      ));
    }
  }
  print "</body></html>\n";
  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 = html_quote($_);
    }
    my $rows = ($ab =~ tr/\n//) + 5;
    pq(qq(
      '<h2>Adressbuch editieren</h2>'
      '<table border=0>'
      '  <tr align="left"><th>Eintrag:<th>Alias<th>E-Mail Adresse<th># optionaler Kommentar</tr>'
      '  <tr align="left"><td>Beispiel:<td><code>Framstag</code><td><code>framstag\@rus.uni-stuttgart.de</code><td><code># Ulli Horlacher</code></tr>'
      '</table>'
      '<form action="$ENV{SCRIPT_NAME}"'
      '      method="post"'
      '      accept-charset="UTF-8"'
      '      enctype="multipart/form-data">'
      '  <input type="hidden" name="akey" value="$akey">'
      '  <textarea name="ab" cols="160" rows="$rows">$ab</textarea><br>'
      '  <input type="submit" value="Absenden">'
      '</form>'
      '<p>'
      'Sie k&ouml;nnen diese Alias-Namen als F*EX Empf&auml;nger-Adressen auf'
      '<a href="/fup?akey=$akey">fup</a> benutzen.'
      '<p>'
      'Alternativ k&ouml;nnen Sie die Datei ADDRESS_BOOK an sich selbst '
      '($user) fexen, welche Ihre Alias-Definitionen enth&auml;lt.'
      '<p>'
      '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
      '</body></html>'
    ));
    exit;
  } else {
    $ab =~ s/[\r<>]//g;
    $ab =~ s/\s*$/\n/;

    foreach (split(/\n/,$ab)) {
      s/^\s+//;
      s/\s+$//;
      if (s/\s*(#.*)//) { $comment = $1 }
      else              { $comment = '' }
      next if /^\s*$/;
      @options = ();
      push @options,$1 if s/(autodelete=\w+)//i;
      push @options,$1 if s/(keep=\d+)//i;
      s/[,\s]+$//;
      if (s/([\S]+)\s+(\S+)//) {
        $alias = $1;
        $address = $2;
        $options = join(',',@options);
        push @abt,"<tr><td>$alias<td>$address<td>$options<td>$comment</tr>\n";
      } else {
        push @badalias,$_;
      }
    }

    if (@badalias) {
      print "<h2>ERROR: bad aliases:</h2>\n<ul>";
      foreach my $ba (@badalias) { print "<li>$ba" }
      pq(qq(
        '</ul>'
        '<p>'
        'Not in format: <code>alias e-mail-address</code>'
        '<p>'
        '<a href="javascript:history.back()">Zur&uuml;ck</a>'
        '</body></html>'
      ));
      exit;
    }

    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 Adresse<th>Optionen<th>Kommentar</tr>'
      '@abt'
      '</table>'
      '<p>'
      '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
      '<p>'
      '<a href="/fup?akey=$akey">zur&uuml;ck zu fup (F*EX Upload)</a>'
      '</body></html>'
    ));
  }
  exit;
}

if ($user and $notification eq 'detailed') {
  unlink "$user/\@NOTIFICATION";
  pq(qq(
    '<h3>Benachrichtigungs E-Mails kommen ab jetzt in detailliertem Format.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $mime eq 'yes') {
  open $mime,'>',"$user/\@MIME" or http_die("cannot write $user/\@MIME - $!\n");
  close $mime;
  pq(qq(
    '<h3>Downloads werden nun angezeigt (wenn m&ouml;glich).<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $mime eq 'no') {
  unlink "$user/\@MIME";
  pq(qq(
    '<h3>Downloads werden nun gespeichert.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $notification eq 'short') {
  unlink "$user/\@NOTIFICATION";
  symlink "short","$user/\@NOTIFICATION";
  pq(qq(
    '<h3>Benachrichtigungs E-Mails kommen ab jetzt in kurzem Format.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $disclaimer) {
  my $df = "$user/\@DISCLAIMER";
  if ($disclaimer =~ /^[\s\"]*DEFAULT[\s\"]*$/i) {
    unlink $df;
    pq(qq(
      '<h3>Der E-Mail Disclaimer wurde auf Standard zur&uuml;ckgesetzt.</h3>'
      '<p>'
      '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
      '</body></html>'
    ));
  } elsif ($disclaimer eq 'CHANGE') {
    $disclaimer = slurp($df) || '';
    $disclaimer =~ s/&/&amp;/g;
    $disclaimer =~ s/</&lt;/g;
    pq(qq(
      '<form action="$ENV{SCRIPT_NAME}"'
      '      method="post"'
      '      accept-charset="UTF-8"'
      '      enctype="multipart/form-data">'
      '  <input type="hidden" name="akey" value="$akey">'
      '  <p><hr><p>'
      '  In Benachrichtigungs E-Mail angeh&auml;ngter Disclaimer:<br>'
      '  <textarea name="disclaimer" cols="80" rows="10">$disclaimer</textarea><br>'
      '  <input type="submit" value="save">'
      '  oder <a href="$ENV{SCRIPT_NAME}?akey=$akey&disclaimer=DEFAULT">'
      '  den Disclaimer zur&uuml;cksetzen</a>.'
      '</form>'
      '</body></html>'
    ));
    exit;
  } else {
    $disclaimer =~ s/^\s+//;
    $disclaimer =~ s/\s+$/\n/;
    open $df,'>',$df or http_die("cannot write $df - $!\n");
    print {$df} $disclaimer;
    close $df;
    $disclaimer =~ s/&/&amp;/g;
    $disclaimer =~ s/</&lt;/g;
    pq(qq(
      '<h2>Der E-Mail Disclaimer wurde ge&auml;ndert auf:</h2>'
      '<pre>'
      '$disclaimer'
      '</pre>'
      '<p>'
      '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
      '</body></html>'
    ));
  }

  &reexec;
}

if ($user and $pubkey) {
  my $gf = "$user/\@GPG";
  my $pk;
  local $/;
  local $_;

  open $pk,">$gf.pk" or http_die("cannot write $gf.pk - $!\n");
  print {$pk} $pubkey;
  close $pk;
  unlink $gf;
  system "gpg --batch --no-default-keyring --keyring $gf --import".
         "< $gf.pk >/dev/null 2>&1";
  if (`gpg --batch <$gf 2>/dev/null` =~ /^pub\s.*<\Q$user\E>/sm) {
    $pk = `gpg --batch <$gf 2>&1`;
    $pk =~ s/&/&amp;/g;
    $pk =~ s/</&lt;/g;
    pq(qq(
      '<h2>E-Mails an Sie werden nun verschl&uuml;sslt mit dem PGP/GPG key:</h2>'
      '<pre>'
      '$pk'
      '</pre>'
      '<p>'
      '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
      '</body></html>'
    ));
    unlink "$gf.pk","$gf~";
  } else {
    $pk = `gpg --batch <$gf.pk 2>&1`;
    $pk =~ s/&/&amp;/g;
    $pk =~ s/</&lt;/g;
    pq(qq(
      '<h2>Die hochgeladene Datei enth&auml;lt keinen PGP/GPG public key f&uuml;r'
      '    <code>$user</code></h2>'
      '<pre>'
      '$pk'
      '</pre>'
      '<p>'
      '<a href="javascript:history.back()">back</a>'
      '</body></html>'
    ));
  }
  &reexec;
}

if ($user and $encryption) {
  my $gf = "$user/\@GPG";

  unless(-s "$ENV{HOME}/.gnupg/pubring.gpg") {
    html_error($error,"no GPG support activated");
  }

  if ($encryption eq 'DELETE') {
    unlink $gf;
    pq(qq(
      '<h3>PGP/GPG key gel&ouml;scht.</h3>'
      '<h3>E-Mails an Sie werden nun unverschl&uuml;sslt verschickt.</h3>'
      '<p>'
      '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    ));
  } elsif ($encryption eq 'CHANGE') {
    pq(qq(
      '<form action="$ENV{SCRIPT_NAME}"'
      '      method="post"'
      '      accept-charset="UTF-8"'
      '      enctype="multipart/form-data">'
      '  <input type="hidden" name="akey" value="$akey">'
      '  W&auml;hlen Sie Ihre PGP/GPG public key Datei aus(*):<br>'
      '  <input type="file" name="pubkey" size="80">'
      '  <p>'
      '  und <input type="submit" value="upload">'
      '</form>'
    ));
    if (-f $gf) {
      my $g = `gpg < $gf`;
      $g =~ s/</&lt;/g;
      pq(qq(
        'or <a href="$ENV{SCRIPT_NAME}?akey=$akey&encryption=DELETE">'
        'l&ouml;schen Sie Ihren abgelegten public key</a>:'
        '<pre>'
        '$g'
        '</pre>'
      ));
    }
    pq(qq(
      '<p><hr><p>'
      '(*) Um Ihren GPG public key zu extrahieren und verifizieren benutzen Sie:'
      '<pre>'
      'gpg -a --export $user > pubkey.gpg'
      'gpg < pubkey.gpg'
      '</pre>'
    ));
  }
  print "</body></html>\n";
  exit;
}

if ($user and $reminder eq 'yes') {
  unlink "$user/\@REMINDER";
  pq(qq(
    '<h3>Sie werden nun Erinnerung E-Mails erhalten.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $reminder eq 'no') {
  unlink "$user/\@REMINDER";
  symlink "no","$user/\@REMINDER";
  pq(qq(
    '<h3>Sie werden nun keine Erinnerung E-Mails erhalten.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($nid) {
  $nid =~ s/^\s+//;
  $nid =~ s/\s+$//;

  $nid = randstring(6) if $nid eq '?';

  open $idf,'>',"$user/@" or die "$user/@ - $!\n";
  print {$idf} $nid,"\n";
  close $idf;
  $akey = untaint(md5_hex("$user:$nid"));
  unlink "$akeydir/$akey";
  symlink "../$user","$akeydir/$akey";

  pq(qq(
    '<h3>new auth-ID "<code>$nid</code>" for $user saved</h3>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

# empty subuser list POST
if (defined($PARAM{'ssid'}) and $ssid =~ /^\s*$/) {
  unlink "$user/\@SUBUSER";
  pq(qq(
    '<h2>All subusers deleted</h2>\n<ul>'
    '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
    '</body></html>'
  ));
  &reexec;
}

# update sub-users
if ($ssid) {
  my ($subuser,$subid,$skey);

  # delete old skeys
  if (open $idf,'<',"$user/\@SUBUSER") {
    while (<$idf>) {
      s/#.*//;
      if (/(.+\@.+):(.+)/) {
        ($subuser,$subid) = ($1,$2);
        $skey = md5_hex("$user:$subuser:$subid");
        unlink "$skeydir/$skey";
        unlink "$subuser/\@MAINUSER/$user";
      }
    }
    close $idf;
  }

  $ssid = strip($ssid);

  # collect (new) subusers
  foreach (split("\n",$ssid)) {
    s/#.*//;
    s/\s//g;
    if (/(.+\@[\w.-]+)/) {
      $subuser = lc $1;
      push @badaddress,$subuser unless checkaddress($subuser);
    }
  }

  if (@badaddress) {
    print "<h2>ERROR: Fehlerhafte Adressen:</h2>\n<ul>";
    foreach my $ba (@badaddress) { print "<li>$ba" }
    pq(qq(
      '</ul>'
      '<a href="javascript:history.back()">Zur&uuml;ck</a>'
      '</body></html>'
    ));
    exit;
  }

  if ($ssid =~ /\S\@\w/) {
    open $idf,'>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
    print "Die Upload-URLs f&uuml;r Ihre Subusers sind:<p><code>\n";
    print "<table>\n";
    foreach (split("\n",$ssid)) {
      s/#.*//;
      s/\s//g;
      if (/(\S+\@[\w.-]+)/) {
        $subuser = lc $1;
        if (/:(.+)/) { $subid = $1 }
        else         { $subid = randstring(8) }
        print {$idf} "$subuser:$subid\n";
        $skey = mkskey($user,$subuser,$subid);
        print "  <tr><td><a href=\"/fuc?akey=$akey&info=$subuser&skey=$skey\">$subuser</a> :",
              "<td>$fup?skey=$skey</tr>\n";
      }
    }
    pq(qq(
      "</table>\n</code><p>"
      "Sie m&uuml;ssen diese URLs Ihren Subusers geben, damit sie Dateien an Sie fexen k&ouml;nnen."
      "<br>"
      "Oder klicken Sie auf den E-Mail Adressen-Link des Subusers, um ihm eine"
      "Benachrichtigungs-E-Mail mit Hilfe des F*EX-Servers zu senden.<p>"
    ));
  }
  print "<a href=\"/foc?akey=$akey\">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>\n";
  print "</body></html>\n";
  close $idf;
  exit;
}

if (open my $subuser,'<',"$user/\@SUBUSER") {
  local $/;
  $ssid = <$subuser> || '';
  close $subuser;
}

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

# pq(qq(
#   '  <input type="hidden" name="user" value="$user">'
#   '  <input type="hidden" name="id"   value="$id">'
#   '  Ihr F*EX Account: <b>$user:$id</b><p>'
#   '  Neue auth-ID: <input type="text" name="nid" value="$id">'
#   '  (Unbedingt die auth-ID merken wenn sie ge&auml;ndert wird!)'
# ));

if (-s "$user/\@ALLOWED_RECIPIENTS") {
  pq(qq(
    '  <p>'
    '  <input type="submit" value="Absenden">'
    '</form>'
    '</body></html>'
  ));
  exit;
}

if ($ssid) {
  $ssid = html_quote(strip($ssid));
}

pq(qq(
  '  <p><hr><p>'
  '  Ihren ausgew&auml;hlten Partnern (= Subusers) erlauben, Daten an Sie zu senden:<br>'
  '  <textarea name="ssid" cols="60" rows="10">$ssid</textarea><br>'
  '  <input type="submit" value="speichern und upload URLs anzeigen">'
  '</form>'
  '<p>'
  '<table border=0>'
  '  <tr align="left"><td>Diese Liste besteht aus Eintr&auml;gen im Format:<td>&lt;E-Mail Adresse>:&lt;encryption-ID><td></tr>'
  '  <tr align="left"><td>Beispiel:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
  '</table>'
  '<p>'
  'Diese besonderen Sender k&ouml;nnen Dateien <em>nur</em> an Sie fexen!<br>'
  'Es ist nicht notwendig, regul&auml;re FEX Benutzer zu Ihrer Liste hinzuzuf&uuml;gen'
  'weil diese bereits auch so fexen k&ouml;nnen.'
  '<p>'
  'Die encryption-ID wird f&uuml;r um eine eindeutige upload URL f&uuml;r diesen Subuser zu erzeugen.<br>'
  'Wenn Sie die encryption-ID weglassen, wird eine zuf&auml;llige gew&auml;hlt.'
));

unless ($nomail) {
  pq(qq(
    '<p><hr><p>'
    '<h3 title="Eine F*EX Gruppe ist einem E-Mail-Verteiler &auml;hnlich, allerdings eben f&uuml;r Dateien">'
    'Editieren Sie Ihre F*EX Gruppen:</h3>'
    '<ul>'
  ));

  foreach $group (glob "$user/\@GROUP/*") {
    if (-f $group and not -l $group and $group !~ /~$/) {
      $group =~ s:.*/::;
      print "  <li><a href=\"$ENV{SCRIPT_NAME}?akey=$akey&group=$group\">\@$group</a>\n";
    }
  }

  pq(qq(
    '  <li><a href="$ENV{SCRIPT_NAME}?akey=$akey&group=NEW"><em>Neue Gruppe</em></a>'
    '</ul>'
  ));
}

pq(qq(
  '<p><hr><p>'
  '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
  '</body></html>'
));

exit;


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

sub notify_otuser {
  my ($user,$otuser,$url,$comment) = @_;
  my $server = $hostname || $mdomain;
  my $sf;

  return if $nomail;

  $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
  $sf = $sender_from ? $sender_from : $user;
  open my $mail,'|-',$sendmail,'-f',$sf,$otuser,$bcc
    or http_die("cannot start sendmail - $!\n");
  pq($mail,qq(
    'From: $sf ($user via F*EX-Service $server)'
    'To: $otuser'
    'Subject: Ihre upload URL'
    'X-Mailer: F*EX'
    ''
    'Dies ist eine maschinell generierte E-Mail.'
    ''
    'Bitte benutzen Sie'
    ''
    '$url'
    ''
    'um eine Datei an $user zu schicken'
    ''
    '$comment'
    ''
    'Fragen? ==> Kontaktieren Sie den F*EX Administrator: $admin'
  ));
  close $mail
    or http_die("cannot send notification e-mail (sendmail error $!)\n");
}


sub notify_subuser {
  my ($user,$subuser,$url,$comment) = @_;
  my $server = $hostname || $mdomain;
  my $sf;

  return if $nomail;

  $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
  $sf = $sender_from ? $sender_from : $user;
  open my $mail,'|-',$sendmail,'-f',$sf,$subuser,$user,$bcc
    or http_die("cannot start sendmail - $!\n");
  pq($mail,qq(
    'From: $sf ($user via F*EX-Service $server)'
    'To: $subuser'
    'Cc: $user'
    'Subject: Ihr F*EX Account auf $server'
    'X-Mailer: F*EX'
    ''
    'Dies ist eine maschinell generierte E-Mail.'
    ''
    'Ein F*EX (File EXchange) Account ist fuer Sie angelegt worden auf $server'
    'Bitte benutzen Sie'
    ''
    '$url'
    ''
    'um Dateien an $user zu schicken'
    ''
    'Siehe http://$ENV{HTTP_HOST}/index.html fuer mehr Informationen ueber F*EX.'
    ''
    '$comment'
    ''
    'Fragen? ==> Kontaktieren Sie den F*EX Administrator: $admin'
  ));
  close $mail
    or http_die("cannot send notification e-mail (sendmail error $!)\n");
}


sub notify_groupmember {
  my ($user,$gm,$group,$id,$url) = @_;
  my $server = $hostname || $mdomain;
  my $sf;

  $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
  $sf = $sender_from ? $sender_from : $user;
  open my $mail,'|-',$sendmail,'-f',$sf,$gm,$user,$bcc
    or http_die("cannot start sendmail - $!\n");
  pq($mail,qq(
    'From: $sf ($user via F*EX-Service $hostname)'
    'To: $gm'
    'Cc: $user'
    'Subject: Ihr F*EX Account auf $server'
    'X-Mailer: F*EX'
    ''
    'Ein F*EX (File EXchange) Account ist fuer Sie angelegt worden auf $server'
    'Bitte benutzen Sie'
    ''
    '$url'
    ''
    'um Dateien fuer F*EX-Gruppe "$group" bereitzustellen'
    ''
    'Siehe http://$ENV{HTTP_HOST}/index.html fuer mehr Informationen ueber F*EX.'
    ''
    'Fragen? ==> Kontaktieren Sie den F*EX Administrator: $admin'
  ));
  close $mail
    or http_die("cannot send notification e-mail (sendmail error $!)\n");
}


sub mkskey {
  my ($user,$subuser,$id) = @_;
  my $skey = md5_hex("$user:$subuser:$id");

  open my $skf,'>',"$skeydir/$skey" or die "$skeydir/$skey - $!\n";
  print {$skf} "from=$subuser\n",
               "to=$user\n",
               "id=$id\n";
  close $skf or die "$skeydir/$skey - $!\n";
  mkdirp("$subuser/\@MAINUSER");
  symlink $skey,"$subuser/\@MAINUSER/$user";
  return $skey;
}


sub mkgkey {
  my ($user,$group,$gm,$id) = @_;
  my $gkey = untaint(md5_hex("$user:$group:$gm:$id"));

  open my $gkf,'>',"$gkeydir/$gkey" or die "$gkeydir/$gkey - $!\n";
  print {$gkf} "from=$gm\n",
               "to=\@$group\n",
               "user=$user\n",
               "id=$id\n";
  close $gkf or die "$gkeydir/$gkey - $!\n";
  return $gkey;
}


sub handle_group {
  my ($gf,$gd,$gl,$gid,$gkey);

  $group =~ s/^@+//;
  $group =~ s:[/&<>]::g;

  # $notify is group member
  if ($notify) {
    $gf = untaint("$notify/\@GROUP/$group");
    unless ($_ = readlink $gf) {
      pq(qq(
        '<h2>ERROR: cannot read $gf - $!</h2>'
        '</body></html>'
      ));
      exit;
    }
    if (m{([^/]+\@[\w.-]+)/}) {
      $user = lc $1;
    } else {
      pq(qq(
        '<h2>INTERNAL ERROR: groupfile = $gf</h2>'
        '</body></html>'
      ));
      exit;
    }
    if (open $gf,'<',$gf) {
      while (<$gf>) {
        if (/\Q$notify\E:(\S+)/i) {
          $gid = $1;
          last;
        }
      }
      close $gf;
    } else {
      pq(qq(
        '<h2>ERROR: cannot open $gf - $!</h2>'
        '</body></html>'
      ));
      exit;
    }
    unless ($gid) {
      pq(qq(
        '<h2>ERROR: $notify nicht gefunden in $gf</h2>'
        '</body></html>'
      ));
      exit;
    }
    $gkey = untaint(md5_hex("$user:$group:$notify:$gid"));
    notify_groupmember(
      $user,
      $notify,
      $group,
      $gid,
#      "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$notify&to=\@$group"
      "$fup?gkey=$gkey"
    );
    pq(qq(
      '<h2>Benachrichtigungs-E-Mail an $notify wurde gesendet</h2>'
      '<p><a href="javascript:history.back()">Zur&uuml;ck</a>'
      '</body></html>'
    ));
    exit;
  }

  $gf = untaint("$user/\@GROUP/$group");

  if (defined $gm) {
    if ($gm =~ /\S/) {
      foreach (split /\n/,$gm) {
        s/#.*//;
        s/\s//g;
        next if /^\w+=./;
        next if /^$/;
        if (s/:.+//) {
          if (/(.+@[\w\.-]+)/ and checkaddress($_)) {
            push @gm,lc $1;
          } else {
            push @badaddress,$_;
          }
        } else {
          push @badformat,$_;
        }
      }
      if (@badformat) {
        print "<h2>ERROR: lines not in format &lt;e-mail address>:&lt;encryption-ID></h2>\n<ul>";
        foreach my $ba (@badformat) { print "<li>$ba" }
        print "</ul>\n";
      }
      if (@badaddress) {
        print "<h2>ERROR: Fehlerhafte Adressen:</h2>\n<ul>";
        foreach my $ba (@badaddress) { print "<li>$ba" }
        print "</ul>\n";
      }
      if (@badformat or @badaddress) {
        pq(qq(
          '<a href="javascript:history.back()">Zur&uuml;ck</a>'
          '</body></html>'
        ));
        exit;
      }
      $gd = "$user/\@GROUP";
      unless (-d $gd or mkdir $gd,0700) {
        print "<h2>ERROR: cannot create $gd - $!</h2>\n";
        print "</body></html>\n";
        exit;
      }
      if (-l $gf) {
        if ($_ = readlink $gf and m{([^/]+\@[\w.-]+)/}) {
          $user = $1;
          pq(qq(
            '<h2>ERROR: Sie sind bereits in der Gruppe \@$group welche dem Benutzer $user geh&ouml;rt</h2>'
            '<a href="javascript:history.back()">Zur&uuml;ck</a>'
            'und geben Sie einen anderen Namen f&uuml;r die Gruppe ein'
            '</body></html>'
          ));
        } else {
          print "<h2>INTERNAL ERROR: $gf is a symlink. but not readable</h2>\n";
          print "</body></html>\n";
        }
        exit;
      }
      # delete old gkeys
      if (open $gf,'<',$gf) {
        # delete old group links and gkeys
        while (<$gf>) {
          s/#.*//;
          if (/(.+\@.+):(.+)/) {
            $gkey = untaint(md5_hex("$user:$group:$1:$2"));
            unlink "$gkeydir/$gkey";
            unlink "$1/\@GROUP/$group" if -l "$1/\@GROUP/$group";
          }
        }
        close $gf;
      }
      # write Neue Gruppe file and gkeys
      if (open $gf,'>',$gf) {
        $gm =~ s/[\r\n]+/\n/g;
        foreach (split /\n/,$gm) {
          print {$gf} "$_\n";
          s/#.*//;
          s/\s//g;
          if (/^\s*([^\/]+):(.+)/) {
            mkgkey(lc $user,$group,lc $1,$2);
          }
        }
        close $gf;
      } else {
        print "<h2>ERROR: cannot write $gf - $!</h2>\n";
        print "</body></html>\n";
        exit;
      }
      if (@gm) {
        foreach $gm (@gm) {
          next if $gm eq $user;
          unless (-d $gm or mkdir $gm,0700) {
            print "<h2>ERROR: cannot create $gm - $!</h2>\n";
            print "</body></html>\n";
            exit;
          }
          $gd = "$gm/\@GROUP";
          unless (-d $gd or mkdir $gd,0700) {
            print "<h2>ERROR: cannot create $gd - $!</h2>\n";
            print "</body></html>\n";
            exit;
          }
          $gl = "$gm/\@GROUP/$group";
          unless (-l $gl or symlink "../../$user/\@GROUP/$group",$gl) {
            print "<h2>ERROR: cannot create $gl - $!</h2>\n";
            print "</body></html>\n";
            exit;
          }
        }
        pq(qq(
          '<h2>Die Gruppe \@$group hat folgende Mitglieder:</h2>'
          '<ul>'
        ));
        foreach $gm (@gm) {
          if ($gm ne $user) {
            print "  <li><a href=\"$ENV{SCRIPT_NAME}?akey=$akey&group=$group&notify=$gm\">$gm</a>\n";
          }
        }
        pq(qq(
          '</ul>'
          '(Klicken Sie auf die Adresse um eine Benachrichtigungs-E-Mail an diesen Benutzer zu senden)'
        ));
      } else {
        print "<h2>Group \@$group has no members</h2>\n";
      }
      pq(qq(
        '<p>'
        '<a href="/foc?akey=$akey">Zur&uuml;ck zur F*EX-Bedienungssteuerung</a>'
      ));
      print "</body></html>\n";
      exit;
    } else {
      # no group members -> delete group file
      unlink $gf;
    }
  } else {
    $gm = '';
    pq(qq(
      '<h2>F*EX-Gruppe editieren</h2>'
      'Eine F*EX Gruppe ist einem E-Mail-Verteiler &auml;hnlich, allerdings eben f&uuml;r Dateien:<br>'
      'Wenn ein Mitglied eine Datei f&uuml;r die Gruppe bereitstellt, '
      'dann werden alle anderen Mitglieder diese Datei erhalten.'
      '<p>'
      '<form action="$ENV{SCRIPT_NAME}"'
      '      method="post"'
      '      accept-charset="UTF-8"'
      '      enctype="multipart/form-data">'
      '  <input type="hidden" name="akey" value="$akey">'
    ));
    if ($group eq 'NEW') {
      pq(qq(
        '  <font color="red">'
        '  Neuer Name f&uuml;r die Gruppe: <input type="text" name="group"> (Sie M&Uuml;SSEN dieses Feld ausf&uuml;llen!)'
        '  </font>'
      ));
      $gm = $user.':'.randstring(8);
    } else {
      if (open $gf,'<',$gf) {
        local $/;
        $gm = <$gf>||'';
      }
      close $gf;
      pq(qq(
        '  <input type="hidden" name="group" value="$group">'
        '  F*EX group <b>\@$group</b>:'
      ));
    }
    my $rows = ($gm =~ tr/\n//) + 5;
    pq(qq(
      '  <br><textarea name="gm" cols="80" rows="$rows">$gm</textarea><br>'
      '  <input type="submit" value="Absenden">'
      '</form>'
      '<p>'
      '<table border=0>'
      '  <tr align="left"><td>This list must have entries in format:<td>&lt;e-mail address>:&lt;encryption-ID><td></tr>'
      '  <tr align="left"><td>Beispiel:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
      '</table>'
      '<p>'
      'Die encryption-ID wird f&uuml;r um eine eindeutige upload URL f&uuml;r diesen Subuser zu erzeugen.'
      'Sie k&ouml;nnen hier eine beliebige g&uuml;ltige E-Mail Adresse angeben.'
    ));
    if (open my $ab,'<',"$user/\@ADDRESS_BOOK") {
      pq(qq(
        "<p><hr><p>"
        "<h3>Your address book:</h3>"
        "<pre>"
      ));
      while (<$ab>) {
        s/#.*//;
        print "$1\n" if /([\S]+\@[\S]+)/;
      }
      close $ab;
      print "</pre>\n";
    }
    print "</body></html>\n";
    exit;
  }
}
