cgi-bin/fuc

   1 #!/usr/bin/perl -wT
   2
   3 # FEX CGI for user control
   4 # (subuser, groups, address book, one time upload key, auth-ID, etc)
   5 #
   6 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   7 #
   8
   9 use CGI         qw(:standard);
  10 use CGI::Carp   qw(fatalsToBrowser);
  11 use Fcntl       qw(:flock);
  12 use Digest::MD5 qw(md5_hex);
  13
  14 $CGI::LIST_CONTEXT_WARN = 0;
  15 $CGI::LIST_CONTEXT_WARN = 0;
  16
  17 # add fex lib
  18 ($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
  19 die "$0: no $FEXLIB\n" unless -d $FEXLIB;
  20
  21 # import from fex.pp
  22 our ($FEXHOME);
  23 our ($mdomain,$admin,$hostname,$sendmail,$akeydir,$skeydir,$docdir,$durl,$bcc);
  24 our ($nomail,$faillog);
  25 our $akey = '';
  26
  27 # load common code, local config : $HOME/lib/fex.ph
  28 require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
  29
  30 my ($CASE,$ESAC);
  31
  32 my $error = 'F*EX user config ERROR';
  33 my $head = "$ENV{SERVER_NAME} F*EX user config";
  34
  35 my $fup = $durl;
  36 $fup =~ s:/fop:/fup:;
  37
  38 chdir $spooldir or die "$spooldir - $!\n";
  39
  40 my $user = my $id = my $nid = my $ssid = my $comment = '';
  41 my $notification = my $reminder = my $disclaimer = '';
  42 my $encryption = my $pubkey = my $mime = '';
  43
  44 $akey = ''; # delete akey cookie
  45
  46 my $qs = $ENV{QUERY_STRING};
  47 if ($qs) {
  48   if ($qs =~ /akey=(\w+)/i) { $akey = $1 }
  49   if ($qs =~ /ab=load/)     { $ab = 'load' }
  50 }
  51
  52 # look for CGI POST parameters
  53 foreach my $v (param) {
  54   my $vv = param($v);
  55   debuglog("Param: $v=\"$vv\"");
  56   if ($v =~ /^akey$/i) {
  57     $akey = $1 if $vv =~ /^(\w+)$/;
  58     next;
  59   }
  60   $CASE =
  61     $v =~ /^user$/i             ? $user         = normalize_email($vv):
  62     $v =~ /^subuser$/i          ? $subuser      = normalize_email($vv):
  63     $v =~ /^otuser$/i           ? $otuser       = normalize_email($vv):
  64     $v =~ /^notify$/i           ? $notify       = normalize_email($vv):
  65     $v =~ /^notification$/i     ? $notification = checkchars('parameter',$vv):
  66     $v =~ /^disclaimer$/i       ? $disclaimer   = $vv:
  67     $v =~ /^encryption$/i       ? $encryption   = checkchars('parameter',$vv):
  68     $v =~ /^pubkey$/i           ? $pubkey       = $vv:
  69     $v =~ /^reminder$/i         ? $reminder     = checkchars('parameter',$vv):
  70     $v =~ /^mime$/i             ? $mime         = checkchars('parameter',$vv):
  71     $v =~ /^comment$/i          ? $comment      = decode_utf8(normalize($vv)):
  72     $v =~ /^id$/i               ? $id           = checkchars('auth-ID',$vv):
  73     $v =~ /^nid$/i              ? $nid          = checkchars('auth-ID',$vv):
  74     $v =~ /^ssid$/i             ? $ssid         = $vv:
  75     $v =~ /^group$/i            ? $group        = checkchars('group',$vv):
  76     $v =~ /^ab$/i               ? $ab           = $vv:
  77     $v =~ /^gm$/i               ? $gm           = $vv:
  78     $v =~ /^show$/i             ? $tools        = checkchars('parameter',$vv):
  79   $ESAC;
  80 }
  81
  82 $group = lc $group if $group and $group ne 'NEW';
  83 $group = '' if $nomail;
  84 $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
  85
  86 $nomail = $comment if $comment =~ /NOMAIL|!#!/;
  87
  88 if ($akey) {
  89
  90   # sid is not set with web browser
  91   my $idf = "$akeydir/$akey/@";
  92
  93   if (open $akey,'<',$idf and $id = getline($akey)) {
  94     close $akey;
  95     $idf =~ /(.*)\/\@/;
  96     $user = readlink $1
  97       or http_die("internal server error: no $akey symlink $1");
  98     $user =~ s:.*/::;
  99     $user = untaint($user);
 100     if ($akey ne md5_hex("$user:$id")) {
 101       $user = $id = '';
 102     }
 103   }
 104 }
 105
 106 &check_status($user) if $user;
 107
 108 if ($user and $akey and $qs and $qs =~ /info=(.+?)&skey=(.+)/) {
 109   $subuser = $1;
 110   $skey = $2;
 111   notify_subuser($user,$subuser,"$fup?skey=$skey",$comment);
 112   http_header("200 OK");
 113   print html_header($head);
 114   pq(qq(
 115     'An information e-mail has been sent to your subuser $subuser'
 116     '<p><a href="javascript:history.back()">Go back</a>'
 117     '</body></html>'
 118   ));
 119   exit;
 120 }
 121
 122
 123 if ($user and $id) {
 124   if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") }
 125   unless (open $idf,'<',"$user/@") {
 126     faillog("user $from, id $id");
 127     html_error($error,"wrong user or auth-ID");
 128   }
 129   $rid = getline($idf);
 130   close $idf;
 131   if ($id eq $rid) {
 132     unless ($akey) {
 133       $akey = untaint(md5_hex("$user:$id"));
 134       unlink "$akeydir/$akey";
 135       symlink "../$user","$akeydir/$akey";
 136     }
 137   } else {
 138     faillog("user $from, id $id");
 139     html_error($error,"wrong user or auth-ID");
 140   }
 141 } else {
 142   my $login = -x "$FEXHOME/login" ? 'login' : 'fup';
 143   nvt_print(
 144     "HTTP/1.1 302 Found",
 145     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$login",
 146     'Expires: 0',
 147     'Content-Length: 0',
 148     ''
 149   );
 150   &reexec;
 151 }
 152
 153 # empty POST? ==> back to foc
 154 if ($ENV{REQUEST_METHOD} eq 'POST' and not
 155     ($subuser or $notify or $nid or $ssid or $group or $ab or $gm or $tools
 156      or $disclaimer or $encryption or $pubkey))
 157 {
 158   nvt_print(
 159     "HTTP/1.1 302 Found",
 160     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/foc",
 161     'Expires: 0',
 162     'Content-Length: 0',
 163     ''
 164   );
 165   &reexec;
 166 }
 167
 168 unlink $faillog if $faillog;
 169
 170 http_header("200 OK");
 171 print html_header($head);
 172 # foreach $v (keys %ENV) { print $v,' = "',$ENV{$v},"\"<br>\n" };
 173
 174 if ($gm and not $group) {
 175   pq(qq(
 176     '<h2>ERROR: no group name specified</h2>'
 177     '</body></html>'
 178   ));
 179   exit;
 180 }
 181
 182 if ($tools) {
 183   pq(qq(
 184     'To use one of the following F*EX clients you must configure them after'
 185     'download:'
 186     '<p>'
 187     '<table border=1>'
 188     '  <tr><th align=left>F*EX server:<td><code>$ENV{PROTO}://$ENV{HTTP_HOST}</code></tr>'
 189     '  <tr><th align=left>Proxy:<td>(your web proxy address, may be empty)</tr>'
 190     '  <tr><th align=left>User:<td><code>$user</code></tr>'
 191     '  <tr><th align=left>Auth-ID:<td><code>$id</code></tr>'
 192     '</table>'
 193   ));
 194   if (open $tools,"$docdir/tools.html") {
 195     while (<$tools>) {
 196       while (/\$([\w_]+)\$/) {
 197         my $var = $1;
 198         my $env = $ENV{$var} || '';
 199         s/\$$var\$/$env/g;
 200       };
 201       print;
 202     }
 203   }
 204   exit;
 205 }
 206
 207 if ($group) {
 208   &handle_group;
 209 }
 210
 211 # create one time upload key
 212 if ($subuser and $otuser) {
 213   $otuser = $subuser;
 214   if ($otuser !~ /^[^@]+@[\w.-]+[a-z]$/) {
 215     pq(qq(
 216       '<code>$otuser</code> is not a valid e-mail address'
 217       '<p><a href="javascript:history.back()">Go back</a>'
 218       '</body></html>'
 219     ));
 220     exit;
 221   }
 222   my $okey = randstring(8);
 223   my $okeyd = "$user/\@OKEY";
 224   mkdir $okeyd;
 225   symlink $otuser,"$okeyd/$okey"
 226     or http_die("cannot create OKEY $okeyd/$okey : $!\n");
 227   my $url = "$fup?to=$user&okey=$okey";
 228   pq(qq(
 229     'A one time upload URL for <code>$otuser</code> has been created:'
 230     '<p>'
 231     '<code>$url</code>'
 232   ));
 233   unless ($nomail) {
 234     &notify_otuser($user,$otuser,$url,$comment);
 235     pq(qq(
 236       '<p>'
 237       'and an information e-mail has been sent to this address.'
 238       '<p>'
 239     ));
 240   }
 241   pq(qq(
 242     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 243     '</body></html>'
 244   ));
 245   exit;
 246 }
 247
 248 # direct single subuser entry
 249 if ($subuser and not $otuser) {
 250   if (-f "$subuser/@") {
 251     pq(qq(
 252       '<code>$subuser</code> is already a registered F*EX full user'
 253       '<p><a href="javascript:history.back()">Go back</a>'
 254       '</body></html>'
 255     ));
 256     exit;
 257   }
 258   if ($subuser !~ /^[^@]+@[\w.-]+[a-z]$/) {
 259     pq(qq(
 260       '<code>$subuser</code> is not a valid e-mail address'
 261       '<p><a href="javascript:history.back()">Go back</a>'
 262       '</body></html>'
 263     ));
 264     exit;
 265   }
 266   $skey = '';
 267   if (open $idf,'<',"$user/\@SUBUSER") {
 268     while (<$idf>) {
 269       chomp;
 270       if (/^\Q$subuser:/) {
 271         $skey = md5_hex("$user:$_");
 272         last;
 273       }
 274     }
 275     close $idf;
 276   }
 277   if ($skey) {
 278     my $url = "$fup?skey=$skey";
 279     if ($nomail) {
 280       pq(qq(
 281         '$subuser is already your subuser and has access URL:'
 282         '<p>'
 283         '<code>$url</code>'
 284       ));
 285     } else {
 286       pq(qq(
 287         '<a href=\"/fuc?akey=$akey&info=$subuser&skey=$skey\">$subuser</a>'
 288         'is already your subuser and has access URL:'
 289         '<p>'
 290         '<code>$url</code>'
 291         '<p>'
 292         "Click on the subuser's e-mail address link to send him an"
 293         "information e-mail by the F*EX server.<p>"
 294       ));
 295     }
 296   } else {
 297     my $sid = randstring(8);
 298     my $skey = mkskey($user,$subuser,$sid);
 299     $url = "$fup?skey=$skey";
 300     open $idf,'>>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
 301     print {$idf} "$subuser:$sid\n";
 302     close $idf;
 303     pq(qq(
 304       'Your subuser upload URL is:'
 305       '<p>'
 306       '<code>$url</code>'
 307     ));
 308     unless ($nomail) {
 309       &notify_subuser($user,$subuser,$url,$comment);
 310       pq(qq(
 311         '<p>'
 312         'An information e-mail has been sent to $subuser'
 313       ));
 314     }
 315   }
 316   print "</body></html>\n";
 317   exit;
 318 }
 319
 320 # modify addressbook
 321 if ($user and $akey and defined $ab) {
 322   if ($ab eq 'load') {
 323     $ab = '';
 324     if (open $ab,'<',"$user/\@ADDRESS_BOOK") {
 325       undef $/;
 326       $_ = <$ab>;
 327       s/\s*$/\n/;
 328       close $ab;
 329       $ab = html_quote($_);
 330     }
 331     my $rows = ($ab =~ tr/\n//) + 5;
 332     pq(qq(
 333       '<h2>Edit address book</h2>'
 334       '<table border=0>'
 335       '  <tr align="left"><th>Entry:<th>alias<th>e-mail address<th># optional comment</tr>'
 336       '  <tr align="left"><td>Example:<td><code>Framstag</code><td><code>framstag\@rus.uni-stuttgart.de</code><td><code># Ulli Horlacher</code></tr>'
 337       '</table>'
 338       '<form action="$ENV{SCRIPT_NAME}"'
 339       '      method="post"'
 340       '      accept-charset="UTF-8"'
 341       '      enctype="multipart/form-data">'
 342       '  <input type="hidden" name="akey" value="$akey">'
 343       '  <textarea name="ab" cols="160" rows="$rows">$ab</textarea><br>'
 344       '  <input type="submit" value="submit">'
 345       '</form>'
 346       '<p>'
 347       'You may use these alias names as F*EX recipient addresses on '
 348       '<a href="/fup?akey=$akey">fup</a>'
 349       '<p>'
 350       'Alternatively you can fex a file ADDRESS_BOOK to yourself '
 351       '($user) containing your alias definitions.'
 352       '<p>'
 353       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 354       '</body></html>'
 355     ));
 356   } else {
 357     $ab =~ s/[\r<>]//g;
 358     $ab =~ s/\s*$/\n/;
 359
 360     foreach (split(/\n/,$ab)) {
 361       s/^\s+//;
 362       s/\s+$//;
 363       if (s/\s*(#.*)//) { $comment = $1 }
 364       else              { $comment = '' }
 365       next if /^\s*$/;
 366       @options = ();
 367       push @options,$1 if s/(autodelete=\w+)//i;
 368       push @options,$1 if s/(keep=\d+)//i;
 369       s/[,\s]+$//;
 370       if (s/([\S]+)\s+(\S+)//) {
 371         $alias = $1;
 372         $address = $2;
 373         $options = join(',',@options);
 374         push @abt,"<tr><td>$alias<td>$address<td>$options<td>$comment</tr>\n";
 375       } else {
 376         push @badalias,$_;
 377       }
 378     }
 379
 380     if (@badalias) {
 381       print "<h2>ERROR: bad aliases:</h2>\n<ul>";
 382       foreach my $ba (@badalias) { print "<li>$ba" }
 383       pq(qq(
 384         '</ul>'
 385         '<p>'
 386         'Not in format: <code>alias e-mail-address</code>'
 387         '<p>'
 388         '<a href="javascript:history.back()">Go back</a>'
 389         '</body></html>'
 390       ));
 391       exit;
 392     }
 393
 394     open my $AB,'>',"$user/\@ADDRESS_BOOK"
 395       or http_die("cannot open $user/\@ADDRESS_BOOK - $!\n");
 396     print {$AB} $ab;
 397     close $AB;
 398     pq(qq(
 399       '<h2><a href ="/fuc?AB=load&akey=$akey">address book</a></h2>'
 400       '<table border=1>'
 401       '<tr><th>alias<th>e-mail address<th>options<th>comment</tr>'
 402       '@abt'
 403       '</table>'
 404       '<p>'
 405       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 406       '<p>'
 407       '<a href="/fup?akey=$akey">back to fup (F*EX upload)</a>'
 408       '</body></html>'
 409     ));
 410   }
 411   exit;
 412 }
 413
 414 if ($user and $notification eq 'detailed') {
 415   unlink "$user/\@NOTIFICATION";
 416   pq(qq(
 417     '<h3>Notification e-mails now come in detailed format.<h3>'
 418     '<p>'
 419     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 420     '</body></html>'
 421   ));
 422   &reexec;
 423 }
 424
 425 if ($user and $mime eq 'yes') {
 426   open $mime,'>',"$user/\@MIME" or http_die("cannot write $user/\@MIME - $!\n");
 427   close $mime;
 428   pq(qq(
 429     '<h3>Downloads will now be displayed (if possible).<h3>'
 430     '<p>'
 431     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 432     '</body></html>'
 433   ));
 434   &reexec;
 435 }
 436
 437 if ($user and $mime eq 'no') {
 438   unlink "$user/\@MIME";
 439   pq(qq(
 440     '<h3>Downloads will now be saved.<h3>'
 441     '<p>'
 442     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 443     '</body></html>'
 444   ));
 445   &reexec;
 446 }
 447
 448 if ($user and $notification eq 'short') {
 449   unlink "$user/\@NOTIFICATION";
 450   symlink "short","$user/\@NOTIFICATION";
 451   pq(qq(
 452     '<h3>Notification e-mails now come in short format.<h3>'
 453     '<p>'
 454     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 455     '</body></html>'
 456   ));
 457   &reexec;
 458 }
 459
 460 if ($user and $disclaimer) {
 461   my $df = "$user/\@DISCLAIMER";
 462   if ($disclaimer =~ /^[\s\"]*DEFAULT[\s\"]*$/i) {
 463     unlink $df;
 464     pq(qq(
 465       '<h3>E-mail disclaimer reset to default.</h3>'
 466       '<p>'
 467       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 468       '</body></html>'
 469     ));
 470   } elsif ($disclaimer eq 'CHANGE') {
 471     $disclaimer = slurp($df) || '';
 472     $disclaimer =~ s/&/&amp;/g;
 473     $disclaimer =~ s/</&lt;/g;
 474     pq(qq(
 475       '<form action="$ENV{SCRIPT_NAME}"'
 476       '      method="post"'
 477       '      accept-charset="UTF-8"'
 478       '      enctype="multipart/form-data">'
 479       '  <input type="hidden" name="akey" value="$akey">'
 480       '  <p><hr><p>'
 481       '  Disclaimer to be sent with download notification e-mail:<br>'
 482       '  <textarea name="disclaimer" cols="80" rows="10">$disclaimer</textarea><br>'
 483       '  <input type="submit" value="save">'
 484       '  or <a href="$ENV{SCRIPT_NAME}?akey=$akey&disclaimer=DEFAULT">'
 485       '  reset the disclaimer to default</a>.'
 486       '</form>'
 487       '</body></html>'
 488     ));
 489     exit;
 490   } else {
 491     $disclaimer =~ s/^\s+//;
 492     $disclaimer =~ s/\s+$/\n/;
 493     open $df,'>',$df or http_die("cannot write $df - $!\n");
 494     print {$df} $disclaimer;
 495     close $df;
 496     $disclaimer =~ s/&/&amp;/g;
 497     $disclaimer =~ s/</&lt;/g;
 498     pq(qq(
 499       '<h2>E-mail disclaimer changed to:</h2>'
 500       '<pre>'
 501       '$disclaimer'
 502       '</pre>'
 503       '<p>'
 504       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 505       '</body></html>'
 506     ));
 507   }
 508
 509   &reexec;
 510 }
 511
 512 if ($user and $pubkey) {
 513   my $gf = "$user/\@GPG";
 514   my $pk;
 515   local $/;
 516   local $_;
 517
 518   open $gf,">$gf.pk" or http_die("cannot write $gf - $!\n");
 519   print {$gf} <$pubkey>;
 520   close $gf;
 521   unlink $gf;
 522   system "gpg --batch --no-default-keyring --keyring $gf --import".
 523          "< $gf.pk >/dev/null 2>&1";
 524   if (`gpg --batch <$gf 2>/dev/null` =~ /^pub\s.*<\Q$user\E>/sm) {
 525     $pk = `gpg --batch <$gf 2>&1`;
 526     $pk =~ s/&/&amp;/g;
 527     $pk =~ s/</&lt;/g;
 528     pq(qq(
 529       '<h2>E-mails to you will be encrypted with the PGP/GPG key:</h2>'
 530       '<pre>'
 531       '$pk'
 532       '</pre>'
 533       '<p>'
 534       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 535       '</body></html>'
 536     ));
 537     unlink "$gf.pk","$gf~";
 538   } else {
 539     $pk = `gpg --batch <$gf.pk 2>&1`;
 540     $pk =~ s/&/&amp;/g;
 541     $pk =~ s/</&lt;/g;
 542     pq(qq(
 543       '<h2>Your uploaded file does not contain a PGP/GPG public key for'
 544       '    <code>$user</code></h2>'
 545       '<pre>'
 546       '$pk'
 547       '</pre>'
 548       '<p>'
 549       '<a href="javascript:history.back()">back</a>'
 550       '</body></html>'
 551     ));
 552   }
 553   &reexec;
 554 }
 555
 556 if ($user and $encryption) {
 557   my $gf = "$user/\@GPG";
 558
 559   unless(-s "$ENV{HOME}/.gnupg/pubring.gpg") {
 560     html_error($error,"no GPG support activated");
 561   }
 562
 563   if ($encryption eq 'DELETE') {
 564     unlink $gf;
 565     pq(qq(
 566       '<h3>PGP/GPG key deleted.</h3>'
 567       '<h3>E-mails to you will be sent not encrypted.</h3>'
 568       '<p>'
 569       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 570       '</body></html>'
 571     ));
 572   } elsif ($encryption eq 'CHANGE') {
 573     pq(qq(
 574       '<form action="$ENV{SCRIPT_NAME}"'
 575       '      method="post"'
 576       '      accept-charset="UTF-8"'
 577       '      enctype="multipart/form-data">'
 578       '  <input type="hidden" name="akey" value="$akey">'
 579       '  Select your PGP/GPG public key file(*):<br>'
 580       '  <input type="file" name="pubkey" size="80">'
 581       '  <p>'
 582       '  and <input type="submit" value="upload">'
 583       '</form>'
 584     ));
 585     if (-f $gf) {
 586       my $g = `gpg < $gf`;
 587       $g =~ s/</&lt;/g;
 588       pq(qq(
 589         'or <a href="$ENV{SCRIPT_NAME}?akey=$akey&encryption=DELETE">'
 590         'delete your already uploaded public key</a>:'
 591         '<pre>'
 592         '$g'
 593         '</pre>'
 594         '<p><hr><p>'
 595         '(*) To extract and verify your GPG public key use:'
 596         '<pre>'
 597         'gpg -a --export $user > pubkey.gpg'
 598         'gpg < pubkey.gpg'
 599         '</pre>'
 600       ));
 601     }
 602     print "</body></html>\n";
 603     exit;
 604   }
 605
 606   &reexec;
 607 }
 608
 609 if ($user and $reminder eq 'yes') {
 610   unlink "$user/\@REMINDER";
 611   pq(qq(
 612     '<h3>You will now get reminder notification e-mails.<h3>'
 613     '<p>'
 614     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 615     '</body></html>'
 616   ));
 617   &reexec;
 618 }
 619
 620 if ($user and $reminder eq 'no') {
 621   unlink "$user/\@REMINDER";
 622   symlink "no","$user/\@REMINDER";
 623   pq(qq(
 624     '<h3>You will now get no reminder notification e-mails.<h3>'
 625     '<p>'
 626     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 627     '</body></html>'
 628   ));
 629   &reexec;
 630 }
 631
 632 if ($nid) {
 633   $nid =~ s/^\s+//;
 634   $nid =~ s/\s+$//;
 635
 636   $nid = randstring(6) if $nid eq '?';
 637
 638   open $idf,'>',"$user/@" or die "$user/@ - $!\n";
 639   print {$idf} $nid,"\n";
 640   close $idf;
 641   $akey = untaint(md5_hex("$user:$nid"));
 642   unlink "$akeydir/$akey";
 643   symlink "../$user","$akeydir/$akey";
 644
 645   pq(qq(
 646     '<h3>new auth-ID "<code>$nid</code>" for $user saved</h3>'
 647     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 648     '</body></html>'
 649   ));
 650   exit;
 651 }
 652
 653 # empty subuser list POST
 654 if (defined(param('ssid')) and $ssid =~ /^\s*$/) {
 655   unlink "$user/\@SUBUSER";
 656   pq(qq(
 657     '<h2>All subusers deleted</h2>\n<ul>'
 658     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 659     '</body></html>'
 660   ));
 661   exit;
 662 }
 663
 664 # update sub-users
 665 if ($ssid) {
 666   my ($subuser,$subid,$skey);
 667
 668   # delete old skeys
 669   if (open $idf,'<',"$user/\@SUBUSER") {
 670     while (<$idf>) {
 671       s/#.*//;
 672       if (/(.+\@.+):(.+)/) {
 673         ($subuser,$subid) = ($1,$2);
 674         $skey = md5_hex("$user:$subuser:$subid");
 675         unlink "$skeydir/$skey";
 676         unlink "$subuser/\@MAINUSER/$user";
 677       }
 678     }
 679     close $idf;
 680   }
 681
 682   $ssid = strip($ssid);
 683
 684   # collect (new) subusers
 685   foreach (split("\n",$ssid)) {
 686     s/#.*//;
 687     s/\s//g;
 688     if (/(.+\@[\w.-]+)/) {
 689       $subuser = lc $1;
 690       push @badaddress,$subuser unless checkaddress($subuser);
 691     }
 692   }
 693
 694   if (@badaddress) {
 695     print "<h2>ERROR: bad addresses:</h2>\n<ul>";
 696     foreach my $ba (@badaddress) { print "<li>$ba" }
 697     pq(qq(
 698       '</ul>'
 699       '<a href="javascript:history.back()">Go back</a>'
 700       '</body></html>'
 701     ));
 702     exit;
 703   }
 704
 705   if ($ssid =~ /\S\@\w/) {
 706     open $idf,'>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
 707     print "Your subusers upload URLs are:<p><code>\n";
 708     print "<table>\n";
 709     foreach (split("\n",$ssid)) {
 710       s/#.*//;
 711       s/\s//g;
 712       if (/(\S+\@[\w.-]+)/) {
 713         $subuser = lc $1;
 714         if (/:(.+)/) { $subid = $1 }
 715         else         { $subid = randstring(8) }
 716         print {$idf} "$subuser:$subid\n";
 717         $skey = mkskey($user,$subuser,$subid);
 718         print "  <tr><td><a href=\"/fuc?akey=$akey&info=$subuser&skey=$skey\">$subuser</a> :",
 719               "<td>$fup?skey=$skey</tr>\n";
 720       }
 721     }
 722     pq(qq(
 723       "</table>\n</code><p>"
 724       "You have to give these URLs to your subusers for fexing files to you."
 725       "<br>"
 726       "Or click on the subuser's e-mail address link to send him an"
 727       "information e-mail by the F*EX server.<p>"
 728     ));
 729   }
 730   print "<a href=\"/foc?akey=$akey\">back to F*EX operation control</a>\n";
 731   print "</body></html>\n";
 732   close $idf;
 733   exit;
 734 }
 735
 736 if (open my $subuser,'<',"$user/\@SUBUSER") {
 737   local $/;
 738   $ssid = <$subuser> || '';
 739   close $subuser;
 740 }
 741
 742 # display HTML form and request user data
 743 pq(qq(
 744   '<form action="$ENV{SCRIPT_NAME}"'
 745   '      method="post"'
 746   '      accept-charset="UTF-8"'
 747   '      enctype="multipart/form-data">'
 748   '  <input type="hidden" name="akey" value="$akey">'
 749 ));
 750
 751 # pq(qq(
 752 #   '  <input type="hidden" name="user" value="$user">'
 753 #   '  <input type="hidden" name="id"   value="$id">'
 754 #   '  Your F*EX account: <b>$user:$id</b><p>'
 755 #   '  New auth-ID: <input type="text" name="nid" value="$id">'
 756 #   '  (Remember your auth-ID when you change it!)'
 757 # ));
 758
 759 if (-s "$user/\@ALLOWED_RECIPIENTS") {
 760   pq(qq(
 761     '  <p>'
 762     '  <input type="submit" value="submit">'
 763     '</form>'
 764     '</body></html>'
 765   ));
 766   exit;
 767 }
 768
 769 if ($ssid) {
 770   $ssid = html_quote(strip($ssid));
 771 }
 772
 773 pq(qq(
 774   '  <p><hr><p>'
 775   '  Allow special senders (= subusers) to fex files to you:<br>'
 776   '  <textarea name="ssid" cols="60" rows="10">$ssid</textarea><br>'
 777   '  <input type="submit" value="save and show upload URLs">'
 778   '</form>'
 779   '<p>'
 780   '<table border=0>'
 781   '  <tr align="left"><td>This list has entries in format:<td>&lt;e-mail address>:&lt;encryption-ID><td></tr>'
 782   '  <tr align="left"><td>Example:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
 783   '</table>'
 784   '<p>'
 785   'These special senders may fex files <em>only</em> to you!<br>'
 786   'It is not necessary to add regular fex users to your list,'
 787   'because they already can fex.'
 788   '<p>'
 789   'The encryption-ID is necessary to generate a unique upload URL for this subuser.<br>'
 790   'If you omit the encryption-ID a random one will be used.'
 791 ));
 792
 793 unless ($nomail) {
 794   pq(qq(
 795     '<p><hr><p>'
 796     '<h3 title="A F*EX group is similar to a mailing list, but for files">'
 797     'Edit your F*EX groups:</h3>'
 798     '<ul>'
 799   ));
 800
 801   foreach $group (glob "$user/\@GROUP/*") {
 802     if (-f $group and not -l $group and $group !~ /~$/) {
 803       $group =~ s:.*/::;
 804       print "  <li><a href=\"$ENV{SCRIPT_NAME}?akey=$akey&group=$group\">\@$group</a>\n";
 805     }
 806   }
 807
 808   pq(qq(
 809     '  <li><a href="$ENV{SCRIPT_NAME}?akey=$akey&group=NEW"><em>new group</em></a>'
 810     '</ul>'
 811   ));
 812 }
 813
 814 pq(qq(
 815   '<p><hr><p>'
 816   '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 817   '</body></html>'
 818 ));
 819
 820 exit;
 821
 822
 823 sub strip {
 824   local $_ = shift;
 825   s/[ \t]+//g;
 826   s/\s*[\r\n]+\s*/\n/g;
 827   return $_;
 828 }
 829
 830 sub notify_otuser {
 831   my ($user,$otuser,$url,$comment) = @_;
 832   my $server = $hostname || $mdomain;
 833   my $sf;
 834
 835   return if $nomail;
 836
 837   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 838   $sf = $sender_from ? $sender_from : $user;
 839   open my $mail,'|-',$sendmail,'-f',$sf,$otuser,$bcc
 840     or http_die("cannot start sendmail - $!\n");
 841   pq($mail,qq(
 842     'From: $sf ($user via F*EX service $server)'
 843     'To: $otuser'
 844     'Subject: Your upload URL'
 845     'X-Mailer: F*EX'
 846     ''
 847     'This is an automatically generated e-mail.'
 848     ''
 849     'Use'
 850     ''
 851     '$url'
 852     ''
 853     'to upload one file to $user'
 854     ''
 855     '$comment'
 856     ''
 857     'Questions? ==> F*EX admin: $admin'
 858   ));
 859   close $mail
 860     or http_die("cannot send notification e-mail (sendmail error $!)\n");
 861 }
 862
 863
 864 sub notify_subuser {
 865   my ($user,$subuser,$url,$comment) = @_;
 866   my $server = $hostname || $mdomain;
 867   my $sf;
 868
 869   return if $nomail;
 870
 871   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 872   $sf = $sender_from ? $sender_from : $user;
 873   open my $mail,'|-',$sendmail,'-f',$sf,$subuser,$user,$bcc
 874     or http_die("cannot start sendmail - $!\n");
 875   pq($mail,qq(
 876     'From: $sf ($user via F*EX service $server)'
 877     'To: $subuser'
 878     'Cc: $user'
 879     'Subject: Your F*EX account on $server'
 880     'X-Mailer: F*EX'
 881     ''
 882     'This is an automatically generated e-mail.'
 883     ''
 884     'A F*EX (File EXchange) account has been created for you on $server'
 885     'Use'
 886     ''
 887     '$url'
 888     ''
 889     'to upload files to $user'
 890     ''
 891     'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
 892     ''
 893     '$comment'
 894     ''
 895     'Questions? ==> F*EX admin: $admin'
 896   ));
 897   close $mail
 898     or http_die("cannot send notification e-mail (sendmail error $!)\n");
 899 }
 900
 901
 902 sub notify_groupmember {
 903   my ($user,$gm,$group,$id,$url) = @_;
 904   my $server = $hostname || $mdomain;
 905   my $sf;
 906
 907   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 908   $sf = $sender_from ? $sender_from : $user;
 909   open my $mail,'|-',$sendmail,'-f',$sf,$gm,$user,$bcc
 910     or http_die("cannot start sendmail - $!\n");
 911   pq($mail,qq(
 912     'From: $sf ($user via F*EX service $hostname)'
 913     'To: $gm'
 914     'Cc: $user'
 915     'Subject: Your F*EX account on $server'
 916     'X-Mailer: F*EX'
 917     ''
 918     'A F*EX (File EXchange) account has been created for you on $server'
 919     'Use'
 920     ''
 921     '$url'
 922     ''
 923     'to upload files to F*EX group "$group"'
 924     ''
 925     'See http://$ENV{HTTP_HOST}/ for more information about F*EX.'
 926     ''
 927     'Questions? ==> F*EX admin: $admin'
 928   ));
 929   close $mail
 930     or http_die("cannot send notification e-mail (sendmail error $!)\n");
 931 }
 932
 933
 934 sub mkskey {
 935   my ($user,$subuser,$id) = @_;
 936   my $skey = md5_hex("$user:$subuser:$id");
 937
 938   open my $skf,'>',"$skeydir/$skey" or die "$skeydir/$skey - $!\n";
 939   print {$skf} "from=$subuser\n",
 940                "to=$user\n",
 941                "id=$id\n";
 942   close $skf or die "$skeydir/$skey - $!\n";
 943   mkdirp("$subuser/\@MAINUSER");
 944   symlink $skey,"$subuser/\@MAINUSER/$user";
 945   return $skey;
 946 }
 947
 948
 949 sub mkgkey {
 950   my ($user,$group,$gm,$id) = @_;
 951   my $gkey = untaint(md5_hex("$user:$group:$gm:$id"));
 952
 953   open my $gkf,'>',"$gkeydir/$gkey" or die "$gkeydir/$gkey - $!\n";
 954   print {$gkf} "from=$gm\n",
 955                "to=\@$group\n",
 956                "user=$user\n",
 957                "id=$id\n";
 958   close $gkf or die "$gkeydir/$gkey - $!\n";
 959   return $gkey;
 960 }
 961
 962
 963 sub handle_group {
 964   my ($gf,$gd,$gl,$gid,$gkey);
 965
 966   $group =~ s/^@+//;
 967   $group =~ s:[/&<>]::g;
 968
 969   # $notify is group member
 970   if ($notify) {
 971     $gf = untaint("$notify/\@GROUP/$group");
 972     unless ($_ = readlink $gf) {
 973       pq(qq(
 974         '<h2>ERROR: cannot read $gf - $!</h2>'
 975         '</body></html>'
 976       ));
 977       exit;
 978     }
 979     if (m{([^/]+\@[\w.-]+)/}) {
 980       $user = lc $1;
 981     } else {
 982       pq(qq(
 983         '<h2>INTERNAL ERROR: groupfile = $gf</h2>'
 984         '</body></html>'
 985       ));
 986       exit;
 987     }
 988     if (open $gf,'<',$gf) {
 989       while (<$gf>) {
 990         if (/\Q$notify\E:(\S+)/i) {
 991           $gid = $1;
 992           last;
 993         }
 994       }
 995       close $gf;
 996     } else {
 997       pq(qq(
 998         '<h2>ERROR: cannot open $gf - $!</h2>'
 999         '</body></html>'
1000       ));
1001       exit;
1002     }
1003     unless ($gid) {
1004       pq(qq(
1005         '<h2>ERROR: $notify not found in $gf</h2>'
1006         '</body></html>'
1007       ));
1008       exit;
1009     }
1010     $gkey = untaint(md5_hex("$user:$group:$notify:$gid"));
1011     notify_groupmember(
1012       $user,
1013       $notify,
1014       $group,
1015       $gid,
1016 #      "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$notify&to=\@$group"
1017       "$fup?gkey=$gkey"
1018     );
1019     pq(qq(
1020       '<h2>Notification e-mail to $notify has been sent</h2>'
1021       '<p><a href="javascript:history.back()">Go back</a>'
1022       '</body></html>'
1023     ));
1024     exit;
1025   }
1026
1027   $gf = untaint("$user/\@GROUP/$group");
1028
1029   if (defined $gm) {
1030     if ($gm =~ /\S/) {
1031       foreach (split /\n/,$gm) {
1032         s/#.*//;
1033         s/\s//g;
1034         next if /^\w+=./;
1035         next if /^$/;
1036         if (s/:.+//) {
1037           if (/(.+@[\w\.-]+)/ and checkaddress($_)) {
1038             push @gm,lc $1;
1039           } else {
1040             push @badaddress,$_;
1041           }
1042         } else {
1043           push @badformat,$_;
1044         }
1045       }
1046       if (@badformat) {
1047         print "<h2>ERROR: lines not in format &lt;e-mail address>:&lt;encryption-ID></h2>\n<ul>";
1048         foreach my $ba (@badformat) { print "<li>$ba" }
1049         print "</ul>\n";
1050       }
1051       if (@badaddress) {
1052         print "<h2>ERROR: bad addresses:</h2>\n<ul>";
1053         foreach my $ba (@badaddress) { print "<li>$ba" }
1054         print "</ul>\n";
1055       }
1056       if (@badformat or @badaddress) {
1057         pq(qq(
1058           '<a href="javascript:history.back()">Go back</a>'
1059           '</body></html>'
1060         ));
1061         exit;
1062       }
1063       $gd = "$user/\@GROUP";
1064       unless (-d $gd or mkdir $gd,0700) {
1065         print "<h2>ERROR: cannot create $gd - $!</h2>\n";
1066         print "</body></html>\n";
1067         exit;
1068       }
1069       if (-l $gf) {
1070         if ($_ = readlink $gf and m{([^/]+\@[\w.-]+)/}) {
1071           $user = $1;
1072           pq(qq(
1073             '<h2>ERROR: you are already in group \@$group owned by $user</h2>'
1074             '<a href="javascript:history.back()">Go back</a>'
1075             'and enter another group name'
1076             '</body></html>'
1077           ));
1078         } else {
1079           print "<h2>INTERNAL ERROR: $gf is a symlink. but not readable</h2>\n";
1080           print "</body></html>\n";
1081         }
1082         exit;
1083       }
1084       # delete old gkeys
1085       if (open $gf,'<',$gf) {
1086         # delete old group links and gkeys
1087         while (<$gf>) {
1088           s/#.*//;
1089           if (/(.+\@.+):(.+)/) {
1090             $gkey = untaint(md5_hex("$user:$group:$1:$2"));
1091             unlink "$gkeydir/$gkey";
1092             unlink "$1/\@GROUP/$group" if -l "$1/\@GROUP/$group";
1093           }
1094         }
1095         close $gf;
1096       }
1097       # write new group file and gkeys
1098       if (open $gf,'>',$gf) {
1099         $gm =~ s/[\r\n]+/\n/g;
1100         foreach (split /\n/,$gm) {
1101           print {$gf} "$_\n";
1102           s/#.*//;
1103           s/\s//g;
1104           if (/^\s*([^\/]+):(.+)/) {
1105             mkgkey(lc $user,$group,lc $1,$2);
1106           }
1107         }
1108         close $gf;
1109       } else {
1110         print "<h2>ERROR: cannot write $gf - $!</h2>\n";
1111         print "</body></html>\n";
1112         exit;
1113       }
1114       if (@gm) {
1115         foreach $gm (@gm) {
1116           next if $gm eq $user;
1117           unless (-d $gm or mkdir $gm,0700) {
1118             print "<h2>ERROR: cannot create $gm - $!</h2>\n";
1119             print "</body></html>\n";
1120             exit;
1121           }
1122           $gd = "$gm/\@GROUP";
1123           unless (-d $gd or mkdir $gd,0700) {
1124             print "<h2>ERROR: cannot create $gd - $!</h2>\n";
1125             print "</body></html>\n";
1126             exit;
1127           }
1128           $gl = "$gm/\@GROUP/$group";
1129           unless (-l $gl or symlink "../../$user/\@GROUP/$group",$gl) {
1130             print "<h2>ERROR: cannot create $gl - $!</h2>\n";
1131             print "</body></html>\n";
1132             exit;
1133           }
1134         }
1135         pq(qq(
1136           '<h2>Group \@$group has members:</h2>'
1137           '<ul>'
1138         ));
1139         foreach $gm (@gm) {
1140           if ($gm ne $user) {
1141             print "  <li><a href=\"$ENV{SCRIPT_NAME}?akey=$akey&group=$group&notify=$gm\">$gm</a>\n";
1142           }
1143         }
1144         pq(qq(
1145           '</ul>'
1146           '(click address to send a notification e-mail to this user)'
1147         ));
1148       } else {
1149         print "<h2>Group \@$group has no members</h2>\n";
1150       }
1151       pq(qq(
1152         '<p>'
1153         '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
1154       ));
1155       print end_html();
1156       exit;
1157     } else {
1158       # no group members -> delete group file
1159       unlink $gf;
1160     }
1161   } else {
1162     $gm = '';
1163     pq(qq(
1164       '<h2>Edit F*EX group</h2>'
1165       'A F*EX group is similar to a mailing list, but for files:<br>'
1166       'When a member fexes a file to this list, '
1167       'then all other members will receive it.'
1168       '<p>'
1169       '<form action="$ENV{SCRIPT_NAME}"'
1170       '      method="post"'
1171       '      accept-charset="UTF-8"'
1172       '      enctype="multipart/form-data">'
1173       '  <input type="hidden" name="akey" value="$akey">'
1174     ));
1175     if ($group eq 'NEW') {
1176       pq(qq(
1177         '  <font color="red">'
1178         '  New group name: <input type="text" name="group"> (You MUST fill out this field!)'
1179         '  </font>'
1180       ));
1181     } else {
1182       if (open $gf,'<',$gf) {
1183         local $/;
1184         $gm = <$gf>||'';
1185       }
1186       close $gf;
1187       pq(qq(
1188         '  <input type="hidden" name="group" value="$group">'
1189         '  F*EX group <b>\@$group</b>:'
1190       ));
1191     }
1192     my $rows = ($gm =~ tr/\n//) + 5;
1193     pq(qq(
1194       '  <br><textarea name="gm" cols="80" rows="$rows">$gm</textarea><br>'
1195       '  <input type="submit" value="submit">'
1196       '</form>'
1197       '<p>'
1198       '<table border=0>'
1199       '  <tr align="left"><td>This list must have entries in format:<td>&lt;e-mail address>:&lt;encryption-ID><td></tr>'
1200       '  <tr align="left"><td>Example:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
1201       '</table>'
1202       '<p>'
1203       'The encryption-ID is necessary to generate a unique upload URL for this subuser.'
1204       'You can name any existing e-mail address.'
1205     ));
1206     if (open my $ab,'<',"$user/\@ADDRESS_BOOK") {
1207       pq(qq(
1208         "<p><hr><p>"
1209         "<h3>Your address book:</h3>"
1210         "<pre>"
1211       ));
1212       while (<$ab>) {
1213         s/#.*//;
1214         print "$1\n" if /([\S]+\@[\S]+)/;
1215       }
1216       close $ab;
1217       print "</pre>\n";
1218     }
1219     print "</body></html>\n";
1220     exit;
1221   }
1222 }