]> git.treefish.org Git - fex.git/blob - cgi-bin/fac
Original release 20150729
[fex.git] / cgi-bin / fac
1 #!/usr/bin/perl -Tw
2
3 # F*EX CGI for administration
4 #
5 # Original author: Andre Hafner <andrehafner@gmx.net>
6 #
7
8 BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
9
10 $| = 1;
11
12 $fac = $0;
13 $fac =~ s:.*/::;
14
15 # add fex lib
16 (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/ or die "no \$FEXLIB\n";
17
18 # import from fex.pp and fex.ph
19 our ($FEXHOME,$spooldir,$logdir,$docdir,$akeydir,$durl,$mdomain,$bs,$hostname);
20 our ($keep_default,$keep_max,$recipient_quota,$sender_quota,$autodelete);
21 our ($admin,$admin_pw,$admin_hosts);
22 our ($sendmail,$bcc);
23 our $error = 'FAC error';
24
25 # load common code, local config : $HOME/lib/fex.ph
26 require "$FEXLIB/fex.pp";
27
28 my @http_auth = ();
29 my $ra = $ENV{REMOTE_ADDR}||0;
30
31 if (not @admin_hosts or not ipin($ra,@admin_hosts)) {
32   html_error($error,"Administration from your host ($ra) is not allowed.");
33 }
34
35 html_error($error,"\$admin not configured in $FEXLIB/fex.ph\n") unless $admin;
36
37 chdir $spooldir or http_die("$spooldir - $!");
38 chomp($admin_pw = slurp("$admin/@")||'');
39 html_error($error,"no F*EX account for admin $admin\n") unless $admin_pw;
40
41 # redirect to https if configured
42 (undef,$port) = split(':',$ENV{HTTP_HOST}||'');
43 $port ||= $ENV{PROTO} eq 'https' ? 443 : 80;
44 if ($port == 80 and open my $x,'/etc/xinetd.d/fexs') {
45   while (<$x>) {
46     if (/^\s*disable\s*=\s*no/) {
47       nvt_print(
48         "HTTP/1.1 301 Moved Permanently",
49         "Location: https://$hostname$ENV{REQUEST_URI}",
50         'Content-Length: 0',
51         ''
52       );
53       exit;
54     }
55   }
56   close $x;
57 }
58
59 our %PARAM;
60 &parse_parameters;
61
62 $action = $PARAM{"action"}||'';
63
64 # authentication
65 &require_akey;
66
67 my $fup = $durl;
68 $fup =~ s:/fop:/fup:;
69
70 my $http_client = $ENV{HTTP_USER_AGENT} || '';
71
72 # files to save with backup function
73 my @backup_files = qw(
74   htdocs/index.html
75   lib/fex.ph
76   lib/fup.pl
77   spool/*@*/@*
78   spool/*@*/.auto
79 );
80
81 # backup goes first
82 if ($action eq "backup") { 
83   &backup;
84   exit;
85 }
86
87 http_header('200 OK');
88
89 $_ = html_header("F*EX Admin Control for $hostname");
90 s:</h1>: (<a href="?action=logout">logout</a>)</h1>:;
91 print;
92
93 my $nav_user = 
94   "<li><a href=\"?action=create\">Create new user</a>\n".
95   "<li><a href=\"?action=change-auth\">Change user auth-ID</a>\n".
96   "<li><a href=\"?action=edit\">Edit user restrictions file</a>\n".
97   "<li><a href=\"?action=delete\">Delete existing user</a>\n".
98   "<li><a href=\"?action=quota\">Manage disk quota</a>\n";
99
100 my $nav_log = 
101   "<li><a href=\"?action=fup.log\">Get fup.log</a>\n".
102   "<li><a href=\"?action=fop.log\">Get fop.log</a>\n".
103   "<li><a href=\"?action=error.log\">Get error.log</a>\n";
104
105 if (-f "$logdir/fexsrv.log") {
106   $nav_log =
107     "<li><a href=\"?action=watch\">Watch logfile</a>\n".
108     "<li><a href=\"?action=fexsrv.log\">Get fexsrv.log</a>\n".
109     $nav_log;
110 }
111
112 my $nav_backup = 
113   "<li><a href=\"?action=backup\">Download backup<br>(config only)</a>\n".
114   "<li><a href=\"?action=restore\">Restore backup</a>\n";
115
116 my $nav_show =
117   "<li><a href=\"?action=list\">List spooled files</a>\n".
118   "<li><a href=\"?action=showquota\">Show quotas (sender/recipient)</a>\n".
119   "<li><a href=\"?action=showconfig\">Show server config</a>\n".
120   "<li><a href=\"?action=userconfig\">Show user config</a>\n";
121   
122 my $nav_edit =  
123   "<li><a href=\"?action=editconfig\">Edit config</a>\n".
124   "<li><a href=\"?action=editindex\">Edit index.html</a>\n";
125
126 pq(qq(
127   '<table border="0">'
128   '  <th>manage user</th>'
129   '  <th>show</th>'
130   '  <th>log files</th>'
131   '  <th>edit</th>'
132   '  <th>backup</th>'
133   '  <tr valign="top">'
134   '    <td><ul>$nav_user</ul>'
135   '    <td><ul>$nav_show</ul>'
136   '    <td><ul>$nav_log</ul>'
137   '    <td><ul>$nav_edit</ul>'
138   '    <td><ul>$nav_backup</ul>'
139   '  </tr>'
140   '</table>'
141   '<hr>'
142 ));
143
144 my @user_items = &userList;
145
146 if    ($action eq "create")      { &createUserForm } 
147 elsif ($action eq "change-auth") { &changeAuthForm } 
148 elsif ($action eq "edit")        { &editRestrictionsForm } 
149 elsif ($action eq "delete")      { &deleteUserForm } 
150 elsif ($action eq "quota")       { &changeQuotaForm } 
151 elsif ($action eq "list")        { &listFiles }
152 elsif ($action eq "showquota")   { &showQuota } 
153 elsif ($action eq "showconfig")  { &showConfig } 
154 elsif ($action eq "userconfig")  { &userConfigForm } 
155 elsif ($action eq "watch")       { &watchLog } 
156 elsif ($action eq "fexsrv.log")  { &getlog("fexsrv.log") } 
157 elsif ($action eq "fup.log")     { &getlog("fup.log") }
158 elsif ($action eq "fop.log")     { &getlog("fop.log") } 
159 elsif ($action eq "error.log")   { &getlog("error.log") } 
160 elsif ($action eq "editconfig")  { &editFile("$FEXLIB/fex.ph") } 
161 elsif ($action eq "editindex")   { &editFile("$docdir/index.html") } 
162 elsif ($action eq "backup")      { &backup } 
163 elsif ($action eq "restore")     { &restoreForm } 
164
165 if (defined $PARAM{"createUser"}) {
166   createUser($PARAM{"createUser"}, $PARAM{"authID"});
167 } elsif (defined $PARAM{"changeAuthUser"}) {
168   if ($PARAM{"changeAuthUser"} =~ /^#.*/) {
169     &changeAuthForm;
170   } else {
171     changeUser($PARAM{"changeAuthUser"}, $PARAM{"authID"});
172   }
173 } elsif (defined $PARAM{"showUserConfig"}) {
174   if ($PARAM{"showUserConfig"} =~ /^#.*/) {
175     &userConfigForm;
176   } else {
177     showUserConfig($PARAM{"showUserConfig"});
178   }
179 } elsif (defined $PARAM{"deleteUser"}) {
180   if ($PARAM{"deleteUser"} =~ /^#.*/) {
181     &deleteUserForm;
182   } else {
183     deleteUser($PARAM{"deleteUser"});
184   }
185 } elsif (defined $PARAM{"userQuota"}) {
186   if ($PARAM{"userQuota"} =~ /^#.*/) {
187     &changeQuotaForm;
188   } else {
189     if (defined $PARAM{"default quota"}) {
190       $user = normalize_user($PARAM{"userQuota"});
191       unlink "$user/\@QUOTA";
192       print "$user has now default quota:<p>\n";
193       print "recipient quota: $recipient_quota MB<br>\n";
194       print "sender quota: $sender_quota MB<br>\n";
195       &end_html;
196     } else {
197       alterQuota(
198         $PARAM{"userQuota"},
199         $PARAM{"recipientQuota"},
200         $PARAM{"senderQuota"}
201       );
202     }
203   }
204 } elsif (defined $PARAM{"editUser"}) {
205   if ($PARAM{"editUser"} =~ /^#.*/) {
206     &editRestrictionsForm;
207   } else {
208     if (defined $PARAM{"delete file"}) {
209       $user = normalize_user($PARAM{"editUser"});
210       unlink "$user/\@ALLOWED_RECIPIENTS";
211       print "upload restrictions for $user have been deleted\n";
212       &end_html;
213     } else {
214       editUser($PARAM{"editUser"});
215     }
216   }
217 } elsif ($PARAM{"contentBox"} and $PARAM{"ar"}) {
218   saveFile($PARAM{"contentBox"},$PARAM{"ar"});
219 } elsif ($PARAM{"upload_archive"}) {
220   restore($PARAM{"upload_archive"}{data});
221 }
222
223 &end_html;
224
225 #######
226 # declaration of formular functions
227 #######
228
229 # formular for creating new users
230 # required arguments: -
231 sub createUserForm {
232   print h3("Create new user");
233   pq(qq(
234     '<form action="/$fac" method="post" enctype="multipart/form-data">'
235     '<table>'
236     '<tr>'
237     '<td>user</td><td><input type="text" name="createUser" size="80"></td>'
238     '</tr>'
239     '<tr>'
240     '<td>auth-ID:</td><td><input type="text" name="authID" size="16"></td>'
241     '</tr>'
242     '</table>'
243     '<input type="submit" name="create user" value="create user">'
244     '</form>'
245   ));
246   &end_html;
247 }
248
249 # formular for changing auth-id of an user
250 # required arguments: -
251 sub changeAuthForm {
252   my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
253
254   print h3("change auth-ID");
255   pq(qq(
256     '<form action="/$fac" method="post" enctype="multipart/form-data">'
257     '<table>'
258     '<tr>'
259     '<td>user:</td><td><select name="changeAuthUser">@option</select></td>'
260     '</tr>'
261     '<tr>'
262     '<td>new auth-ID:</td><td><input type="text" name="authID" size="16"></td>'
263     '</tr>'
264     '</table>'
265     '<input type="submit" name="change" value="change">'
266     '</form>'
267   ));
268   &end_html;
269 }
270
271 # formular choosing user, whose config files shall be shown
272 # required arguments: -
273 sub userConfigForm {
274   my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
275
276   print h3("Show user config files");
277   pq(qq(
278     '<form action="/$fac" method="post enctype="multipart/form-data">'
279     '<table>'
280     '<tr>'
281     '<td>user:</td><td><select name="showUserConfig">@option</select></td>'
282     '</tr>'
283     '</table>'
284     '<input type="submit" name="show config files" value="show config files">'
285     '</form>'
286   ));
287   &end_html;
288 }
289
290 # formular for choosing user, whose restriction file shall be edited
291 # required arguments: -
292 sub editRestrictionsForm {
293   my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
294
295   print h3("Edit user restriction file");
296   pq(qq(
297     '<form action="/$fac" method="post enctype="multipart/form-data">'
298     '<table>'
299     '<tr>'
300     '<td>user:</td><td><select name="editUser">@option</select></td>'
301     '</tr>'
302     '</table>'
303     '<input type="submit" name="edit file" value="edit file">'
304     '<input type="submit" name="delete file" value="delete file">'
305     '</form>'
306   ));
307   &end_html;
308 }
309
310 # formular for choosing user, who shall be removed
311 # required arguments: - 
312 sub deleteUserForm {
313   my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
314
315   print h3("Delete existing user");
316   pq(qq(
317     '<form action="/$fac" method="post enctype="multipart/form-data">'
318     '<table>'
319     '<tr>'
320     '<td>user:</td><td><select name="deleteUser">@option</select></td>'
321     '</tr>'
322     '</table>'
323     '<input type="submit" name="delete user" value="delete user">'
324     '</form>'
325   ));
326   &end_html;
327 }
328
329 # formular for changing an user's quota file
330 # required arguments: -
331 sub changeQuotaForm {
332   my $user;
333   my @option;
334   my $rquota = '';
335   my $squota = '';
336   
337   if ($user = $PARAM{"user"}) {
338
339     $user = normalize_user($user);
340     $rquota = $1 if ($PARAM{"rquota"}||'') =~ /^(\d+)$/;
341     $squota = $1 if ($PARAM{"squota"}||'') =~ /^(\d+)$/;
342   }
343
344   foreach (@user_items) {
345     if ($user and $user eq $_) {
346       push @option,"<option value=\"$_\" selected>$_</option>\n";
347     } else {
348       push @option,"<option value=\"$_\">$_</option>\n";
349     }
350   }
351
352   print h3("Manage disk quota");
353   pq(qq(
354     '<form action="/$fac" method="post" enctype="multipart/form-data">'
355     '<table>'
356     '<tr>'
357     '<td>user:</td><td><select name="userQuota">@option</select></td>'
358     '</tr>'
359     '<tr>'
360     '<td>new quota for recipient:</td>'
361     '<td><input type="text" name="recipientQuota" size="12" value=\"$rquota\">'
362     ' MB (optional)</td>'
363     '</tr>'
364     '<tr>'
365     '<td>new quota for sender:</td>'
366     '<td><input type="text" name="senderQuota" size="12" value=\"$squota\">'
367     ' MB (optional)</td>'
368     '</tr>'
369     '</table>'
370     '<input type="submit" name="change quota" value="change quota">'
371     '<input type="submit" name="default quota" value="default quota">'
372     '</form>'
373   ));
374   &end_html;
375 }
376
377 # formular for choosing backup file to restore
378 # required arguments: -
379 sub restoreForm {
380   print h2("restore config");
381   pq(qq(
382     'Specify the backup-archive you want to restore:<br>'
383     '<form action="/$fac" method="post" enctype="multipart/form-data">'
384     '<input type="file" name="upload_archive" size="80"><br>'
385     '<input type="submit" name="restore" value="restore">'
386     '</form>'
387   ));
388   &end_html;
389 }
390
391
392 #######
393 # declaration user functions
394 #######
395
396 # function for creating new users
397 # required arguments: username, auth-id
398 sub createUser {
399   my ($user,$id) = @_;
400   my $idf;
401   
402   http_die("not enough arguments in createUser") unless $id;
403   
404   $user = normalize_user($user);
405
406   unless (-d "$user") {
407     mkdir "$user",0755 or http_die("cannot mkdir $user - $!");
408   }
409   
410   $idf = "$user/@";
411
412   if (-f $idf) {
413     html_error($error,"There is already an user $user!");       
414   }
415   
416   open $idf,'>',$idf or http_die("cannot write $idf - $!");
417   print {$idf} $id,"\n";
418   close $idf or http_die("cannot write $idf - $!");
419   print "<code>\n";
420   printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
421   printf "%s/%s<p>\n",$fup,b64("from=$user&id=$id");
422   print "</code>\n";
423   notifyUser($user,$id);
424   print "An information e-mail to $user has been sent.\n";
425   &end_html;
426 }
427
428 # function for changing an user's auth-ID
429 # required arguments: username, auth-id
430 sub changeUser {
431   my ($user,$id) = @_;
432   
433   http_die("not enough arguments in changeUser") unless $id;
434   
435   $id = despace($id);
436   $user = normalize_user($user);
437   my $idf = "$user/@";
438   print "<code>\n";
439   print "$idf<p>";
440   
441   open $idf,'>',$idf or http_die("cannot write $idf - $!");
442   print {$idf} $id,"\n";
443   close $idf or http_die("cannot write $idf - $!");
444   printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
445   printf "%s/%s\n",$fup,b64("from=$user&id=$id");
446   print "</code><p>\n";
447   notifyUser($user,$id,"change-auth");
448   print "An information e-mail to $user has been sent.\n";
449   &end_html;
450 }
451
452 # function for showing an user's config files
453 # required arguments: username
454 sub showUserConfig {
455   my $user = shift;
456
457   http_die("not enough arguments in showUserConfig!") unless $user;
458   $user = normalize_user($user);
459    
460   chdir "$user" or http_die("could not change directory $user - $!");
461   print h2("Config files of <code>$user</code>");
462
463   foreach my $file (glob('.auto @* @GROUP/*')) {
464     if (-f $file and not -l $file and $file !~ /.*~$/) {
465       print h3($file), "\n";
466       open $file,'<',$file or http_die("cannot open $file - $!");
467       # print "<table border=1><tr><td>\n";
468       dumpfile($file);
469       # print "</tr></table>\n";
470       close $file;
471     }
472   }
473   &end_html;
474 }
475
476 # function for editing an user's recipient/sender restrictions
477 # required arguments: username
478 sub editUser {
479   my $user = shift;
480   my $content;
481   
482   http_die("not enough arguments in editUser") unless $user;
483   $user = normalize_user($user);
484   http_die("no user $user") unless -d $user;
485   my $ar = "$user/\@ALLOWED_RECIPIENTS";
486   unless (-f $ar) {
487     open $ar,'>',$ar or http_die("cannot open $ar - $!");
488     print {$ar}<<'EOD';
489 # Restrict allowed recipients. Only those listed here are allowed.
490 # Make this file COMPLETLY empty if you want to disable the restriction.
491 # An allowed recipient is an e-mail address, you can use * as wildcard.
492 # Example: *@flupp.org
493 EOD
494     close $ar;
495   }
496   $content = dehtml(slurp($ar));
497   pq(qq(
498     'Edit restrictions file for user $user :<br>'
499     '<form action="/$fac" method="post" enctype="multipart/form-data">'
500     '<textarea name="contentBox"  rows="10" cols="80">'
501     '$content'
502     '</textarea><br>'
503     '<input type="hidden" name="ar" value="$ar">'
504     '<input type="submit" name="save changes" value="save changes">'
505     '</form>'
506   ));
507   &end_html;
508 }
509
510 # function for deleting files
511 # required arguments: list of Files
512 sub deleteFiles {
513   http_die("not enough arguments in deleteFiles") unless (my @files = @_);
514     
515   foreach (@files) {
516     if (-e) {
517       if (unlink $_) {
518         print "file has been deleted: $_<br>\n";
519       } else {
520         print "file could not be deleted: $_ - $!<br>\n";
521       }
522     } else {
523       print "file does not exists: $_<br>\n";
524     }
525   }
526   &end_html;
527 }
528
529 # function for saving a single file
530 # required arguments: content, location
531 sub saveFile {
532   my ($rf,$ar) = @_;
533   my $new;
534   
535   http_die("not enough arguments in saveFile") unless $ar;
536   
537   if ($ar eq 'index.html') {
538     $ar = "$docdir/index.html"
539   } elsif ($ar eq 'fex.ph') {
540     $ar = "$FEXLIB/fex.ph"
541   } elsif ($ar =~ m'^([^/]+/\@ALLOWED_RECIPIENTS)$') {
542     $ar = $1;
543   } else {
544     http_die("unknown file $ar")
545   }
546   
547   $new = $ar.'_new';
548   if ($ar =~ /fex.ph$/) {
549     open $new,'>',$new or http_die("cannot open ${ar}_new - $!");
550     print {$new} $rf;
551     close $new or http_die("cannot write $new - $!");;
552     my $status = dehtml(`perl -c $FEXLIB/fex.ph_new 2>&1`);
553     if ($status =~ /syntax OK/ ) {
554       rename $ar,"$ar~";
555       rename $new,$ar;
556       http_die("cannot write $ar~ - $!") if $?;
557     } else {
558       rename "$ar~",$ar;
559       pq(qq(
560         'No valid syntax in configuration file:'
561         '<p><pre>$status</pre><p>'
562         '<a href="javascript:history.back()">back</a>'
563       ));
564       &end_html;
565     }
566   } else {
567     system qw'cp -a',$ar,"$ar~";
568   }
569   open $ar,'>',$ar or http_die("cannot write $ar - $!");
570   print {$ar} $rf;
571   close $ar or http_die("cannot write $ar - $!");;
572   print "<code>$ar</code> has been saved\n";
573   &end_html;
574 }
575
576 # function for deleting existing user
577 # required arguments: username
578 sub deleteUser {
579   my $user = shift;
580
581   http_die("not enough arguments in deleteUser") unless $user;
582
583   $user = normalize_user($user);
584
585   $idf = "$user/\@";
586   http_die("no such user $user") unless -f $idf;
587   unlink $idf or http_die("cannot remove $idf - $!");
588   unlink "$user/\@ALLOWED_RECIPIENTS";
589   unlink "$user/\@SUBUSER";
590   rmrf("$user/\@GROUP");
591   print "$user deleted\n";
592   &end_html;
593 }
594
595 # function for saving quota information for one single user
596 # required arguments: username, recipient-quota, sender-quota
597 sub alterQuota {
598   my ($user,$rq,$sq) = @_;
599   my ($rquota,$squota);
600   my $qf;
601
602   $user = normalize_user($user);
603   http_die("$user is not a F*EX user") unless -d $user;
604   
605   $rquota = $squota = '';
606   $qf = "$user/\@QUOTA";
607   if (open $qf,$qf) {
608     while (<$qf>) {
609       s/#.*//;
610       $rquota = $1 if /recipient.*?(\d+)/i;
611       $squota = $1 if /sender.*?(\d+)/i;
612     }
613     close $qf;
614   }
615   
616   $rquota = $1 if $rq and $rq =~ /(\d+)/;
617   $squota = $1 if $sq and $sq =~ /(\d+)/;
618   open $qf,'>',$qf or http_die("cannot write $qf - $!");
619   print {$qf} "recipient:$rquota\n" if $rquota;
620   print {$qf} "sender:$squota\n"    if $squota;
621   close $qf or http_die("cannot write $qf - $!");
622   
623   $rquota = $recipient_quota unless $rquota;
624   $squota = $sender_quota    unless $squota;
625   print h3("New quotas for $user");
626   print "recipient quota: $rquota MB<br>\n";
627   print "sender quota: $squota MB<br>\n";
628   &end_html;
629 }
630
631 # function for listing f*exed files
632 # required arguments: -
633 sub listFiles {
634   print h3("List current files");
635   my ($file,$dkey);
636   print "<pre>\n";
637   foreach $recipient (glob "*@*") {
638     next if -l $recipient;
639     foreach $file (glob "$recipient/*/*") {
640       if (-s "$file/data" and  $dkey = readlink("$file/dkey") and -l ".dkeys/$dkey") {
641         ($to,$from,$file) = split "/",$file;
642         $file = html_quote($file);
643         print "$from &rarr; $to : $durl/$dkey/$file\n";
644       }
645     }
646   }
647   print "</pre>\n";
648   &end_html;
649 }
650
651 # function for watching the fex-logfile
652 # required arguments: -
653 sub watchLog {
654   if (-f "$logdir/fexsrv.log") {
655     print h2("polling fexsrv.log"),"\n";
656     open my $log,"$FEXHOME/bin/logwatch|" 
657       or http_die("cannot run $FEXHOME/bin/logwatch - $!");
658     dumpfile($log);
659   } else {
660     print h2("no fexsrv.log");
661   }
662   &end_html;
663 }
664
665 # function for showing logfiles
666 # required arguments: logfile-name
667 sub getlog {
668   my $log = shift or http_die("not enough arguments in getLog");
669   
670   print h2("show $log");
671   if (open $log,"$logdir/$log") {
672     dumpfile($log);
673     close $log;
674   } else {
675     http_die("cannot open $logdir/$log - $!");
676   }
677   &end_html;
678 }
679
680 # function for creating a new backup file
681 # required arguments: -
682 sub backup {
683   my @d = localtime time;
684   my $date = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
685   my $backup = "backup/config-$date.tar";
686   my $http_client = $ENV{HTTP_USER_AGENT} || '';
687   my $size;
688
689   my $home = $FEXHOME;
690   $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
691   
692   chdir $home or http_die("$home - $!");
693   
694   unless (-d "backup") {
695     mkdir "backup",0700 or http_die("cannot mkdir backup - $!");
696   }
697   
698   system "tar -cf $backup @backup_files 2>/dev/null";
699   
700   $size = -s $backup or http_die("backup file empty");
701   
702   open $backup,'<',$backup or http_die("cannot open $backup - $!");
703   
704   nvt_print(
705     'HTTP/1.1 200 OK',
706     "Content-Length: $size",
707     "Content-Type: application/octet-stream; filename=fex-backup-$date.tar",
708     "Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"",
709     "",
710   );
711   
712   while (read($backup,my $b,$bs)) {
713     print $b or last;
714   }
715   
716   exit;
717 }
718
719 # function for restoring an old configuration file
720 # required arguments: uploaded archive
721 sub restore {
722   my $archive_file = shift or http_die("not enough arguments in restore!");
723   my $restore = "backup.tar";
724   my $home = $FEXHOME;
725
726   $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
727
728   chdir $home or http_die("$home - $!");
729   mkdir 'backup';
730
731   open $restore,'>',$restore or http_die("cannot open $restore - $!");
732   print {$restore} $archive_file;
733   close $restore or http_die("cannot write $restore - $!");
734   if (-s $restore) {
735     print "file upload successful<br>\n";
736     print "saving actual config in $home/backup/config.tar<br>\n";
737     print "<pre>\n";
738     system "tar -cf backup/config.tar @backup_files";
739     print "</pre>\n";
740     print "starting restore:\n<p>\n";
741     print "<pre>\n";
742     system "tar -xvf $restore";
743     unlink $restore;
744     &end_html;
745   } else {
746     http_die("upload error - no file data received");
747   }
748 }
749
750 # function for editing a text-file
751 # required arguments: filepath, filename
752 sub editFile {
753   my $ar = shift;
754   my $file;
755   
756   $file = dehtml(slurp($ar));
757   
758   $ar =~ s:.*/::;
759
760   print h2("edit <code>$ar<code>");
761
762   pq(qq(
763     '<form action="/$fac" enctype="multipart/form-data" method="post">'
764     '<textarea name="contentBox" rows="26" cols="80">'
765     '$file'
766     '</textarea><br>'
767     '<input type="hidden" name="ar" value="$ar">'
768     '<input type="submit" name="save changes" value="save changes">'
769     '</form>'
770   ));
771   &end_html;
772 }
773
774 # function for showing all users' quotas
775 # required arguments: -
776 sub showQuota {
777
778   print h2("Show quotas (domain sorted, values in MB)");
779   print "<table border=\"1\"><tr>";
780   foreach (@user_items) {
781     if (/\#\#\#\s(\S+)/) {
782       print "<tr>";
783       print "<th>\@$1</th>";
784       print "<th>sender</th>";
785       print "<th>sender (used)</th>";
786       print "<th>recipient</th>";
787       print "<th>recipient (used)</th>";
788       print "</tr>\n";
789 #      $table = $_;
790     } else {
791       my $rquota = $recipient_quota;
792       my $squota = $sender_quota;
793       my $rquota_used = 0;
794       my $squota_used = 0;
795       my $user = $_;
796       ($squota,$squota_used) = check_sender_quota($user);
797       ($rquota,$rquota_used) = check_recipient_quota($user);
798       my $action = "quota&user=$user&rquota=$rquota&squota=$squota";
799       s/\@.*//;
800       print "<tr>";
801       print "<td><a href=\"?action=$action\">$_</a></td>";
802       print "<td align=\"right\">$squota</td>";
803       print "<td align=\"right\">$squota_used</td>";
804       print "<td align=\"right\">$rquota</td>";
805       print "<td align=\"right\">$rquota_used</td>";
806       print "</tr>\n";
807     }
808   }
809   print "</table>\n";
810   &end_html;
811
812 }
813
814 # function for showing fex-server configuration
815 # required arguments: -
816 sub showConfig {
817   print h3("Show config");
818   print "<table border=\"0\">\n";
819   printf "<tr><td>spooldir:</td><td>%s</td>\n",$spooldir;
820   printf "<tr><td>logdir:</td><td>%s</td>\n",$logdir;
821   printf "<tr><td>docdir:</td><td>%s</td>\n",$docdir;
822   printf "<tr><td>durl:</td><td>%s</td>\n",$durl;
823   printf "<tr><td>mdomain:</td><td>%s</td>\n",$mdomain||'';
824   printf "<tr><td>autodelete:</td><td>%s</td>\n",$autodelete;
825   printf "<tr><td>keep:</td><td>%s</td>\n",$keep_default;
826   printf "<tr><td>keep_max:</td><td>%s</td>\n",$keep_max;
827   printf "<tr><td>recipient_quota:</td><td>%s</td>\n",$recipient_quota;
828   printf "<tr><td>sender_quota:</td><td>%s</td>\n",$sender_quota;
829   printf "<tr><td>admin:</td><td>%s</td>\n",$admin;
830   print "</table>\n";
831   &end_html;
832 }
833
834 # require authentification
835 sub require_akey {
836   my $id;
837   my $rid;
838
839   if ($action eq 'logout') {
840     if (($ENV{HTTP_COOKIE}||'') =~ /akey=(\w+)/) {
841       unlink "$akeydir/$1";
842     }
843     nvt_print(
844       "HTTP/1.1 301 Moved Permanently",
845       "Location: /$fac",
846       'Content-Length: 0',
847       "Set-Cookie: akey=; Max-Age=0; Discard",
848       ''
849     );
850     &reexec;
851   }
852
853   $rid = slurp("$admin/@") or html_error($error,"no F*EX account for $admin");
854   chomp $rid;
855
856   $id = $PARAM{"id"};
857
858   if ($id) {
859     # correct auth-ID?
860     if ($id eq $rid) {
861       $akey = md5_hex("$admin:$rid");
862       return;
863     }
864   } elsif ($akey) {
865     # correct akey?
866     return if $akey eq md5_hex("$admin:$rid");
867   }  
868
869   http_header('200 OK');
870   print html_header("F*EX Admin Control for $hostname");
871
872   if ($akey) {
873     pq(qq(
874       '<font color="red"><h3>'
875       '  wrong akey for <code>$admin</code>'
876       '</h3></font>'
877     ));
878   }
879
880   if ($id and $id ne $rid) {
881     pq(qq(
882       '<font color="red"><h3>'
883       '  wrong auth-ID for <code>$admin</code>'
884       '</h3></font>'
885     ));
886   }
887
888   pq(qq(
889     '<form action="/$fac" method="post" enctype="multipart/form-data">'
890     '  auth-ID for <code>$admin</code>:'
891     '  <input type="password" name="id" size="16" autocomplete="off">'
892     '</form>'
893   ));
894   &end_html;
895 }
896
897
898 # function for checking simple HTTP authentication
899 # (not used any more, replaced with require_akey)
900 sub require_auth {
901   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) 
902   { @http_auth = split(':',decode_b64($1)) }
903   if (
904     @http_auth != 2 
905     or $http_auth[0] !~ /^(fexmaster|admin|\Q$admin\E)$/
906     or $http_auth[1] ne $admin_pw
907   ) {
908     http_header(
909       '401 Authorization Required',
910       "WWW-Authenticate: Basic realm=$admin F*EX admin authentification",
911       'Content-Length: 0',
912     );
913     # control back to fexsrv for further HTTP handling
914     &reexec;
915   }
916 }
917
918
919 # function for sending notification mails to an user
920 # required arguments: username, auth-id, message-type
921 sub notifyUser {
922   my ($user,$id,$type) = @_;
923   my $url = $durl;
924   my $message = 'A F*EX account has been created for you. Use';
925
926   http_die("not enough arguments in createUser") unless $id;
927   if ($type and $type eq "change-auth") {
928     $message = 'New auth-ID for your F*EX account has been set. Use'
929   }
930
931   $user = normalize_user($user);
932   open my $mail,'|-',$sendmail,'-f',$admin,$user,$bcc
933     or http_die("cannot start sendmail - $!");
934   $url =~ s:/fop::;
935   pq($mail,qq(
936     'From: $admin'
937     'To: $user'
938     'Subject: your F*EX account on $hostname'
939     'X-Mailer: F*EX'
940     ''
941     '$message'
942     ''
943     '$url/fup?from=$user'
944     'auth-ID: $id'
945     ''
946     'See $url/index.html for more information about F*EX.'
947     ''
948     'Questions? ==> F*EX admin: $admin'
949   ));
950   close $mail
951     or http_die("cannot send notification e-mail (sendmail error $!)");
952 }
953
954
955 # sort key is the (inverse) domain
956 # required arguments: list of usernames (e-mail addresses)
957 sub domainsort {
958 #    http_die("not enough arguments in domainsort") unless (my @d = @_);
959   my @d = @_;
960   local $_;
961
962   foreach (@d) {
963     s/\s//g;
964     s/\./,/ while /\..*@/;
965     s/@/@./;
966     $_ = join('.',reverse(split /\./));
967   }
968   
969   @d = sort { lc $a cmp lc $b } @d;
970   
971   foreach (@d) {
972     $_ = join('.',reverse(split /\./));
973     s/,/./g;
974     s/@\./@/;
975   }
976   
977   return @d;
978 }
979
980 # function for creating a sorted list of all users
981 # required arguments: -
982 sub userList {
983   my (@u,@list);
984   my $domain = '';
985   my $u;
986   
987   foreach $u (glob('*@*')) {
988     next if -l $u;
989     push @u,$u if -f "$u/@";
990   }
991   
992   foreach (domainsort(@u)) {
993     if (/@(.+)/) {
994       if ($1 ne $domain) {
995         push @list,"### $1 ###";
996       }
997       push @list,$_;
998       $domain = $1;
999     }
1000   }
1001   
1002   return @list;
1003 }
1004
1005
1006 sub dumpfile {
1007   my $file = shift;
1008   
1009   print "<pre>\n";
1010   while (<$file>) { print dehtml($_) }
1011   print "\n</pre>\n";
1012 }
1013
1014
1015 sub h2 {
1016   local $_ = shift;
1017   chomp;
1018   return "<h2>$_</h2>\n";
1019 }
1020
1021
1022 sub h3 {
1023   local $_ = shift;
1024   chomp;
1025   return "<h3>$_</h3>\n";
1026 }
1027
1028
1029 sub end_html {
1030   print "</body></html>\n";
1031   exit;
1032 }
1033
1034
1035 sub dehtml {
1036   local $_ = shift;
1037   s/&/&amp;/g;
1038   s/</&lt;/g;
1039   return $_;
1040 }