#!/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>
#
-use CGI qw(:standard);
-use CGI::Carp qw(fatalsToBrowser);
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+
use Fcntl qw(:flock);
use Digest::MD5 qw(md5_hex);
-$CGI::LIST_CONTEXT_WARN = 0;
-$CGI::LIST_CONTEXT_WARN = 0;
-
# add fex lib
($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;
if ($qs =~ /ab=load/) { $ab = 'load' }
}
-# look for CGI POST parameters
-foreach my $v (param) {
- my $vv = param($v);
- debuglog("Param: $v=\"$vv\"");
+# look for CGI parameters
+our %PARAM;
+&parse_parameters;
+foreach my $v (keys %PARAM) {
+ my $vv = $PARAM{$v};
+ # debuglog("Param: $v=\"$vv\"");
if ($v =~ /^akey$/i) {
$akey = $1 if $vv =~ /^(\w+)$/;
next;
$v =~ /^notification$/i ? $notification = checkchars('parameter',$vv):
$v =~ /^disclaimer$/i ? $disclaimer = $vv:
$v =~ /^encryption$/i ? $encryption = checkchars('parameter',$vv):
- $v =~ /^pubkey$/i ? $pubkey = $vv:
+ $v =~ /^pubkey$/i ? $pubkey = $PARAM{$v}{data}:
$v =~ /^reminder$/i ? $reminder = checkchars('parameter',$vv):
$v =~ /^mime$/i ? $mime = checkchars('parameter',$vv):
$v =~ /^comment$/i ? $comment = decode_utf8(normalize($vv)):
$ESAC;
}
-$group = lc $group if $group and $group ne 'NEW';
+if ($group and $group ne 'NEW') {
+ $group = lc $group;
+ $group =~ s/[^\w\*%^+=:,.!-]/_/g;
+}
$group = '' if $nomail;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
# 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
+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))
+ or $disclaimer or $encryption or $pubkey))
{
nvt_print(
"HTTP/1.1 302 Found",
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(
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
'</body></html>'
));
+ exit;
} 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 $gf,">$gf.pk" or http_die("cannot write $gf - $!\n");
- print {$gf} <$pubkey>;
- close $gf;
+
+ open $pk,">$gf.pk" or http_die("cannot write $gf.pk - $!\n");
+ print {$pk} $pubkey;
+ close $pk;
unlink $gf;
system "gpg --batch --no-default-keyring --keyring $gf --import".
"< $gf.pk >/dev/null 2>&1";
'$pk'
'</pre>'
'<p>'
- '<a href="javascript:history.back()">back</a>'
+ '<a href="javascript:history.back()">back</a>'
'</body></html>'
));
}
if ($user and $encryption) {
my $gf = "$user/\@GPG";
-
+
unless(-s "$ENV{HOME}/.gnupg/pubring.gpg") {
html_error($error,"no GPG support activated");
}
'<h3>E-mails to you will be sent not encrypted.</h3>'
'<p>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
- '</body></html>'
));
} elsif ($encryption eq 'CHANGE') {
pq(qq(
'<pre>'
'$g'
'</pre>'
- '<p><hr><p>'
- '(*) To extract and verify your GPG public key use:'
- '<pre>'
- 'gpg -a --export $user > pubkey.gpg'
- 'gpg < pubkey.gpg'
- '</pre>'
));
}
- print "</body></html>\n";
- exit;
+ pq(qq(
+ '<p><hr><p>'
+ '(*) To extract and verify your GPG public key use:'
+ '<pre>'
+ 'gpg -a --export $user > pubkey.gpg'
+ 'gpg < pubkey.gpg'
+ '</pre>'
+ ));
}
-
- &reexec;
+ print "</body></html>\n";
+ exit;
}
if ($user and $reminder eq 'yes') {
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>'
'</body></html>'
));
- exit;
+ &reexec;
}
# empty subuser list POST
-if (defined(param('ssid')) and $ssid =~ /^\s*$/) {
+if (defined($PARAM{'ssid'}) and $ssid =~ /^\s*$/) {
unlink "$user/\@SUBUSER";
pq(qq(
'<h2>All subusers deleted</h2>\n<ul>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
'</body></html>'
));
- exit;
+ &reexec;
}
# 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
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>'
'<p>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
));
- print end_html();
+ print "</body></html>\n";
exit;
} else {
# no group members -> delete group file
' New group name: <input type="text" name="group"> (You MUST fill out this field!)'
' </font>'
));
+ $gm = $user.':'.randstring(8);
} else {
if (open $gf,'<',$gf) {
local $/;
projects / fex.git / blobdiff