#!/usr/bin/perl -wT

# FEX CGI for user 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 user config ERROR';
my $head = "$ENV{SERVER_NAME} F*EX user config";

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#$user",$comment);
  http_header("200 OK");
  print html_header($head);
  pq(qq(
    'An information e-mail has been sent to your subuser $subuser'
    '<p><a href="javascript:history.back()">Go back</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,"wrong user or 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,"wrong user or 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: no group name specified</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> is not a valid e-mail address'
      '<p><a href="javascript:history.back()">Go back</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(
    'A one time upload URL for <code>$otuser</code> has been created:'
    '<p>'
    '<code>$url</code>'
  ));
  unless ($nomail) {
    &notify_otuser($user,$otuser,$url,$comment);
    pq(qq(
      '<p>'
      'and an information e-mail has been sent to this address.'
      '<p>'
    ));
  }
  pq(qq(
    '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
    '</body></html>'
  ));
  exit;
}

# direct single subuser entry
if ($subuser and not $otuser) {
  if (-f "$subuser/@") {
    pq(qq(
      '<code>$subuser</code> is already a registered F*EX full user'
      '<p><a href="javascript:history.back()">Go back</a>'
      '</body></html>'
    ));
    exit;
  }
  if ($subuser !~ /^[^@]+@[\w.-]+[a-z]$/) {
    pq(qq(
      '<code>$subuser</code> is not a valid e-mail address'
      '<p><a href="javascript:history.back()">Go back</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"
        "information e-mail by the F*EX server.<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(
      'Your subuser upload URL is:'
      '<p>'
      '<code>$url</code>'
    ));
    unless ($nomail) {
      &notify_subuser($user,$subuser,$url,$comment);
      pq(qq(
        '<p>'
        'An information e-mail has been sent to $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>Edit address book</h2>'
      '<table border=0>'
      '  <tr align="left"><th>Entry:<th>alias<th>e-mail address<th># optional comment</tr>'
      '  <tr align="left"><td>Example:<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="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.'
      '<p>'
      '<a href="/foc?akey=$akey">back to F*EX operation control</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()">Go back</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 address<th>options<th>comment</tr>'
      '@abt'
      '</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;
}

if ($user and $notification eq 'detailed') {
  unlink "$user/\@NOTIFICATION";
  pq(qq(
    '<h3>Notification e-mails now come in detailed format.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">back to F*EX operation control</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 will now be displayed (if possible).<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $mime eq 'no') {
  unlink "$user/\@MIME";
  pq(qq(
    '<h3>Downloads will now be saved.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $notification eq 'short') {
  unlink "$user/\@NOTIFICATION";
  symlink "short","$user/\@NOTIFICATION";
  pq(qq(
    '<h3>Notification e-mails now come in short format.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $disclaimer) {
  my $df = "$user/\@DISCLAIMER";
  if ($disclaimer =~ /^[\s\"]*DEFAULT[\s\"]*$/i) {
    unlink $df;
    pq(qq(
      '<h3>E-mail disclaimer reset to default.</h3>'
      '<p>'
      '<a href="/foc?akey=$akey">back to F*EX operation control</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>'
      '  Disclaimer to be sent with download notification e-mail:<br>'
      '  <textarea name="disclaimer" cols="80" rows="10">$disclaimer</textarea><br>'
      '  <input type="submit" value="save">'
      '  or <a href="$ENV{SCRIPT_NAME}?akey=$akey&disclaimer=DEFAULT">'
      '  reset the disclaimer to default</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>E-mail disclaimer changed to:</h2>'
      '<pre>'
      '$disclaimer'
      '</pre>'
      '<p>'
      '<a href="/foc?akey=$akey">back to F*EX operation control</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 to you will be encrypted with the PGP/GPG key:</h2>'
      '<pre>'
      '$pk'
      '</pre>'
      '<p>'
      '<a href="/foc?akey=$akey">back to F*EX operation control</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>Your uploaded file does not contain a PGP/GPG public key for'
      '    <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 deleted.</h3>'
      '<h3>E-mails to you will be sent not encrypted.</h3>'
      '<p>'
      '<a href="/foc?akey=$akey">back to F*EX operation control</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">'
      '  Select your PGP/GPG public key file(*):<br>'
      '  <input type="file" name="pubkey" size="80">'
      '  <p>'
      '  and <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">'
        'delete your already uploaded public key</a>:'
        '<pre>'
        '$g'
        '</pre>'
      ));
    }
    pq(qq(
      '<p><hr><p>'
      '(*) To extract and verify your GPG public key use:'
      '<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>You will now get reminder notification e-mails.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
    '</body></html>'
  ));
  &reexec;
}

if ($user and $reminder eq 'no') {
  unlink "$user/\@REMINDER";
  symlink "no","$user/\@REMINDER";
  pq(qq(
    '<h3>You will now get no reminder notification e-mails.<h3>'
    '<p>'
    '<a href="/foc?akey=$akey">back to F*EX operation control</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">back to F*EX operation control</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">back to F*EX operation control</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: bad addresses:</h2>\n<ul>";
    foreach my $ba (@badaddress) { print "<li>$ba" }
    pq(qq(
      '</ul>'
      '<a href="javascript:history.back()">Go back</a>'
      '</body></html>'
    ));
    exit;
  }

  if ($ssid =~ /\S\@\w/) {
    open $idf,'>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
    print "Your subusers upload URLs are:<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>"
      "You have to give these URLs to your subusers for fexing files to you."
      "<br>"
      "Or click on the subuser's e-mail address link to send him an"
      "information e-mail by the F*EX server.<p>"
    ));
  }
  print "<a href=\"/foc?akey=$akey\">back to F*EX operation control</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">'
#   '  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!)'
# ));

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

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

pq(qq(
  '  <p><hr><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="save and show upload URLs">'
  '</form>'
  '<p>'
  '<table border=0>'
  '  <tr align="left"><td>This list has entries in format:<td>&lt;e-mail address>:&lt;encryption-ID><td></tr>'
  '  <tr align="left"><td>Example:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
  '</table>'
  '<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.'
  '<p>'
  'The encryption-ID is necessary to generate a unique upload URL for this subuser.<br>'
  'If you omit the encryption-ID a random one will be used.'
));

unless ($nomail) {
  pq(qq(
    '<p><hr><p>'
    '<h3 title="A F*EX group is similar to a mailing list, but for files">'
    'Edit your F*EX groups:</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>new group</em></a>'
    '</ul>'
  ));
}

pq(qq(
  '<p><hr><p>'
  '<a href="/foc?akey=$akey">back to F*EX operation control</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: Your upload URL'
    'X-Mailer: F*EX'
    'Content-Type: text/plain; charset=utf-8'
    'Content-Transfer-Encoding: 8bit'
    ''
    'This is an automatically generated e-mail.'
    ''
    'Use'
    ''
    '$url'
    ''
    'to upload one file to $user'
    ''
    '$comment'
    ''
    'Questions? ==> F*EX admin: $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: Your F*EX account on $server'
    'X-Mailer: F*EX'
    'Content-Type: text/plain; charset=utf-8'
    'Content-Transfer-Encoding: 8bit'
    ''
    'This is an automatically generated e-mail.'
    ''
    'A F*EX (File EXchange) account has been created for you on $server'
    'Use'
    ''
    '$url'
    ''
    'to upload files to $user'
    ''
    'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
    ''
    '$comment'
    ''
    'Questions? ==> F*EX admin: $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: Your F*EX account on $server'
    'X-Mailer: F*EX'
    ''
    'A F*EX (File EXchange) account has been created for you on $server'
    'Use'
    ''
    '$url'
    ''
    'to upload files to F*EX group "$group"'
    ''
    'See http://$ENV{HTTP_HOST}/index.html 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 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 not found 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>Notification e-mail to $notify has been sent</h2>'
      '<p><a href="javascript:history.back()">Go back</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: bad addresses:</h2>\n<ul>";
        foreach my $ba (@badaddress) { print "<li>$ba" }
        print "</ul>\n";
      }
      if (@badformat or @badaddress) {
        pq(qq(
          '<a href="javascript:history.back()">Go back</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: you are already in group \@$group owned by $user</h2>'
            '<a href="javascript:history.back()">Go back</a>'
            'and enter another group name'
            '</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 new group 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>Group \@$group has members:</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>'
          '(click address to send a notification e-mail to this user)'
        ));
      } else {
        print "<h2>Group \@$group has no members</h2>\n";
      }
      pq(qq(
        '<p>'
        '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
      ));
      print "</body></html>\n";
      exit;
    } else {
      # no group members -> delete group file
      unlink $gf;
    }
  } else {
    $gm = '';
    pq(qq(
      '<h2>Edit F*EX group</h2>'
      'A F*EX group is similar to a mailing list, but for files:<br>'
      'When a member fexes a file to this list, '
      'then all other members will receive it.'
      '<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">'
        '  New group name: <input type="text" name="group"> (You MUST fill out this field!)'
        '  </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="submit">'
      '</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>Example:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
      '</table>'
      '<p>'
      'The encryption-ID is necessary to generate a unique upload URL for this subuser.'
      'You can name any existing e-mail address.'
    ));
    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;
  }
}