#!/usr/bin/perl -U
#
# v0.01, (c)mahatma, no warranty
use CGI qw(:standard);
use CGI::Carp qw(fatalsToBrowser);
# optional:
use MD5; my $use_md5=1; # comment to no encryption
my $cgi = new CGI;
my $session="$ENV{REMOTE_ADDR} $ENV{HTTP_X_FORWARDED_FOR}";
umask 0177;
### config start
## $auth - password: 0-none/.htpasswd; 1:crypt; 2:unencrypted; 3:md5
## 2,3 - additionally md5 hashed (if $use_md5==1)
my $auth=0;
## don't touch this (better):
my ($user,$password,@sig) = $auth==0?($ENV{REMOTE_USER},''):login_get();
my $passwd=''; # passwords filename ($auth!=0)
my %hpasswd; # predefined or buffer
## you may use own password database (undef $passwd first):
#dbmopen(%hpasswd,'/etc/dbpasswd/dbpasswd',600);
## or you may enter own login:
#$hpasswd{'user'}='password';
my $base="./";
my $webbase="/";
my $iam=$ENV{SCRIPT_NAME};
my $secure=0; # 0:none; 1:uid/gid; 2:1+deny chown/chmod
my @suid;
## for upload:
#$cgi::POST_MAX = 1048576; # max to upload
#my $temp='/tmp/'; # undef = direct
#my $mv='/bin/mv'; # if $temp defined only
### config end
### alt config - standard multi-user unix hosting example, exec as root
#my $auth=1;
#my ($user,$password,@sig) = $auth==0?($ENV{REMOTE_USER},''):login_get();
#my $passwd="/etc/shadow";
#my %hpasswd;
#my $base="/home/$user/public_html/";
#my $webbase="/~$user/";
#my $iam=$ENV{SCRIPT_NAME};
#my $secure=1;
#my @suid=($user,$user);
##$cgi::POST_MAX = 1048576;
##my $temp='/tmp/';
##my $mv='/bin/mv';
### alt config end
#push (@INC, "/home/~$user");
#$ENV{PATH}="/home/~$user";
my $header="Content-type: text/html\n\n";
my $head='';
my $error;
my $path=param('path')||'';
my $action=param('action')||'start';
my @item;
my $lastpath='';
my $it;
for(my $i=0;$i<65535 && defined($it=param("item$i")) && $it ne '';$i++){
push @item,param("item$i");
};
### install ###
install() if($ARGV[0] eq install);
if($action eq 'menu'){a_menu();ex(0)}
elsif($action eq 'start'){a_start();ex(0)}
### /install ###
if(!login()){
$error.='Invalid login ' if($user ne '');
$error.='Not logged in!';
$user=$password='';
@item=();
a_ls();
ex(-2);
}
seq() if($secure>0);
if($action eq 'ls' || $action eq 'reload'){a_lsd()}
elsif($action eq 'get'){a_get()}
elsif($action eq 'upload'){a_upload()}
elsif($action eq 'delete'){a_rm()}
elsif($action eq 'mkdir'){a_mkdir()}
elsif($action eq 'chmod'){a_chmod()}
elsif($action eq 'chown'){a_chown()}
elsif($action eq 'link'){a_link()}
elsif($action eq 'symlink'){a_symlink()}
elsif($action eq 'logoff'){a_logoff()}
else{zerr("Invalid command \"$action\"")}
ex(0);
### login ###
sub login_get(){
return split(/:/,param('sig'));
}
sub login_js(){
my $t='p';
$t="md5h($t)" if($auth==3);
$t="md5h($t+t+s)" if($use_md5 && ($auth!=0));
return qq(
var sig='';
function setpass(p,t,s){sig=fm1.document.f.item0.value+':'+$t+':'+t}
function sign(f){f.sig.value=sig}
function logoff(){sig=''}
)
}
sub login(){
return 1 if($auth==0);
my $u,$p,$l;
if(defined($passwd)){
open PF,"<$passwd" or return 0;
while(defined($l=)){
($u,$p)=(split(/:/, $l))[0,1];
if($u eq $user){
$hpasswd{$u}=$p;
last;
}
}
close(PF);
}
return 0 if(!defined($p=$hpasswd{$user}));
if($auth==1){
$password=crypt($password,$p)
}elsif($use_md5){
$p=MD5->hexhash("$p@sig[0]$session");
}
return ($password eq $p);
}
sub logoff(){
@sig=[];
$user=$password='';
}
### /login ###
sub err_(){
my $e=shift;
return "$!; $action \"$e\" ";
}
sub ex(){
exit shift;
}
sub seq(){
my $u=defined(@suid[0])?(getpwnam(@suid[0]) or &zerr("uid:\"@suid[0]\"")):-1;
my $g=defined(@suid[1])?(getgrnam(@suid[1]) or &zerr("gid:\"@suid[1]\"")):-1;
$)="$g $g"; $(=$g; $<=$>=$u;
if($) ne "$g $g" or $(!=$g or $!=$u){
print "$header Security error (set uid/gid)";
&ex(-3);
}
}
sub seq2(){
&zerr('Denyed') if($secure==2);
}
sub chk(){
my $n=shift;
$n=~s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
my @d=split(/\//,$n);
for (my $i=0;$i<=$#d;$i++){
if(@d[$i] eq '.' or @d[$i] eq ''){
splice(@d,$i,1);
$i-- if($i>-1);
}elsif(@d[$i] eq '..'){
if($i>0){splice(@d,--$i,2)}
else{splice(@d,$i,1)};
$i-- if($i>-1);
}
}
$n='';
my $f=pop(@d);
for my $i(@d) {$n.=$i.'/'};
$n.=$f;
return $n;
}
sub a_logoff(){
$error.='Logged out!';
logoff();
@item=();
a_ls();
}
sub a_get(){
for my $it(@item){
my @s=stat(my $n=$base.(my $i=&chk("$path$it")));
# err($n) if(!$s);
# if(-d $n){
if(@s[2]&0x4000){
$lastpath=$path;
$path=$i;
$path.='/' if($path ne '');
a_lsd();
}else{
open FH,"<$n" or err($it);
print "Content-type: application/unknown\nContent-Length: @s[7]\nLast-Modified: ".localtime(@s[9])."\nContent-Transfer-Coding: binary\nContent-Disposition: download; filename=\"$it\"\n\n", or err($it);
close(FH);
}
}
}
sub a_upload(){
for my $it(@item){
my @n=split(/[\\\/:]/,$it);
my $d=&chk($path.pop(@n));
my $f=defined($temp)?"$temp$user.".time.".tmp":"$base$d";
open FH, ">$f" or err($it);
# chown @own[0],@own[1],$f or err($it.rm()) if(defined(@own));
# binmode FH;
print FH <$it> or err($it.rm());
close (FH);
`$mv -f $f $base$d` if(defined($temp));
}
a_lsd();
sub rm(){
close FH;
unlink FH;
return '';
}
}
sub a_link(){
for my $its(@item){for my $it(split(/,/,$its)){
my ($l,$ll)=split(/:/,$it,2);
link $base.&chk($ll),$base.&chk($l) or &err("$l -> $ll");
}}
a_lsd();
}
sub a_symlink(){
for my $its(@item){for my $it(split(/,/,$its)){
my ($l,$ll)=split(/:/,$it,2);
my @l0=split(/\//,&chk($l));
my @l1=split(/\//,&chk($ll));
my $n=0;
my $i;
for($i=0;($i<=$#l0)&&(@l0[$i] eq @l1[$i]);$i++){ $n++};
splice(@l0,0,$n);
splice(@l1,0,$n);
$ll='';
my $f=pop(@l1);
for($i=0;$i<$#l0;$i++) {$ll.='../'};
for $i(@l1) {$ll.=$i.'/'};
$ll.=$f;
symlink $ll,"$base$l" or &err("$l -> $ll");
}}
a_lsd();
}
sub a_mkdir(){
for my $it(@item){mkdir($base.&chk("$path$it")) or err(&chk("$path$it"))}
a_lsd();
}
sub a_rm(){
for my $its(@item){for my $it(split(/,/,$its)){
my $n=$base.&chk("$path$it");
if(-l $n) {unlink($n) or err($it)}
elsif(-d $n) {rmdir($n) or err($it)}
else{unlink($n) or err($it);}
}};
a_lsd();
};
sub a_chmod(){
seq2();
for my $its(@item){for my $it(split(/,/,$its)){
my @it1=split(/:/,$it,2); #### try 1 or 2!!!
@it1[1]=$base.&chk($path.@it1[1]);
chmod @it1 or err($it);
}};
a_lsd();
};
sub zerr(){
my $e=shift;
$error.="$e ";
a_lsd();
&ex(-1);
}
sub a_chown(){
seq2();
for my $its(@item){
my @its1=split(/,/,$its);
my @u=split(/:/,pop(@its1));
my @uid;
if(@u[0] && @u[0] ne '') {($uid=getpwnam(@u[0])) or &zerr(@u[0]);}
my $gid;
if(@u[1] && @u[1] ne '') {($gid=getgrnam(@u[1])) or &zerr(@u[1]);}
for my $it(@its1){
chown $uid||-1,$gid||-1,$base.&chk("$path$it") or err($it);
}
}
a_lsd();
}
##################################################################
sub err(){
$error.=&err_(shift||'');
a_lsd();
&ex(-1);
}
sub a_lsd(){
@item=('');
a_ls();
}
sub esc(){
my $x=shift;
#$x=~s/([\x00-\x29\x2c\x3a-\x3f\x5b-\x5e\x60\x7b-\x7f])/sprintf('%%%02X',ord($1))/eg;
$x=~s/([\x00-\x1f,:\"\'\\])/sprintf('%%%02X',ord($1))/eg;
return $x;
}
sub a_ls(){
my $e='';
my $err;
my $t=qq($header$head
$session Login: