]> git.treefish.org Git - fex.git/blob - cgi-bin/fuc
Original release 20150120
[fex.git] / 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 }