]> git.treefish.org Git - fex.git/blob - cgi-bin/fuc
c18aa454fddb2f9b003cfdb0293c4ca8cf22d037
[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 BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
10
11 use Fcntl       qw(:flock);
12 use Digest::MD5 qw(md5_hex);
13
14 # add fex lib
15 ($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
16 die "$0: no $FEXLIB\n" unless -d $FEXLIB;
17
18 # import from fex.pp
19 our ($FEXHOME);
20 our ($mdomain,$admin,$hostname,$sendmail,$akeydir,$skeydir,$docdir,$durl,$bcc);
21 our ($nomail,$faillog);
22 our $akey = '';
23
24 # load common code, local config : $HOME/lib/fex.ph
25 require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
26
27 my ($CASE,$ESAC);
28
29 my $error = 'F*EX user config ERROR';
30 my $head = "$ENV{SERVER_NAME} F*EX user config";
31
32 my $fup = $durl;
33 $fup =~ s:/fop:/fup:;
34
35 chdir $spooldir or die "$spooldir - $!\n";
36
37 my $user = my $id = my $nid = my $ssid = my $comment = '';
38 my $notification = my $reminder = my $disclaimer = '';
39 my $encryption = my $pubkey = my $mime = '';
40
41 $akey = ''; # delete akey cookie
42
43 my $qs = $ENV{QUERY_STRING};
44 if ($qs) {
45   if ($qs =~ /akey=(\w+)/i) { $akey = $1 }
46   if ($qs =~ /ab=load/)     { $ab = 'load' }
47 }
48
49 # look for CGI parameters
50 our %PARAM;
51 &parse_parameters;
52 foreach my $v (keys %PARAM) {
53   my $vv = $PARAM{$v};
54   # debuglog("Param: $v=\"$vv\"");
55   if ($v =~ /^akey$/i) {
56     $akey = $1 if $vv =~ /^(\w+)$/;
57     next;
58   }
59   $CASE =
60     $v =~ /^user$/i             ? $user         = normalize_email($vv):
61     $v =~ /^subuser$/i          ? $subuser      = normalize_email($vv):
62     $v =~ /^otuser$/i           ? $otuser       = normalize_email($vv):
63     $v =~ /^notify$/i           ? $notify       = normalize_email($vv):
64     $v =~ /^notification$/i     ? $notification = checkchars('parameter',$vv):
65     $v =~ /^disclaimer$/i       ? $disclaimer   = $vv:
66     $v =~ /^encryption$/i       ? $encryption   = checkchars('parameter',$vv):
67     $v =~ /^pubkey$/i           ? $pubkey       = $PARAM{$v}{data}:
68     $v =~ /^reminder$/i         ? $reminder     = checkchars('parameter',$vv):
69     $v =~ /^mime$/i             ? $mime         = checkchars('parameter',$vv):
70     $v =~ /^comment$/i          ? $comment      = decode_utf8(normalize($vv)):
71     $v =~ /^id$/i               ? $id           = checkchars('auth-ID',$vv):
72     $v =~ /^nid$/i              ? $nid          = checkchars('auth-ID',$vv):
73     $v =~ /^ssid$/i             ? $ssid         = $vv:
74     $v =~ /^group$/i            ? $group        = checkchars('group',$vv):
75     $v =~ /^ab$/i               ? $ab           = $vv:
76     $v =~ /^gm$/i               ? $gm           = $vv:
77     $v =~ /^show$/i             ? $tools        = checkchars('parameter',$vv):
78   $ESAC;
79 }
80
81 if ($group and $group ne 'NEW') {
82   $group = lc $group;
83   $group =~ s/[^\w\*%^+=:,.!-]/_/g;
84 }
85 $group = '' if $nomail;
86 $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
87
88 $nomail = $comment if $comment =~ /NOMAIL|!#!/;
89
90 if ($akey) {
91
92   # sid is not set with web browser
93   my $idf = "$akeydir/$akey/@";
94     
95   if (open $akey,'<',$idf and $id = getline($akey)) {
96     close $akey;
97     $idf =~ /(.*)\/\@/;
98     $user = readlink $1 
99       or http_die("internal server error: no $akey symlink $1");
100     $user =~ s:.*/::;
101     $user = untaint($user);
102     if ($akey ne md5_hex("$user:$id")) {
103       $user = $id = '';
104     }
105   }
106 }
107
108 &check_status($user) if $user;
109
110 if ($user and $akey and $qs and $qs =~ /info=(.+?)&skey=(.+)/) {
111   $subuser = $1;
112   $skey = $2;
113   notify_subuser($user,$subuser,"$fup?skey=$skey",$comment);
114   http_header("200 OK");
115   print html_header($head);
116   pq(qq(
117     'An information e-mail has been sent to your subuser $subuser'
118     '<p><a href="javascript:history.back()">Go back</a>'
119     '</body></html>'
120   ));
121   exit;
122 }
123
124
125 if ($user and $id) {
126   if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") }  
127   unless (open $idf,'<',"$user/@") {
128     faillog("user $from, id $id");
129     html_error($error,"wrong user or auth-ID");
130   }
131   $rid = getline($idf);
132   close $idf;
133   if ($id eq $rid) {
134     unless ($akey) {
135       $akey = untaint(md5_hex("$user:$id"));
136       unlink "$akeydir/$akey";
137       symlink "../$user","$akeydir/$akey";
138     }
139   } else {
140     faillog("user $from, id $id");
141     html_error($error,"wrong user or auth-ID");
142   }
143 } else {
144   my $login = -x "$FEXHOME/login" ? 'login' : 'fup';
145   nvt_print(
146     "HTTP/1.1 302 Found",
147     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$login",
148     'Expires: 0',
149     'Content-Length: 0',
150     ''
151   );
152   &reexec;
153 }
154
155 # empty POST? ==> back to foc
156 if ($ENV{REQUEST_METHOD} eq 'POST' and not 
157     ($subuser or $notify or $nid or $ssid or $group or $ab or $gm or $tools
158      or $disclaimer or $encryption or $pubkey)) 
159 {
160   nvt_print(
161     "HTTP/1.1 302 Found",
162     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/foc",
163     'Expires: 0',
164     'Content-Length: 0',
165     ''
166   );
167   &reexec;
168 }
169
170 unlink $faillog if $faillog;
171
172 http_header("200 OK");
173 print html_header($head);
174 # foreach $v (keys %ENV) { print $v,' = "',$ENV{$v},"\"<br>\n" };
175
176 if ($gm and not $group) {
177   pq(qq(
178     '<h2>ERROR: no group name specified</h2>'
179     '</body></html>'
180   ));
181   exit;
182 }
183
184 if ($tools) {
185   pq(qq(
186     'To use one of the following F*EX clients you must configure them after'
187     'download:'
188     '<p>'
189     '<table border=1>'
190     '  <tr><th align=left>F*EX server:<td><code>$ENV{PROTO}://$ENV{HTTP_HOST}</code></tr>'
191     '  <tr><th align=left>Proxy:<td>(your web proxy address, may be empty)</tr>'
192     '  <tr><th align=left>User:<td><code>$user</code></tr>'
193     '  <tr><th align=left>Auth-ID:<td><code>$id</code></tr>'
194     '</table>'
195   ));
196   if (open $tools,"$docdir/tools.html") {
197     while (<$tools>) {
198       while (/\$([\w_]+)\$/) {
199         my $var = $1;
200         my $env = $ENV{$var} || '';
201         s/\$$var\$/$env/g;
202       };
203       print;
204     }
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}/ 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 }