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