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#$user",$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     'Content-Type: text/plain; charset=utf-8'
 849     'Content-Transfer-Encoding: 8bit'
 850     ''
 851     'This is an automatically generated e-mail.'
 852     ''
 853     'Use'
 854     ''
 855     '$url'
 856     ''
 857     'to upload one file to $user'
 858     ''
 859     '$comment'
 860     ''
 861     'Questions? ==> F*EX admin: $admin'
 862   ));
 863   close $mail
 864     or http_die("cannot send notification e-mail (sendmail error $!)\n");
 865 }
 866
 867
 868 sub notify_subuser {
 869   my ($user,$subuser,$url,$comment) = @_;
 870   my $server = $hostname || $mdomain;
 871   my $sf;
 872
 873   return if $nomail;
 874
 875   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 876   $sf = $sender_from ? $sender_from : $user;
 877   open my $mail,'|-',$sendmail,'-f',$sf,$subuser,$user,$bcc
 878     or http_die("cannot start sendmail - $!\n");
 879   pq($mail,qq(
 880     'From: $sf ($user via F*EX service $server)'
 881     'To: $subuser'
 882     'Cc: $user'
 883     'Subject: Your F*EX account on $server'
 884     'X-Mailer: F*EX'
 885     'Content-Type: text/plain; charset=utf-8'
 886     'Content-Transfer-Encoding: 8bit'
 887     ''
 888     'This is an automatically generated e-mail.'
 889     ''
 890     'A F*EX (File EXchange) account has been created for you on $server'
 891     'Use'
 892     ''
 893     '$url'
 894     ''
 895     'to upload files to $user'
 896     ''
 897     'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
 898     ''
 899     '$comment'
 900     ''
 901     'Questions? ==> F*EX admin: $admin'
 902   ));
 903   close $mail
 904     or http_die("cannot send notification e-mail (sendmail error $!)\n");
 905 }
 906
 907
 908 sub notify_groupmember {
 909   my ($user,$gm,$group,$id,$url) = @_;
 910   my $server = $hostname || $mdomain;
 911   my $sf;
 912
 913   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
 914   $sf = $sender_from ? $sender_from : $user;
 915   open my $mail,'|-',$sendmail,'-f',$sf,$gm,$user,$bcc
 916     or http_die("cannot start sendmail - $!\n");
 917   pq($mail,qq(
 918     'From: $sf ($user via F*EX service $hostname)'
 919     'To: $gm'
 920     'Cc: $user'
 921     'Subject: Your F*EX account on $server'
 922     'X-Mailer: F*EX'
 923     ''
 924     'A F*EX (File EXchange) account has been created for you on $server'
 925     'Use'
 926     ''
 927     '$url'
 928     ''
 929     'to upload files to F*EX group "$group"'
 930     ''
 931     'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
 932     ''
 933     'Questions? ==> F*EX admin: $admin'
 934   ));
 935   close $mail
 936     or http_die("cannot send notification e-mail (sendmail error $!)\n");
 937 }
 938
 939
 940 sub mkskey {
 941   my ($user,$subuser,$id) = @_;
 942   my $skey = md5_hex("$user:$subuser:$id");
 943
 944   open my $skf,'>',"$skeydir/$skey" or die "$skeydir/$skey - $!\n";
 945   print {$skf} "from=$subuser\n",
 946                "to=$user\n",
 947                "id=$id\n";
 948   close $skf or die "$skeydir/$skey - $!\n";
 949   mkdirp("$subuser/\@MAINUSER");
 950   symlink $skey,"$subuser/\@MAINUSER/$user";
 951   return $skey;
 952 }
 953
 954
 955 sub mkgkey {
 956   my ($user,$group,$gm,$id) = @_;
 957   my $gkey = untaint(md5_hex("$user:$group:$gm:$id"));
 958
 959   open my $gkf,'>',"$gkeydir/$gkey" or die "$gkeydir/$gkey - $!\n";
 960   print {$gkf} "from=$gm\n",
 961                "to=\@$group\n",
 962                "user=$user\n",
 963                "id=$id\n";
 964   close $gkf or die "$gkeydir/$gkey - $!\n";
 965   return $gkey;
 966 }
 967
 968
 969 sub handle_group {
 970   my ($gf,$gd,$gl,$gid,$gkey);
 971
 972   $group =~ s/^@+//;
 973   $group =~ s:[/&<>]::g;
 974
 975   # $notify is group member
 976   if ($notify) {
 977     $gf = untaint("$notify/\@GROUP/$group");
 978     unless ($_ = readlink $gf) {
 979       pq(qq(
 980         '<h2>ERROR: cannot read $gf - $!</h2>'
 981         '</body></html>'
 982       ));
 983       exit;
 984     }
 985     if (m{([^/]+\@[\w.-]+)/}) {
 986       $user = lc $1;
 987     } else {
 988       pq(qq(
 989         '<h2>INTERNAL ERROR: groupfile = $gf</h2>'
 990         '</body></html>'
 991       ));
 992       exit;
 993     }
 994     if (open $gf,'<',$gf) {
 995       while (<$gf>) {
 996         if (/\Q$notify\E:(\S+)/i) {
 997           $gid = $1;
 998           last;
 999         }
1000       }
1001       close $gf;
1002     } else {
1003       pq(qq(
1004         '<h2>ERROR: cannot open $gf - $!</h2>'
1005         '</body></html>'
1006       ));
1007       exit;
1008     }
1009     unless ($gid) {
1010       pq(qq(
1011         '<h2>ERROR: $notify not found in $gf</h2>'
1012         '</body></html>'
1013       ));
1014       exit;
1015     }
1016     $gkey = untaint(md5_hex("$user:$group:$notify:$gid"));
1017     notify_groupmember(
1018       $user,
1019       $notify,
1020       $group,
1021       $gid,
1022 #      "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$notify&to=\@$group"
1023       "$fup?gkey=$gkey"
1024     );
1025     pq(qq(
1026       '<h2>Notification e-mail to $notify has been sent</h2>'
1027       '<p><a href="javascript:history.back()">Go back</a>'
1028       '</body></html>'
1029     ));
1030     exit;
1031   }
1032
1033   $gf = untaint("$user/\@GROUP/$group");
1034
1035   if (defined $gm) {
1036     if ($gm =~ /\S/) {
1037       foreach (split /\n/,$gm) {
1038         s/#.*//;
1039         s/\s//g;
1040         next if /^\w+=./;
1041         next if /^$/;
1042         if (s/:.+//) {
1043           if (/(.+@[\w\.-]+)/ and checkaddress($_)) {
1044             push @gm,lc $1;
1045           } else {
1046             push @badaddress,$_;
1047           }
1048         } else {
1049           push @badformat,$_;
1050         }
1051       }
1052       if (@badformat) {
1053         print "<h2>ERROR: lines not in format &lt;e-mail address>:&lt;encryption-ID></h2>\n<ul>";
1054         foreach my $ba (@badformat) { print "<li>$ba" }
1055         print "</ul>\n";
1056       }
1057       if (@badaddress) {
1058         print "<h2>ERROR: bad addresses:</h2>\n<ul>";
1059         foreach my $ba (@badaddress) { print "<li>$ba" }
1060         print "</ul>\n";
1061       }
1062       if (@badformat or @badaddress) {
1063         pq(qq(
1064           '<a href="javascript:history.back()">Go back</a>'
1065           '</body></html>'
1066         ));
1067         exit;
1068       }
1069       $gd = "$user/\@GROUP";
1070       unless (-d $gd or mkdir $gd,0700) {
1071         print "<h2>ERROR: cannot create $gd - $!</h2>\n";
1072         print "</body></html>\n";
1073         exit;
1074       }
1075       if (-l $gf) {
1076         if ($_ = readlink $gf and m{([^/]+\@[\w.-]+)/}) {
1077           $user = $1;
1078           pq(qq(
1079             '<h2>ERROR: you are already in group \@$group owned by $user</h2>'
1080             '<a href="javascript:history.back()">Go back</a>'
1081             'and enter another group name'
1082             '</body></html>'
1083           ));
1084         } else {
1085           print "<h2>INTERNAL ERROR: $gf is a symlink. but not readable</h2>\n";
1086           print "</body></html>\n";
1087         }
1088         exit;
1089       }
1090       # delete old gkeys
1091       if (open $gf,'<',$gf) {
1092         # delete old group links and gkeys
1093         while (<$gf>) {
1094           s/#.*//;
1095           if (/(.+\@.+):(.+)/) {
1096             $gkey = untaint(md5_hex("$user:$group:$1:$2"));
1097             unlink "$gkeydir/$gkey";
1098             unlink "$1/\@GROUP/$group" if -l "$1/\@GROUP/$group";
1099           }
1100         }
1101         close $gf;
1102       }
1103       # write new group file and gkeys
1104       if (open $gf,'>',$gf) {
1105         $gm =~ s/[\r\n]+/\n/g;
1106         foreach (split /\n/,$gm) {
1107           print {$gf} "$_\n";
1108           s/#.*//;
1109           s/\s//g;
1110           if (/^\s*([^\/]+):(.+)/) {
1111             mkgkey(lc $user,$group,lc $1,$2);
1112           }
1113         }
1114         close $gf;
1115       } else {
1116         print "<h2>ERROR: cannot write $gf - $!</h2>\n";
1117         print "</body></html>\n";
1118         exit;
1119       }
1120       if (@gm) {
1121         foreach $gm (@gm) {
1122           next if $gm eq $user;
1123           unless (-d $gm or mkdir $gm,0700) {
1124             print "<h2>ERROR: cannot create $gm - $!</h2>\n";
1125             print "</body></html>\n";
1126             exit;
1127           }
1128           $gd = "$gm/\@GROUP";
1129           unless (-d $gd or mkdir $gd,0700) {
1130             print "<h2>ERROR: cannot create $gd - $!</h2>\n";
1131             print "</body></html>\n";
1132             exit;
1133           }
1134           $gl = "$gm/\@GROUP/$group";
1135           unless (-l $gl or symlink "../../$user/\@GROUP/$group",$gl) {
1136             print "<h2>ERROR: cannot create $gl - $!</h2>\n";
1137             print "</body></html>\n";
1138             exit;
1139           }
1140         }
1141         pq(qq(
1142           '<h2>Group \@$group has members:</h2>'
1143           '<ul>'
1144         ));
1145         foreach $gm (@gm) {
1146           if ($gm ne $user) {
1147             print "  <li><a href=\"$ENV{SCRIPT_NAME}?akey=$akey&group=$group&notify=$gm\">$gm</a>\n";
1148           }
1149         }
1150         pq(qq(
1151           '</ul>'
1152           '(click address to send a notification e-mail to this user)'
1153         ));
1154       } else {
1155         print "<h2>Group \@$group has no members</h2>\n";
1156       }
1157       pq(qq(
1158         '<p>'
1159         '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
1160       ));
1161       print "</body></html>\n";
1162       exit;
1163     } else {
1164       # no group members -> delete group file
1165       unlink $gf;
1166     }
1167   } else {
1168     $gm = '';
1169     pq(qq(
1170       '<h2>Edit F*EX group</h2>'
1171       'A F*EX group is similar to a mailing list, but for files:<br>'
1172       'When a member fexes a file to this list, '
1173       'then all other members will receive it.'
1174       '<p>'
1175       '<form action="$ENV{SCRIPT_NAME}"'
1176       '      method="post"'
1177       '      accept-charset="UTF-8"'
1178       '      enctype="multipart/form-data">'
1179       '  <input type="hidden" name="akey" value="$akey">'
1180     ));
1181     if ($group eq 'NEW') {
1182       pq(qq(
1183         '  <font color="red">'
1184         '  New group name: <input type="text" name="group"> (You MUST fill out this field!)'
1185         '  </font>'
1186       ));
1187       $gm = $user.':'.randstring(8);
1188     } else {
1189       if (open $gf,'<',$gf) {
1190         local $/;
1191         $gm = <$gf>||'';
1192       }
1193       close $gf;
1194       pq(qq(
1195         '  <input type="hidden" name="group" value="$group">'
1196         '  F*EX group <b>\@$group</b>:'
1197       ));
1198     }
1199     my $rows = ($gm =~ tr/\n//) + 5;
1200     pq(qq(
1201       '  <br><textarea name="gm" cols="80" rows="$rows">$gm</textarea><br>'
1202       '  <input type="submit" value="submit">'
1203       '</form>'
1204       '<p>'
1205       '<table border=0>'
1206       '  <tr align="left"><td>This list must have entries in format:<td>&lt;e-mail address>:&lt;encryption-ID><td></tr>'
1207       '  <tr align="left"><td>Example:<td><code>framstag\@rus.uni-stuttgart.de:schwuppdiwupp</code><td></tr>'
1208       '</table>'
1209       '<p>'
1210       'The encryption-ID is necessary to generate a unique upload URL for this subuser.'
1211       'You can name any existing e-mail address.'
1212     ));
1213     if (open my $ab,'<',"$user/\@ADDRESS_BOOK") {
1214       pq(qq(
1215         "<p><hr><p>"
1216         "<h3>Your address book:</h3>"
1217         "<pre>"
1218       ));
1219       while (<$ab>) {
1220         s/#.*//;
1221         print "$1\n" if /([\S]+\@[\S]+)/;
1222       }
1223       close $ab;
1224       print "</pre>\n";
1225     }
1226     print "</body></html>\n";
1227     exit;
1228   }
1229 }