version 1.238, 2004/08/24 10:40:08
|
version 1.247, 2004/09/02 18:37:44
|
Line 52 use LONCAPA::lonlocal;
|
Line 52 use LONCAPA::lonlocal;
|
use LONCAPA::lonssl; |
use LONCAPA::lonssl; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
|
|
my $DEBUG = 1; # Non zero to enable debug log entries. |
my $DEBUG = 0; # Non zero to enable debug log entries. |
|
|
my $status=''; |
my $status=''; |
my $lastlog=''; |
my $lastlog=''; |
Line 1282 sub push_file_handler {
|
Line 1282 sub push_file_handler {
|
} |
} |
®ister_handler("pushfile", \&push_file_handler, 1, 0, 1); |
®ister_handler("pushfile", \&push_file_handler, 1, 0, 1); |
|
|
|
# |
|
# du - list the disk usuage of a directory recursively. |
|
# |
|
# note: stolen code from the ls file handler |
|
# under construction by Rick Banghart |
|
# . |
|
# Parameters: |
|
# $cmd - The command that dispatched us (du). |
|
# $ududir - The directory path to list... I'm not sure what this |
|
# is relative as things like ls:. return e.g. |
|
# no_such_dir. |
|
# $client - Socket open on the client. |
|
# Returns: |
|
# 1 - indicating that the daemon should not disconnect. |
|
# Side Effects: |
|
# The reply is written to $client. |
|
# |
|
|
|
sub du_handler { |
|
my ($cmd, $ududir, $client) = @_; |
|
if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) { |
|
&Failure($client,"refused\n","$cmd:$ududir"); |
|
return 1; |
|
} |
|
my $duout = `du -ks $ududir 2>/dev/null`; |
|
$duout=~s/[^\d]//g; #preserve only the numbers |
|
&Reply($client,"$duout\n","$cmd:$ududir"); |
|
return 1; |
|
} |
|
®ister_handler("du", \&du_handler, 0, 1, 0); |
|
|
|
|
|
# |
|
# ls - list the contents of a directory. For each file in the |
|
# selected directory the filename followed by the full output of |
|
# the stat function is returned. The returned info for each |
|
# file are separated by ':'. The stat fields are separated by &'s. |
|
# Parameters: |
|
# $cmd - The command that dispatched us (ls). |
|
# $ulsdir - The directory path to list... I'm not sure what this |
|
# is relative as things like ls:. return e.g. |
|
# no_such_dir. |
|
# $client - Socket open on the client. |
|
# Returns: |
|
# 1 - indicating that the daemon should not disconnect. |
|
# Side Effects: |
|
# The reply is written to $client. |
|
# |
|
sub ls_handler { |
|
my ($cmd, $ulsdir, $client) = @_; |
|
|
|
my $userinput = "$cmd:$ulsdir"; |
|
|
|
my $obs; |
|
my $rights; |
|
my $ulsout=''; |
|
my $ulsfn; |
|
if (-e $ulsdir) { |
|
if(-d $ulsdir) { |
|
if (opendir(LSDIR,$ulsdir)) { |
|
while ($ulsfn=readdir(LSDIR)) { |
|
undef $obs, $rights; |
|
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
|
#We do some obsolete checking here |
|
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
|
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
|
my @obsolete=<FILE>; |
|
foreach my $obsolete (@obsolete) { |
|
if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
|
if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } |
|
} |
|
} |
|
$ulsout.=$ulsfn.'&'.join('&',@ulsstats); |
|
if($obs eq '1') { $ulsout.="&1"; } |
|
else { $ulsout.="&0"; } |
|
if($rights eq '1') { $ulsout.="&1:"; } |
|
else { $ulsout.="&0:"; } |
|
} |
|
closedir(LSDIR); |
|
} |
|
} else { |
|
my @ulsstats=stat($ulsdir); |
|
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
|
} |
|
} else { |
|
$ulsout='no_such_dir'; |
|
} |
|
if ($ulsout eq '') { $ulsout='empty'; } |
|
print $client "$ulsout\n"; |
|
|
|
return 1; |
|
|
|
} |
|
®ister_handler("ls", \&ls_handler, 0, 1, 0); |
|
|
|
|
|
|
Line 1845 sub remove_user_file_handler {
|
Line 1939 sub remove_user_file_handler {
|
if (-e $udir) { |
if (-e $udir) { |
my $file=$udir.'/userfiles/'.$ufile; |
my $file=$udir.'/userfiles/'.$ufile; |
if (-e $file) { |
if (-e $file) { |
unlink($file); |
if (-f $file){ |
|
unlink($file); |
|
} elsif(-d $file) { |
|
rmdir($file); |
|
} |
if (-e $file) { |
if (-e $file) { |
&Failure($client, "failed\n", "$cmd:$tail"); |
&Failure($client, "failed\n", "$cmd:$tail"); |
} else { |
} else { |
Line 2110 sub put_user_profile_entry {
|
Line 2208 sub put_user_profile_entry {
|
|
|
my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
|
|
my ($udom,$uname,$namespace,$what) =split(/:/,$tail); |
my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4); |
if ($namespace ne 'roles') { |
if ($namespace ne 'roles') { |
chomp($what); |
chomp($what); |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
Line 3271 sub tmp_del_handler {
|
Line 3369 sub tmp_del_handler {
|
} |
} |
®ister_handler("tmpdel", \&tmp_del_handler, 0, 1, 0); |
®ister_handler("tmpdel", \&tmp_del_handler, 0, 1, 0); |
# |
# |
|
# Processes the setannounce command. This command |
|
# creates a file named announce.txt in the top directory of |
|
# the documentn root and sets its contents. The announce.txt file is |
|
# printed in its entirety at the LonCAPA login page. Note: |
|
# once the announcement.txt fileis created it cannot be deleted. |
|
# However, setting the contents of the file to empty removes the |
|
# announcement from the login page of loncapa so who cares. |
|
# |
|
# Parameters: |
|
# $cmd - The command that got us dispatched. |
|
# $announcement - The text of the announcement. |
|
# $client - Socket open on the client process. |
|
# Retunrns: |
|
# 1 - Indicating request processing should continue |
|
# Side Effects: |
|
# The file {DocRoot}/announcement.txt is created. |
|
# A reply is sent to $client. |
|
# |
|
sub set_announce_handler { |
|
my ($cmd, $announcement, $client) = @_; |
|
|
|
my $userinput = "$cmd:$announcement"; |
|
|
|
chomp($announcement); |
|
$announcement=&unescape($announcement); |
|
if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. |
|
'/announcement.txt')) { |
|
print $store $announcement; |
|
close $store; |
|
&Reply($client, "ok\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)."\n", $userinput); |
|
} |
|
|
|
return 1; |
|
} |
|
®ister_handler("setannounce", \&set_announce_handler, 0, 1, 0); |
|
# |
|
# Return the version of the daemon. This can be used to determine |
|
# the compatibility of cross version installations or, alternatively to |
|
# simply know who's out of date and who isn't. Note that the version |
|
# is returned concatenated with the tail. |
|
# Parameters: |
|
# $cmd - the request that dispatched to us. |
|
# $tail - Tail of the request (client's version?). |
|
# $client - Socket open on the client. |
|
#Returns: |
|
# 1 - continue processing requests. |
|
# Side Effects: |
|
# Replies with version to $client. |
|
sub get_version_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
|
|
my $userinput = $cmd.$tail; |
|
|
|
&Reply($client, &version($userinput)."\n", $userinput); |
|
|
|
|
|
return 1; |
|
} |
|
®ister_handler("version", \&get_version_handler, 0, 1, 0); |
|
# Set the current host and domain. This is used to support |
|
# multihomed systems. Each IP of the system, or even separate daemons |
|
# on the same IP can be treated as handling a separate lonCAPA virtual |
|
# machine. This command selects the virtual lonCAPA. The client always |
|
# knows the right one since it is lonc and it is selecting the domain/system |
|
# from the hosts.tab file. |
|
# Parameters: |
|
# $cmd - Command that dispatched us. |
|
# $tail - Tail of the command (domain/host requested). |
|
# $socket - Socket open on the client. |
|
# |
|
# Returns: |
|
# 1 - Indicates the program should continue to process requests. |
|
# Side-effects: |
|
# The default domain/system context is modified for this daemon. |
|
# a reply is sent to the client. |
|
# |
|
sub set_virtual_host_handler { |
|
my ($cmd, $tail, $socket) = @_; |
|
|
|
my $userinput ="$cmd:$tail"; |
|
|
|
&Reply($client, &sethost($userinput)."\n", $userinput); |
|
|
|
|
|
return 1; |
|
} |
|
®ister_handler("sethost", \&set_virtual_host_handler, 0, 1, 0); |
|
|
|
# Process a request to exit: |
|
# - "bye" is sent to the client. |
|
# - The client socket is shutdown and closed. |
|
# - We indicate to the caller that we should exit. |
|
# Formal Parameters: |
|
# $cmd - The command that got us here. |
|
# $tail - Tail of the command (empty). |
|
# $client - Socket open on the tail. |
|
# Returns: |
|
# 0 - Indicating the program should exit!! |
|
# |
|
sub exit_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
|
|
my $userinput = "$cmd:$tail"; |
|
|
|
&logthis("Client $clientip ($clientname) hanging up: $userinput"); |
|
&Reply($client, "bye\n", $userinput); |
|
$client->shutdown(2); # shutdown the socket forcibly. |
|
$client->close(); |
|
|
|
return 0; |
|
} |
|
®ister_handler("exit", \&exit_handler, 0,,1); |
|
®ister_handler("init", \&exit_handler, 0,,1); |
|
®ister_handler("quit", \&exit_handler, 0,,1); |
|
|
|
|
|
# |
|
# |
# |
# |
# |
# |
# |
# |
Line 3387 sub process_request {
|
Line 3605 sub process_request {
|
|
|
#------------------- Commands not yet in spearate handlers. -------------- |
#------------------- Commands not yet in spearate handlers. -------------- |
|
|
|
|
# ----------------------------------------------------------------------- idput |
|
if ($userinput =~ /^idput/) { |
|
if(isClient) { |
|
my ($cmd,$udom,$what)=split(/:/,$userinput); |
|
chomp($what); |
|
$udom=~s/\W//g; |
|
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
|
my $now=time; |
|
my @pairs=split(/\&/,$what); |
|
my %hash; |
|
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
|
{ |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname.hist")) { |
|
print $hfh "P:$now:$what\n"; |
|
} |
|
} |
|
foreach my $pair (@pairs) { |
|
my ($key,$value)=split(/=/,$pair); |
|
$hash{$key}=$value; |
|
} |
|
if (untie(%hash)) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting idput\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting idput\n"; |
|
} |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
# ----------------------------------------------------------------------- idget |
|
} elsif ($userinput =~ /^idget/) { |
|
if(isClient) { |
|
my ($cmd,$udom,$what)=split(/:/,$userinput); |
|
chomp($what); |
|
$udom=~s/\W//g; |
|
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
|
my @queries=split(/\&/,$what); |
|
my $qresult=''; |
|
my %hash; |
|
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
|
for (my $i=0;$i<=$#queries;$i++) { |
|
$qresult.="$hash{$queries[$i]}&"; |
|
} |
|
if (untie(%hash)) { |
|
$qresult=~s/\&$//; |
|
print $client "$qresult\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting idget\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting idget\n"; |
|
} |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
# ---------------------------------------------------------------------- tmpput |
|
} elsif ($userinput =~ /^tmpput/) { |
|
if(isClient) { |
|
my ($cmd,$what)=split(/:/,$userinput); |
|
my $store; |
|
$tmpsnum++; |
|
my $id=$$.'_'.$clientip.'_'.$tmpsnum; |
|
$id=~s/\W/\_/g; |
|
$what=~s/\n//g; |
|
my $execdir=$perlvar{'lonDaemons'}; |
|
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { |
|
print $store $what; |
|
close $store; |
|
print $client "$id\n"; |
|
} |
|
else { |
|
print $client "error: ".($!+0) |
|
."IO::File->new Failed ". |
|
"while attempting tmpput\n"; |
|
} |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
|
|
# ---------------------------------------------------------------------- tmpget |
|
} elsif ($userinput =~ /^tmpget/) { |
|
if(isClient) { |
|
my ($cmd,$id)=split(/:/,$userinput); |
|
chomp($id); |
|
$id=~s/\W/\_/g; |
|
my $store; |
|
my $execdir=$perlvar{'lonDaemons'}; |
|
if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { |
|
my $reply=<$store>; |
|
print $client "$reply\n"; |
|
close $store; |
|
} |
|
else { |
|
print $client "error: ".($!+0) |
|
."IO::File->new Failed ". |
|
"while attempting tmpget\n"; |
|
} |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
# ---------------------------------------------------------------------- tmpdel |
|
} elsif ($userinput =~ /^tmpdel/) { |
|
if(isClient) { |
|
my ($cmd,$id)=split(/:/,$userinput); |
|
chomp($id); |
|
$id=~s/\W/\_/g; |
|
my $execdir=$perlvar{'lonDaemons'}; |
|
if (unlink("$execdir/tmp/$id.tmp")) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
."Unlink tmp Failed ". |
|
"while attempting tmpdel\n"; |
|
} |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
# -------------------------------------------------------------------------- ls |
|
} elsif ($userinput =~ /^ls/) { |
|
if(isClient) { |
|
my $obs; |
|
my $rights; |
|
my ($cmd,$ulsdir)=split(/:/,$userinput); |
|
my $ulsout=''; |
|
my $ulsfn; |
|
if (-e $ulsdir) { |
|
if(-d $ulsdir) { |
|
if (opendir(LSDIR,$ulsdir)) { |
|
while ($ulsfn=readdir(LSDIR)) { |
|
undef $obs, $rights; |
|
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
|
#We do some obsolete checking here |
|
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
|
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
|
my @obsolete=<FILE>; |
|
foreach my $obsolete (@obsolete) { |
|
if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
|
if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } |
|
} |
|
} |
|
$ulsout.=$ulsfn.'&'.join('&',@ulsstats); |
|
if($obs eq '1') { $ulsout.="&1"; } |
|
else { $ulsout.="&0"; } |
|
if($rights eq '1') { $ulsout.="&1:"; } |
|
else { $ulsout.="&0:"; } |
|
} |
|
closedir(LSDIR); |
|
} |
|
} else { |
|
my @ulsstats=stat($ulsdir); |
|
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
|
} |
|
} else { |
|
$ulsout='no_such_dir'; |
|
} |
|
if ($ulsout eq '') { $ulsout='empty'; } |
|
print $client "$ulsout\n"; |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
# ----------------------------------------------------------------- setannounce |
|
} elsif ($userinput =~ /^setannounce/) { |
|
if (isClient) { |
|
my ($cmd,$announcement)=split(/:/,$userinput); |
|
chomp($announcement); |
|
$announcement=&unescape($announcement); |
|
if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. |
|
'/announcement.txt')) { |
|
print $store $announcement; |
|
close $store; |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error: ".($!+0)."\n"; |
|
} |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
|
|
} |
|
# ------------------------------------------------------------------ Hanging up |
|
} elsif (($userinput =~ /^exit/) || |
|
($userinput =~ /^init/)) { # no restrictions. |
|
&logthis( |
|
"Client $clientip ($clientname) hanging up: $userinput"); |
|
print $client "bye\n"; |
|
$client->shutdown(2); # shutdown the socket forcibly. |
|
$client->close(); |
|
return 0; |
|
|
|
# ---------------------------------- set current host/domain |
|
} elsif ($userinput =~ /^sethost/) { |
|
if (isClient) { |
|
print $client &sethost($userinput)."\n"; |
|
} else { |
|
print $client "refused\n"; |
|
} |
|
#---------------------------------- request file (?) version. |
|
} elsif ($userinput =~/^version/) { |
|
if (isClient) { |
|
print $client &version($userinput)."\n"; |
|
} else { |
|
print $client "refused\n"; |
|
} |
|
#------------------------------- is auto-enrollment enabled? |
#------------------------------- is auto-enrollment enabled? |
} elsif ($userinput =~/^autorun/) { |
if ($userinput =~/^autorun/) { |
if (isClient) { |
if (isClient) { |
my ($cmd,$cdom) = split(/:/,$userinput); |
my ($cmd,$cdom) = split(/:/,$userinput); |
my $outcome = &localenroll::run($cdom); |
my $outcome = &localenroll::run($cdom); |