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