#!/usr/bin/perl -wT
-# FEX CGI for user control
+# FEX CGI for user control
# (subuser, groups, address book, one time upload key, auth-ID, etc)
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+use utf8;
use Fcntl qw(:flock);
use Digest::MD5 qw(md5_hex);
$v =~ /^group$/i ? $group = checkchars('group',$vv):
$v =~ /^ab$/i ? $ab = $vv:
$v =~ /^gm$/i ? $gm = $vv:
- $v =~ /^show$/i ? $tools = checkchars('parameter',$vv):
+ $v =~ /^show$/i ? $show = checkchars('parameter',$vv):
$ESAC;
}
$nomail = $comment if $comment =~ /NOMAIL|!#!/;
+if ($show and $show eq 'tools') {
+ nvt_print(
+ "HTTP/1.1 302 Found",
+ "Location: /tools.html",
+ 'Expires: 0',
+ 'Content-Length: 0',
+ ''
+ );
+ &reexec;
+
+ if (open $tools,"$docdir/tools.html") {
+ while (<$tools>) {
+ while (/\$([\w_]+)\$/) {
+ my $var = $1;
+ my $env = $ENV{$var} || '';
+ s/\$$var\$/$env/g;
+ };
+ print;
+ }
+ }
+ exit;
+}
+
+
if ($akey) {
# sid is not set with web browser
my $idf = "$akeydir/$akey/@";
-
+
if (open $akey,'<',$idf and $id = getline($akey)) {
close $akey;
$idf =~ /(.*)\/\@/;
- $user = readlink $1
+ $user = readlink $1
or http_die("internal server error: no $akey symlink $1");
$user =~ s:.*/::;
$user = untaint($user);
if ($user and $id) {
- if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") }
+ if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") }
unless (open $idf,'<',"$user/@") {
faillog("user $from, id $id");
html_error($error,"wrong user or auth-ID");
}
# empty POST? ==> back to foc
-if ($ENV{REQUEST_METHOD} eq 'POST' and not
- ($subuser or $notify or $nid or $ssid or $group or $ab or $gm or $tools
- or $disclaimer or $encryption or $pubkey))
+if ($ENV{REQUEST_METHOD} eq 'POST' and not
+ ($subuser or $notify or $nid or $ssid or $group or $ab or $gm
+ or $disclaimer or $encryption or $pubkey))
{
nvt_print(
"HTTP/1.1 302 Found",
exit;
}
-if ($tools) {
- pq(qq(
- 'To use one of the following F*EX clients you must configure them after'
- 'download:'
- '<p>'
- '<table border=1>'
- ' <tr><th align=left>F*EX server:<td><code>$ENV{PROTO}://$ENV{HTTP_HOST}</code></tr>'
- ' <tr><th align=left>Proxy:<td>(your web proxy address, may be empty)</tr>'
- ' <tr><th align=left>User:<td><code>$user</code></tr>'
- ' <tr><th align=left>Auth-ID:<td><code>$id</code></tr>'
- '</table>'
- ));
- if (open $tools,"$docdir/tools.html") {
- while (<$tools>) {
- while (/\$([\w_]+)\$/) {
- my $var = $1;
- my $env = $ENV{$var} || '';
- s/\$$var\$/$env/g;
- };
- print;
- }
- }
- exit;
-}
-
if ($group) {
&handle_group;
}
my $okey = randstring(8);
my $okeyd = "$user/\@OKEY";
mkdir $okeyd;
- symlink $otuser,"$okeyd/$okey"
+ symlink $otuser,"$okeyd/$okey"
or http_die("cannot create OKEY $okeyd/$okey : $!\n");
my $url = "$fup?to=$user&okey=$okey";
pq(qq(
} else {
$ab =~ s/[\r<>]//g;
$ab =~ s/\s*$/\n/;
-
+
foreach (split(/\n/,$ab)) {
s/^\s+//;
s/\s+$//;
push @badalias,$_;
}
}
-
+
if (@badalias) {
print "<h2>ERROR: bad aliases:</h2>\n<ul>";
foreach my $ba (@badalias) { print "<li>$ba" }
));
exit;
}
-
- open my $AB,'>',"$user/\@ADDRESS_BOOK"
+
+ open my $AB,'>',"$user/\@ADDRESS_BOOK"
or http_die("cannot open $user/\@ADDRESS_BOOK - $!\n");
print {$AB} $ab;
close $AB;
my $pk;
local $/;
local $_;
-
+
open $pk,">$gf.pk" or http_die("cannot write $gf.pk - $!\n");
print {$pk} $pubkey;
close $pk;
if ($user and $encryption) {
my $gf = "$user/\@GPG";
-
+
unless(-s "$ENV{HOME}/.gnupg/pubring.gpg") {
html_error($error,"no GPG support activated");
}
if ($nid) {
$nid =~ s/^\s+//;
$nid =~ s/\s+$//;
-
+
$nid = randstring(6) if $nid eq '?';
-
+
open $idf,'>',"$user/@" or die "$user/@ - $!\n";
print {$idf} $nid,"\n";
close $idf;
$akey = untaint(md5_hex("$user:$nid"));
unlink "$akeydir/$akey";
symlink "../$user","$akeydir/$akey";
-
+
pq(qq(
'<h3>new auth-ID "<code>$nid</code>" for $user saved</h3>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
# update sub-users
if ($ssid) {
my ($subuser,$subid,$skey);
-
+
# delete old skeys
if (open $idf,'<',"$user/\@SUBUSER") {
while (<$idf>) {
push @badaddress,$subuser unless checkaddress($subuser);
}
}
-
+
if (@badaddress) {
print "<h2>ERROR: bad addresses:</h2>\n<ul>";
foreach my $ba (@badaddress) { print "<li>$ba" }
));
exit;
}
-
+
if ($ssid =~ /\S\@\w/) {
open $idf,'>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
print "Your subusers upload URLs are:<p><code>\n";
));
}
print "<a href=\"/foc?akey=$akey\">back to F*EX operation control</a>\n";
- print "</body></html>\n";
+ print "</body></html>\n";
close $idf;
exit;
}
my ($user,$otuser,$url,$comment) = @_;
my $server = $hostname || $mdomain;
my $sf;
-
+
return if $nomail;
-
+
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$sf = $sender_from ? $sender_from : $user;
open my $mail,'|-',$sendmail,'-f',$sf,$otuser,$bcc
my ($user,$subuser,$url,$comment) = @_;
my $server = $hostname || $mdomain;
my $sf;
-
+
return if $nomail;
-
+
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$sf = $sender_from ? $sender_from : $user;
open my $mail,'|-',$sendmail,'-f',$sf,$subuser,$user,$bcc
my ($user,$gm,$group,$id,$url) = @_;
my $server = $hostname || $mdomain;
my $sf;
-
+
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$sf = $sender_from ? $sender_from : $user;
open my $mail,'|-',$sendmail,'-f',$sf,$gm,$user,$bcc
''
'to upload files to F*EX group "$group"'
''
- 'See http://$ENV{HTTP_HOST}/ for more information about F*EX.'
+ 'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
''
'Questions? ==> F*EX admin: $admin'
));
sub mkskey {
my ($user,$subuser,$id) = @_;
my $skey = md5_hex("$user:$subuser:$id");
-
+
open my $skf,'>',"$skeydir/$skey" or die "$skeydir/$skey - $!\n";
print {$skf} "from=$subuser\n",
"to=$user\n",
sub mkgkey {
my ($user,$group,$gm,$id) = @_;
my $gkey = untaint(md5_hex("$user:$group:$gm:$id"));
-
+
open my $gkf,'>',"$gkeydir/$gkey" or die "$gkeydir/$gkey - $!\n";
print {$gkf} "from=$gm\n",
"to=\@$group\n",
sub handle_group {
my ($gf,$gd,$gl,$gid,$gkey);
-
+
$group =~ s/^@+//;
$group =~ s:[/&<>]::g;
}
$gf = untaint("$user/\@GROUP/$group");
-
+
if (defined $gm) {
if ($gm =~ /\S/) {
foreach (split /\n/,$gm) {
foreach my $ba (@badaddress) { print "<li>$ba" }
print "</ul>\n";
}
- if (@badformat or @badaddress) {
+ if (@badformat or @badaddress) {
pq(qq(
'<a href="javascript:history.back()">Go back</a>'
'</body></html>'
projects / fex.git / blobdiff