#!/usr/bin/perl -wT # FEX CGI for user control # (subuser, groups, address book, one time upload key, auth-ID, etc) # # Author: Ulli Horlacher # use CGI qw(:standard); use CGI::Carp qw(fatalsToBrowser); 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; # import from fex.pp our ($FEXHOME); our ($mdomain,$admin,$hostname,$sendmail,$akeydir,$skeydir,$docdir,$durl,$bcc); our ($nomail,$faillog); our $akey = ''; # load common code, local config : $HOME/lib/fex.ph require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n"; my ($CASE,$ESAC); my $error = 'F*EX user config ERROR'; my $head = "$ENV{SERVER_NAME} F*EX user config"; my $fup = $durl; $fup =~ s:/fop:/fup:; chdir $spooldir or die "$spooldir - $!\n"; my $user = my $id = my $nid = my $ssid = my $comment = ''; my $notification = my $reminder = my $disclaimer = ''; my $encryption = my $pubkey = my $mime = ''; $akey = ''; # delete akey cookie my $qs = $ENV{QUERY_STRING}; if ($qs) { if ($qs =~ /akey=(\w+)/i) { $akey = $1 } if ($qs =~ /ab=load/) { $ab = 'load' } } # look for CGI POST parameters foreach my $v (param) { my $vv = param($v); debuglog("Param: $v=\"$vv\""); if ($v =~ /^akey$/i) { $akey = $1 if $vv =~ /^(\w+)$/; next; } $CASE = $v =~ /^user$/i ? $user = normalize_email($vv): $v =~ /^subuser$/i ? $subuser = normalize_email($vv): $v =~ /^otuser$/i ? $otuser = normalize_email($vv): $v =~ /^notify$/i ? $notify = normalize_email($vv): $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 =~ /^reminder$/i ? $reminder = checkchars('parameter',$vv): $v =~ /^mime$/i ? $mime = checkchars('parameter',$vv): $v =~ /^comment$/i ? $comment = decode_utf8(normalize($vv)): $v =~ /^id$/i ? $id = checkchars('auth-ID',$vv): $v =~ /^nid$/i ? $nid = checkchars('auth-ID',$vv): $v =~ /^ssid$/i ? $ssid = $vv: $v =~ /^group$/i ? $group = checkchars('group',$vv): $v =~ /^ab$/i ? $ab = $vv: $v =~ /^gm$/i ? $gm = $vv: $v =~ /^show$/i ? $tools = checkchars('parameter',$vv): $ESAC; } $group = lc $group if $group and $group ne 'NEW'; $group = '' if $nomail; $user .= '@'.$mdomain if $mdomain and $user !~ /@/; $nomail = $comment if $comment =~ /NOMAIL|!#!/; 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 or http_die("internal server error: no $akey symlink $1"); $user =~ s:.*/::; $user = untaint($user); if ($akey ne md5_hex("$user:$id")) { $user = $id = ''; } } } &check_status($user) if $user; if ($user and $akey and $qs and $qs =~ /info=(.+?)&skey=(.+)/) { $subuser = $1; $skey = $2; notify_subuser($user,$subuser,"$fup?skey=$skey",$comment); http_header("200 OK"); print html_header($head); pq(qq( 'An information e-mail has been sent to your subuser $subuser' '

Go back' '' )); exit; } if ($user and $id) { 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"); } $rid = getline($idf); close $idf; if ($id eq $rid) { unless ($akey) { $akey = untaint(md5_hex("$user:$id")); unlink "$akeydir/$akey"; symlink "../$user","$akeydir/$akey"; } } else { faillog("user $from, id $id"); html_error($error,"wrong user or auth-ID"); } } else { my $login = -x "$FEXHOME/login" ? 'login' : 'fup'; nvt_print( "HTTP/1.1 302 Found", "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$login", 'Expires: 0', 'Content-Length: 0', '' ); &reexec; } # 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)) { nvt_print( "HTTP/1.1 302 Found", "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/foc", 'Expires: 0', 'Content-Length: 0', '' ); &reexec; } unlink $faillog if $faillog; http_header("200 OK"); print html_header($head); # foreach $v (keys %ENV) { print $v,' = "',$ENV{$v},"\"
\n" }; if ($gm and not $group) { pq(qq( '

ERROR: no group name specified

' '' )); exit; } if ($tools) { pq(qq( 'To use one of the following F*EX clients you must configure them after' 'download:' '

' '' ' ' ' ' ' ' ' ' '
F*EX server:$ENV{PROTO}://$ENV{HTTP_HOST}
Proxy:(your web proxy address, may be empty)
User:$user
Auth-ID:$id
' )); 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; } # create one time upload key if ($subuser and $otuser) { $otuser = $subuser; if ($otuser !~ /^[^@]+@[\w.-]+[a-z]$/) { pq(qq( '$otuser is not a valid e-mail address' '

Go back' '' )); exit; } my $okey = randstring(8); my $okeyd = "$user/\@OKEY"; mkdir $okeyd; symlink $otuser,"$okeyd/$okey" or http_die("cannot create OKEY $okeyd/$okey : $!\n"); my $url = "$fup?to=$user&okey=$okey"; pq(qq( 'A one time upload URL for $otuser has been created:' '

' '$url' )); unless ($nomail) { ¬ify_otuser($user,$otuser,$url,$comment); pq(qq( '

' 'and an information e-mail has been sent to this address.' '

' )); } pq(qq( 'back to F*EX operation control' '' )); exit; } # direct single subuser entry if ($subuser and not $otuser) { if (-f "$subuser/@") { pq(qq( '$subuser is already a registered F*EX full user' '

Go back' '' )); exit; } if ($subuser !~ /^[^@]+@[\w.-]+[a-z]$/) { pq(qq( '$subuser is not a valid e-mail address' '

Go back' '' )); exit; } $skey = ''; if (open $idf,'<',"$user/\@SUBUSER") { while (<$idf>) { chomp; if (/^\Q$subuser:/) { $skey = md5_hex("$user:$_"); last; } } close $idf; } if ($skey) { my $url = "$fup?skey=$skey"; if ($nomail) { pq(qq( '$subuser is already your subuser and has access URL:' '

' '$url' )); } else { pq(qq( '$subuser' 'is already your subuser and has access URL:' '

' '$url' '

' "Click on the subuser's e-mail address link to send him an" "information e-mail by the F*EX server.

" )); } } else { my $sid = randstring(8); my $skey = mkskey($user,$subuser,$sid); $url = "$fup?skey=$skey"; open $idf,'>>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n"; print {$idf} "$subuser:$sid\n"; close $idf; pq(qq( 'Your subuser upload URL is:' '

' '$url' )); unless ($nomail) { ¬ify_subuser($user,$subuser,$url,$comment); pq(qq( '

' 'An information e-mail has been sent to $subuser' )); } } print "\n"; exit; } # modify addressbook if ($user and $akey and defined $ab) { if ($ab eq 'load') { $ab = ''; if (open $ab,'<',"$user/\@ADDRESS_BOOK") { undef $/; $_ = <$ab>; s/\s*$/\n/; close $ab; $ab = html_quote($_); } my $rows = ($ab =~ tr/\n//) + 5; pq(qq( '

Edit address book

' '' ' ' ' ' '
Entry:aliase-mail address# optional comment
Example:Framstagframstag\@rus.uni-stuttgart.de# Ulli Horlacher
' '
' ' ' '
' ' ' '
' '

' 'You may use these alias names as F*EX recipient addresses on ' 'fup' '

' 'Alternatively you can fex a file ADDRESS_BOOK to yourself ' '($user) containing your alias definitions.' '

' 'back to F*EX operation control' '' )); } else { $ab =~ s/[\r<>]//g; $ab =~ s/\s*$/\n/; foreach (split(/\n/,$ab)) { s/^\s+//; s/\s+$//; if (s/\s*(#.*)//) { $comment = $1 } else { $comment = '' } next if /^\s*$/; @options = (); push @options,$1 if s/(autodelete=\w+)//i; push @options,$1 if s/(keep=\d+)//i; s/[,\s]+$//; if (s/([\S]+)\s+(\S+)//) { $alias = $1; $address = $2; $options = join(',',@options); push @abt,"$alias$address$options$comment\n"; } else { push @badalias,$_; } } if (@badalias) { print "

ERROR: bad aliases:

\n' '

' 'Not in format: alias e-mail-address' '

' 'Go back' '' )); exit; } open my $AB,'>',"$user/\@ADDRESS_BOOK" or http_die("cannot open $user/\@ADDRESS_BOOK - $!\n"); print {$AB} $ab; close $AB; pq(qq( '

address book

' '' '' '@abt' '
aliase-mail addressoptionscomment
' '

' 'back to F*EX operation control' '

' 'back to fup (F*EX upload)' '' )); } exit; } if ($user and $notification eq 'detailed') { unlink "$user/\@NOTIFICATION"; pq(qq( '

Notification e-mails now come in detailed format.

' '

' 'back to F*EX operation control' '' )); &reexec; } if ($user and $mime eq 'yes') { open $mime,'>',"$user/\@MIME" or http_die("cannot write $user/\@MIME - $!\n"); close $mime; pq(qq( '

Downloads will now be displayed (if possible).

' '

' 'back to F*EX operation control' '' )); &reexec; } if ($user and $mime eq 'no') { unlink "$user/\@MIME"; pq(qq( '

Downloads will now be saved.

' '

' 'back to F*EX operation control' '' )); &reexec; } if ($user and $notification eq 'short') { unlink "$user/\@NOTIFICATION"; symlink "short","$user/\@NOTIFICATION"; pq(qq( '

Notification e-mails now come in short format.

' '

' 'back to F*EX operation control' '' )); &reexec; } if ($user and $disclaimer) { my $df = "$user/\@DISCLAIMER"; if ($disclaimer =~ /^[\s\"]*DEFAULT[\s\"]*$/i) { unlink $df; pq(qq( '

E-mail disclaimer reset to default.

' '

' 'back to F*EX operation control' '' )); } elsif ($disclaimer eq 'CHANGE') { $disclaimer = slurp($df) || ''; $disclaimer =~ s/&/&/g; $disclaimer =~ s/' ' ' '


' ' Disclaimer to be sent with download notification e-mail:
' '
' ' ' ' or ' ' reset the disclaimer to default.' '' '' )); exit; } else { $disclaimer =~ s/^\s+//; $disclaimer =~ s/\s+$/\n/; open $df,'>',$df or http_die("cannot write $df - $!\n"); print {$df} $disclaimer; close $df; $disclaimer =~ s/&/&/g; $disclaimer =~ s/E-mail disclaimer changed to:' '

'
      '$disclaimer'
      '
' '

' 'back to F*EX operation control' '' )); } &reexec; } if ($user and $pubkey) { my $gf = "$user/\@GPG"; my $pk; local $/; local $_; open $gf,">$gf.pk" or http_die("cannot write $gf - $!\n"); print {$gf} <$pubkey>; close $gf; unlink $gf; system "gpg --batch --no-default-keyring --keyring $gf --import". "< $gf.pk >/dev/null 2>&1"; if (`gpg --batch <$gf 2>/dev/null` =~ /^pub\s.*<\Q$user\E>/sm) { $pk = `gpg --batch <$gf 2>&1`; $pk =~ s/&/&/g; $pk =~ s/E-mails to you will be encrypted with the PGP/GPG key:' '

'
      '$pk'
      '
' '

' 'back to F*EX operation control' '' )); unlink "$gf.pk","$gf~"; } else { $pk = `gpg --batch <$gf.pk 2>&1`; $pk =~ s/&/&/g; $pk =~ s/Your uploaded file does not contain a PGP/GPG public key for' ' $user' '

'
      '$pk'
      '
' '

' 'back' '' )); } &reexec; } if ($user and $encryption) { my $gf = "$user/\@GPG"; unless(-s "$ENV{HOME}/.gnupg/pubring.gpg") { html_error($error,"no GPG support activated"); } if ($encryption eq 'DELETE') { unlink $gf; pq(qq( '

PGP/GPG key deleted.

' '

E-mails to you will be sent not encrypted.

' '

' 'back to F*EX operation control' '' )); } elsif ($encryption eq 'CHANGE') { pq(qq( '

' ' ' ' Select your PGP/GPG public key file(*):
' ' ' '

' ' and ' '

' )); if (-f $gf) { my $g = `gpg < $gf`; $g =~ s/' 'delete your already uploaded public key:' '
'
        '$g'
        '
' '


' '(*) To extract and verify your GPG public key use:' '

'
        'gpg -a --export $user > pubkey.gpg'
        'gpg < pubkey.gpg'
        '
' )); } print "\n"; exit; } &reexec; } if ($user and $reminder eq 'yes') { unlink "$user/\@REMINDER"; pq(qq( '

You will now get reminder notification e-mails.

' '

' 'back to F*EX operation control' '' )); &reexec; } if ($user and $reminder eq 'no') { unlink "$user/\@REMINDER"; symlink "no","$user/\@REMINDER"; pq(qq( '

You will now get no reminder notification e-mails.

' '

' 'back to F*EX operation control' '' )); &reexec; } 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( '

new auth-ID "$nid" for $user saved

' 'back to F*EX operation control' '' )); exit; } # empty subuser list POST if (defined(param('ssid')) and $ssid =~ /^\s*$/) { unlink "$user/\@SUBUSER"; pq(qq( '

All subusers deleted

\n