|
version 1.211, 2004/07/23 16:14:19
|
version 1.212, 2004/07/27 10:25:07
|
|
Line 148 my @adderrors = ("ok",
|
Line 148 my @adderrors = ("ok",
|
| # |
# |
| # Statistics that are maintained and dislayed in the status line. |
# Statistics that are maintained and dislayed in the status line. |
| # |
# |
| my $Transactions; # Number of attempted transactions. |
my $Transactions = 0; # Number of attempted transactions. |
| my $Failures; # Number of transcations failed. |
my $Failures = 0; # Number of transcations failed. |
| |
|
| # ResetStatistics: |
# ResetStatistics: |
| # Resets the statistics counters: |
# Resets the statistics counters: |
|
Line 1047 sub get_request {
|
Line 1047 sub get_request {
|
| my $input = <$client>; |
my $input = <$client>; |
| chomp($input); |
chomp($input); |
| |
|
| Debug("Request = $input\n"); |
Debug("get_request: Request = $input\n"); |
| |
|
| &status('Processing '.$clientname.':'.$input); |
&status('Processing '.$clientname.':'.$input); |
| |
|
| return $input; |
return $input; |
| } |
} |
| |
#--------------------------------------------------------------- |
| |
# |
| |
# Process a request. This sub should shrink as each action |
| |
# gets farmed out into a separat sub that is registered |
| |
# with the dispatch hash. |
| |
# |
| |
# Parameters: |
| |
# user_input - The request received from the client (lonc). |
| |
# Returns: |
| |
# true to keep processing, false if caller should exit. |
| |
# |
| |
sub process_request { |
| |
my ($userinput) = @_; # Easier for now to break style than to |
| |
# fix all the userinput -> user_input. |
| |
my $wasenc = 0; # True if request was encrypted. |
| |
# ------------------------------------------------------------ See if encrypted |
| |
if ($userinput =~ /^enc/) { |
| |
$userinput = decipher($userinput); |
| |
$wasenc=1; |
| |
if(!$userinput) { # Cipher not defined. |
| |
&Failure($client, "error: Encrypted data without negotated key"); |
| |
return 0; |
| |
} |
| |
} |
| |
Debug("process_request: $userinput\n"); |
| |
|
| |
# ------------------------------------------------------------- Normal commands |
| |
# ------------------------------------------------------------------------ ping |
| |
if ($userinput =~ /^ping/) { # client only |
| |
if(isClient) { |
| |
print $client "$currenthostid\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
} |
| |
# ------------------------------------------------------------------------ pong |
| |
}elsif ($userinput =~ /^pong/) { # client only |
| |
if(isClient) { |
| |
my $reply=&reply("ping",$clientname); |
| |
print $client "$currenthostid:$reply\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
} |
| |
# ------------------------------------------------------------------------ ekey |
| |
} elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs |
| |
my $buildkey=time.$$.int(rand 100000); |
| |
$buildkey=~tr/1-6/A-F/; |
| |
$buildkey=int(rand 100000).$buildkey.int(rand 100000); |
| |
my $key=$currenthostid.$clientname; |
| |
$key=~tr/a-z/A-Z/; |
| |
$key=~tr/G-P/0-9/; |
| |
$key=~tr/Q-Z/0-9/; |
| |
$key=$key.$buildkey.$key.$buildkey.$key.$buildkey; |
| |
$key=substr($key,0,32); |
| |
my $cipherkey=pack("H32",$key); |
| |
$cipher=new IDEA $cipherkey; |
| |
print $client "$buildkey\n"; |
| |
# ------------------------------------------------------------------------ load |
| |
} elsif ($userinput =~ /^load/) { # client only |
| |
if (isClient) { |
| |
my $loadavg; |
| |
{ |
| |
my $loadfile=IO::File->new('/proc/loadavg'); |
| |
$loadavg=<$loadfile>; |
| |
} |
| |
$loadavg =~ s/\s.*//g; |
| |
my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; |
| |
print $client "$loadpercent\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------------------------------------- userload |
| |
} elsif ($userinput =~ /^userload/) { # client only |
| |
if(isClient) { |
| |
my $userloadpercent=&userload(); |
| |
print $client "$userloadpercent\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# |
| |
# Transactions requiring encryption: |
| |
# |
| |
# ----------------------------------------------------------------- currentauth |
| |
} elsif ($userinput =~ /^currentauth/) { |
| |
if (($wasenc==1) && isClient) { # Encoded & client only. |
| |
my ($cmd,$udom,$uname)=split(/:/,$userinput); |
| |
my $result = GetAuthType($udom, $uname); |
| |
if($result eq "nouser") { |
| |
print $client "unknown_user\n"; |
| |
} |
| |
else { |
| |
print $client "$result\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
#--------------------------------------------------------------------- pushfile |
| |
} elsif($userinput =~ /^pushfile/) { # encoded & manager. |
| |
if(($wasenc == 1) && isManager) { |
| |
my $cert = GetCertificate($userinput); |
| |
if(ValidManager($cert)) { |
| |
my $reply = PushFile($userinput); |
| |
print $client "$reply\n"; |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
#--------------------------------------------------------------------- reinit |
| |
} elsif($userinput =~ /^reinit/) { # Encoded and manager |
| |
if (($wasenc == 1) && isManager) { |
| |
my $cert = GetCertificate($userinput); |
| |
if(ValidManager($cert)) { |
| |
chomp($userinput); |
| |
my $reply = ReinitProcess($userinput); |
| |
print $client "$reply\n"; |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
} |
| |
#------------------------------------------------------------------------- edit |
| |
} elsif ($userinput =~ /^edit/) { # encoded and manager: |
| |
if(($wasenc ==1) && (isManager)) { |
| |
my $cert = GetCertificate($userinput); |
| |
if(ValidManager($cert)) { |
| |
my($command, $filetype, $script) = split(/:/, $userinput); |
| |
if (($filetype eq "hosts") || ($filetype eq "domain")) { |
| |
if($script ne "") { |
| |
Reply($client, EditFile($userinput)); |
| |
} else { |
| |
Reply($client,"refused\n",$userinput); |
| |
} |
| |
} else { |
| |
Reply($client,"refused\n",$userinput); |
| |
} |
| |
} else { |
| |
Reply($client,"refused\n",$userinput); |
| |
} |
| |
} else { |
| |
Reply($client,"refused\n",$userinput); |
| |
} |
| |
# ------------------------------------------------------------------------ auth |
| |
} elsif ($userinput =~ /^auth/) { # Encoded and client only. |
| |
if (($wasenc==1) && isClient) { |
| |
my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); |
| |
chomp($upass); |
| |
$upass=unescape($upass); |
| |
my $proname=propath($udom,$uname); |
| |
my $passfilename="$proname/passwd"; |
| |
if (-e $passfilename) { |
| |
my $pf = IO::File->new($passfilename); |
| |
my $realpasswd=<$pf>; |
| |
chomp($realpasswd); |
| |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
| |
my $pwdcorrect=0; |
| |
if ($howpwd eq 'internal') { |
| |
&Debug("Internal auth"); |
| |
$pwdcorrect= |
| |
(crypt($upass,$contentpwd) eq $contentpwd); |
| |
} elsif ($howpwd eq 'unix') { |
| |
&Debug("Unix auth"); |
| |
if((getpwnam($uname))[1] eq "") { #no such user! |
| |
$pwdcorrect = 0; |
| |
} else { |
| |
$contentpwd=(getpwnam($uname))[1]; |
| |
my $pwauth_path="/usr/local/sbin/pwauth"; |
| |
unless ($contentpwd eq 'x') { |
| |
$pwdcorrect= |
| |
(crypt($upass,$contentpwd) eq |
| |
$contentpwd); |
| |
} |
| |
|
| |
elsif (-e $pwauth_path) { |
| |
open PWAUTH, "|$pwauth_path" or |
| |
die "Cannot invoke authentication"; |
| |
print PWAUTH "$uname\n$upass\n"; |
| |
close PWAUTH; |
| |
$pwdcorrect=!$?; |
| |
} |
| |
} |
| |
} elsif ($howpwd eq 'krb4') { |
| |
my $null=pack("C",0); |
| |
unless ($upass=~/$null/) { |
| |
my $krb4_error = &Authen::Krb4::get_pw_in_tkt |
| |
($uname,"",$contentpwd,'krbtgt', |
| |
$contentpwd,1,$upass); |
| |
if (!$krb4_error) { |
| |
$pwdcorrect = 1; |
| |
} else { |
| |
$pwdcorrect=0; |
| |
# log error if it is not a bad password |
| |
if ($krb4_error != 62) { |
| |
&logthis('krb4:'.$uname.','. |
| |
&Authen::Krb4::get_err_txt($Authen::Krb4::error)); |
| |
} |
| |
} |
| |
} |
| |
} elsif ($howpwd eq 'krb5') { |
| |
my $null=pack("C",0); |
| |
unless ($upass=~/$null/) { |
| |
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); |
| |
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; |
| |
my $krbserver=&Authen::Krb5::parse_name($krbservice); |
| |
my $credentials=&Authen::Krb5::cc_default(); |
| |
$credentials->initialize($krbclient); |
| |
my $krbreturn = |
| |
&Authen::Krb5::get_in_tkt_with_password( |
| |
$krbclient,$krbserver,$upass,$credentials); |
| |
# unless ($krbreturn) { |
| |
# &logthis("Krb5 Error: ". |
| |
# &Authen::Krb5::error()); |
| |
# } |
| |
$pwdcorrect = ($krbreturn == 1); |
| |
} else { $pwdcorrect=0; } |
| |
} elsif ($howpwd eq 'localauth') { |
| |
$pwdcorrect=&localauth::localauth($uname,$upass, |
| |
$contentpwd); |
| |
} |
| |
if ($pwdcorrect) { |
| |
print $client "authorized\n"; |
| |
} else { |
| |
print $client "non_authorized\n"; |
| |
} |
| |
} else { |
| |
print $client "unknown_user\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ---------------------------------------------------------------------- passwd |
| |
} elsif ($userinput =~ /^passwd/) { # encoded and client |
| |
if (($wasenc==1) && isClient) { |
| |
my |
| |
($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); |
| |
chomp($npass); |
| |
$upass=&unescape($upass); |
| |
$npass=&unescape($npass); |
| |
&Debug("Trying to change password for $uname"); |
| |
my $proname=propath($udom,$uname); |
| |
my $passfilename="$proname/passwd"; |
| |
if (-e $passfilename) { |
| |
my $realpasswd; |
| |
{ my $pf = IO::File->new($passfilename); |
| |
$realpasswd=<$pf>; } |
| |
chomp($realpasswd); |
| |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
| |
if ($howpwd eq 'internal') { |
| |
&Debug("internal auth"); |
| |
if (crypt($upass,$contentpwd) eq $contentpwd) { |
| |
my $salt=time; |
| |
$salt=substr($salt,6,2); |
| |
my $ncpass=crypt($npass,$salt); |
| |
{ |
| |
my $pf; |
| |
if ($pf = IO::File->new(">$passfilename")) { |
| |
print $pf "internal:$ncpass\n"; |
| |
&logthis("Result of password change for $uname: pwchange_success"); |
| |
print $client "ok\n"; |
| |
} else { |
| |
&logthis("Unable to open $uname passwd to change password"); |
| |
print $client "non_authorized\n"; |
| |
} |
| |
} |
| |
|
| |
} else { |
| |
print $client "non_authorized\n"; |
| |
} |
| |
} elsif ($howpwd eq 'unix') { |
| |
# Unix means we have to access /etc/password |
| |
# one way or another. |
| |
# First: Make sure the current password is |
| |
# correct |
| |
&Debug("auth is unix"); |
| |
$contentpwd=(getpwnam($uname))[1]; |
| |
my $pwdcorrect = "0"; |
| |
my $pwauth_path="/usr/local/sbin/pwauth"; |
| |
unless ($contentpwd eq 'x') { |
| |
$pwdcorrect= |
| |
(crypt($upass,$contentpwd) eq $contentpwd); |
| |
} elsif (-e $pwauth_path) { |
| |
open PWAUTH, "|$pwauth_path" or |
| |
die "Cannot invoke authentication"; |
| |
print PWAUTH "$uname\n$upass\n"; |
| |
close PWAUTH; |
| |
&Debug("exited pwauth with $? ($uname,$upass) "); |
| |
$pwdcorrect=($? == 0); |
| |
} |
| |
if ($pwdcorrect) { |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
&Debug("Opening lcpasswd pipeline"); |
| |
my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log"); |
| |
print $pf "$uname\n$npass\n$npass\n"; |
| |
close $pf; |
| |
my $err = $?; |
| |
my $result = ($err>0 ? 'pwchange_failure' |
| |
: 'ok'); |
| |
&logthis("Result of password change for $uname: ". |
| |
&lcpasswdstrerror($?)); |
| |
print $client "$result\n"; |
| |
} else { |
| |
print $client "non_authorized\n"; |
| |
} |
| |
} else { |
| |
print $client "auth_mode_error\n"; |
| |
} |
| |
} else { |
| |
print $client "unknown_user\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------------------------------------- makeuser |
| |
} elsif ($userinput =~ /^makeuser/) { # encoded and client. |
| |
&Debug("Make user received"); |
| |
my $oldumask=umask(0077); |
| |
if (($wasenc==1) && isClient) { |
| |
my |
| |
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
| |
&Debug("cmd =".$cmd." $udom =".$udom. |
| |
" uname=".$uname); |
| |
chomp($npass); |
| |
$npass=&unescape($npass); |
| |
my $proname=propath($udom,$uname); |
| |
my $passfilename="$proname/passwd"; |
| |
&Debug("Password file created will be:". |
| |
$passfilename); |
| |
if (-e $passfilename) { |
| |
print $client "already_exists\n"; |
| |
} elsif ($udom ne $currentdomainid) { |
| |
print $client "not_right_domain\n"; |
| |
} else { |
| |
my @fpparts=split(/\//,$proname); |
| |
my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; |
| |
my $fperror=''; |
| |
for (my $i=3;$i<=$#fpparts;$i++) { |
| |
$fpnow.='/'.$fpparts[$i]; |
| |
unless (-e $fpnow) { |
| |
unless (mkdir($fpnow,0777)) { |
| |
$fperror="error: ".($!+0) |
| |
." mkdir failed while attempting " |
| |
."makeuser"; |
| |
} |
| |
} |
| |
} |
| |
unless ($fperror) { |
| |
my $result=&make_passwd_file($uname, $umode,$npass, |
| |
$passfilename); |
| |
print $client $result; |
| |
} else { |
| |
print $client "$fperror\n"; |
| |
} |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
umask($oldumask); |
| |
# -------------------------------------------------------------- changeuserauth |
| |
} elsif ($userinput =~ /^changeuserauth/) { # encoded & client |
| |
&Debug("Changing authorization"); |
| |
if (($wasenc==1) && isClient) { |
| |
my |
| |
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
| |
chomp($npass); |
| |
&Debug("cmd = ".$cmd." domain= ".$udom. |
| |
"uname =".$uname." umode= ".$umode); |
| |
$npass=&unescape($npass); |
| |
my $proname=&propath($udom,$uname); |
| |
my $passfilename="$proname/passwd"; |
| |
if ($udom ne $currentdomainid) { |
| |
print $client "not_right_domain\n"; |
| |
} else { |
| |
my $result=&make_passwd_file($uname, $umode,$npass, |
| |
$passfilename); |
| |
print $client $result; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------ home |
| |
} elsif ($userinput =~ /^home/) { # client clear or encoded |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname)=split(/:/,$userinput); |
| |
chomp($uname); |
| |
my $proname=propath($udom,$uname); |
| |
if (-e $proname) { |
| |
print $client "found\n"; |
| |
} else { |
| |
print $client "not_found\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ---------------------------------------------------------------------- update |
| |
} elsif ($userinput =~ /^update/) { # client clear or encoded. |
| |
if(isClient) { |
| |
my ($cmd,$fname)=split(/:/,$userinput); |
| |
my $ownership=ishome($fname); |
| |
if ($ownership eq 'not_owner') { |
| |
if (-e $fname) { |
| |
my ($dev,$ino,$mode,$nlink, |
| |
$uid,$gid,$rdev,$size, |
| |
$atime,$mtime,$ctime, |
| |
$blksize,$blocks)=stat($fname); |
| |
my $now=time; |
| |
my $since=$now-$atime; |
| |
if ($since>$perlvar{'lonExpire'}) { |
| |
my $reply= |
| |
&reply("unsub:$fname","$clientname"); |
| |
unlink("$fname"); |
| |
} else { |
| |
my $transname="$fname.in.transfer"; |
| |
my $remoteurl= |
| |
&reply("sub:$fname","$clientname"); |
| |
my $response; |
| |
{ |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',"$remoteurl"); |
| |
$response=$ua->request($request,$transname); |
| |
} |
| |
if ($response->is_error()) { |
| |
unlink($transname); |
| |
my $message=$response->status_line; |
| |
&logthis( |
| |
"LWP GET: $message for $fname ($remoteurl)"); |
| |
} else { |
| |
if ($remoteurl!~/\.meta$/) { |
| |
my $ua=new LWP::UserAgent; |
| |
my $mrequest= |
| |
new HTTP::Request('GET',$remoteurl.'.meta'); |
| |
my $mresponse= |
| |
$ua->request($mrequest,$fname.'.meta'); |
| |
if ($mresponse->is_error()) { |
| |
unlink($fname.'.meta'); |
| |
} |
| |
} |
| |
rename($transname,$fname); |
| |
} |
| |
} |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "not_found\n"; |
| |
} |
| |
} else { |
| |
print $client "rejected\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------- fetch a user file from a remote server |
| |
} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc. |
| |
if(isClient) { |
| |
my ($cmd,$fname)=split(/:/,$userinput); |
| |
my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); |
| |
my $udir=propath($udom,$uname).'/userfiles'; |
| |
unless (-e $udir) { mkdir($udir,0770); } |
| |
if (-e $udir) { |
| |
$ufile=~s/^[\.\~]+//; |
| |
my $path = $udir; |
| |
if ($ufile =~m|(.+)/([^/]+)$|) { |
| |
my @parts=split('/',$1); |
| |
foreach my $part (@parts) { |
| |
$path .= '/'.$part; |
| |
if ((-e $path)!=1) { |
| |
mkdir($path,0770); |
| |
} |
| |
} |
| |
} |
| |
my $destname=$udir.'/'.$ufile; |
| |
my $transname=$udir.'/'.$ufile.'.in.transit'; |
| |
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; |
| |
my $response; |
| |
{ |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',"$remoteurl"); |
| |
$response=$ua->request($request,$transname); |
| |
} |
| |
if ($response->is_error()) { |
| |
unlink($transname); |
| |
my $message=$response->status_line; |
| |
&logthis("LWP GET: $message for $fname ($remoteurl)"); |
| |
print $client "failed\n"; |
| |
} else { |
| |
if (!rename($transname,$destname)) { |
| |
&logthis("Unable to move $transname to $destname"); |
| |
unlink($transname); |
| |
print $client "failed\n"; |
| |
} else { |
| |
print $client "ok\n"; |
| |
} |
| |
} |
| |
} else { |
| |
print $client "not_home\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
} |
| |
# --------------------------------------------------------- remove a user file |
| |
} elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc. |
| |
if(isClient) { |
| |
my ($cmd,$fname)=split(/:/,$userinput); |
| |
my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); |
| |
&logthis("$udom - $uname - $ufile"); |
| |
if ($ufile =~m|/\.\./|) { |
| |
# any files paths with /../ in them refuse |
| |
# to deal with |
| |
print $client "refused\n"; |
| |
} else { |
| |
my $udir=propath($udom,$uname); |
| |
if (-e $udir) { |
| |
my $file=$udir.'/userfiles/'.$ufile; |
| |
if (-e $file) { |
| |
unlink($file); |
| |
if (-e $file) { |
| |
print $client "failed\n"; |
| |
} else { |
| |
print $client "ok\n"; |
| |
} |
| |
} else { |
| |
print $client "not_found\n"; |
| |
} |
| |
} else { |
| |
print $client "not_home\n"; |
| |
} |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
} |
| |
# ------------------------------------------ authenticate access to a user file |
| |
} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only |
| |
if(isClient) { |
| |
my ($cmd,$fname,$session)=split(/:/,$userinput); |
| |
chomp($session); |
| |
my $reply='non_auth'; |
| |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
| |
$session.'.id')) { |
| |
while (my $line=<ENVIN>) { |
| |
if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; } |
| |
} |
| |
close(ENVIN); |
| |
print $client $reply."\n"; |
| |
} else { |
| |
print $client "invalid_token\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ----------------------------------------------------------------- unsubscribe |
| |
} elsif ($userinput =~ /^unsub/) { |
| |
if(isClient) { |
| |
my ($cmd,$fname)=split(/:/,$userinput); |
| |
if (-e $fname) { |
| |
print $client &unsub($fname,$clientip); |
| |
} else { |
| |
print $client "not_found\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------- subscribe |
| |
} elsif ($userinput =~ /^sub/) { |
| |
if(isClient) { |
| |
print $client &subscribe($userinput,$clientip); |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------- current version |
| |
} elsif ($userinput =~ /^currentversion/) { |
| |
if(isClient) { |
| |
my ($cmd,$fname)=split(/:/,$userinput); |
| |
print $client ¤tversion($fname)."\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------- log |
| |
} elsif ($userinput =~ /^log/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
{ |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/activity.log")) { |
| |
print $hfh "$now:$clientname:$what\n"; |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." IO::File->new Failed " |
| |
."while attempting log\n"; |
| |
} |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------- put |
| |
} elsif ($userinput =~ /^put/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$what) |
| |
=split(/:/,$userinput,5); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
if ($namespace ne 'roles') { |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
my @pairs=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File', |
| |
"$proname/$namespace.db", |
| |
&GDBM_WRCREAT(),0640)) { |
| |
unless ($namespace=~/^nohist\_/) { |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/$namespace.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 put\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting put\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------- inc |
| |
} elsif ($userinput =~ /^inc:/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$what) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
if ($namespace ne 'roles') { |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
my @pairs=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File', |
| |
"$proname/$namespace.db", |
| |
&GDBM_WRCREAT(),0640)) { |
| |
unless ($namespace=~/^nohist\_/) { |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; } |
| |
} |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
# We could check that we have a number... |
| |
if (! defined($value) || $value eq '') { |
| |
$value = 1; |
| |
} |
| |
$hash{$key}+=$value; |
| |
} |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) failed ". |
| |
"while attempting inc\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting inc\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------------------------------------- rolesput |
| |
} elsif ($userinput =~ /^rolesput/) { |
| |
if(isClient) { |
| |
&Debug("rolesput"); |
| |
if ($wasenc==1) { |
| |
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
| |
=split(/:/,$userinput); |
| |
&Debug("cmd = ".$cmd." exedom= ".$exedom. |
| |
"user = ".$exeuser." udom=".$udom. |
| |
"what = ".$what); |
| |
my $namespace='roles'; |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
my @pairs=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
| |
{ |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
| |
print $hfh "P:$now:$exedom:$exeuser:$what\n"; |
| |
} |
| |
} |
| |
|
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
&ManagePermissions($key, $udom, $uname, |
| |
&GetAuthType( $udom, |
| |
$uname)); |
| |
$hash{$key}=$value; |
| |
} |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting rolesput\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting rolesput\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------------------------------------- rolesdel |
| |
} elsif ($userinput =~ /^rolesdel/) { |
| |
if(isClient) { |
| |
&Debug("rolesdel"); |
| |
if ($wasenc==1) { |
| |
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
| |
=split(/:/,$userinput); |
| |
&Debug("cmd = ".$cmd." exedom= ".$exedom. |
| |
"user = ".$exeuser." udom=".$udom. |
| |
"what = ".$what); |
| |
my $namespace='roles'; |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
my @rolekeys=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
| |
{ |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
| |
print $hfh "D:$now:$exedom:$exeuser:$what\n"; |
| |
} |
| |
} |
| |
foreach my $key (@rolekeys) { |
| |
delete $hash{$key}; |
| |
} |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting rolesdel\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting rolesdel\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------- get |
| |
} elsif ($userinput =~ /^get/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$what) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
chomp($what); |
| |
my @queries=split(/\&/,$what); |
| |
my $proname=propath($udom,$uname); |
| |
my $qresult=''; |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.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 get\n"; |
| |
} |
| |
} else { |
| |
if ($!+0 == 2) { |
| |
print $client "error:No such file or ". |
| |
"GDBM reported bad block error\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting get\n"; |
| |
} |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------ eget |
| |
} elsif ($userinput =~ /^eget/) { |
| |
if (isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$what) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
chomp($what); |
| |
my @queries=split(/\&/,$what); |
| |
my $proname=propath($udom,$uname); |
| |
my $qresult=''; |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
| |
for (my $i=0;$i<=$#queries;$i++) { |
| |
$qresult.="$hash{$queries[$i]}&"; |
| |
} |
| |
if (untie(%hash)) { |
| |
$qresult=~s/\&$//; |
| |
if ($cipher) { |
| |
my $cmdlength=length($qresult); |
| |
$qresult.=" "; |
| |
my $encqresult=''; |
| |
for |
| |
(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { |
| |
$encqresult.= |
| |
unpack("H16", |
| |
$cipher->encrypt(substr($qresult,$encidx,8))); |
| |
} |
| |
print $client "enc:$cmdlength:$encqresult\n"; |
| |
} else { |
| |
print $client "error:no_key\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting eget\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting eget\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------- del |
| |
} elsif ($userinput =~ /^del/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$what) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
my @keys=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
| |
unless ($namespace=~/^nohist\_/) { |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; } |
| |
} |
| |
foreach my $key (@keys) { |
| |
delete($hash{$key}); |
| |
} |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting del\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting del\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------------ keys |
| |
} elsif ($userinput =~ /^keys/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
my $proname=propath($udom,$uname); |
| |
my $qresult=''; |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
| |
foreach my $key (keys %hash) { |
| |
$qresult.="$key&"; |
| |
} |
| |
if (untie(%hash)) { |
| |
$qresult=~s/\&$//; |
| |
print $client "$qresult\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting keys\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting keys\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ----------------------------------------------------------------- dumpcurrent |
| |
} elsif ($userinput =~ /^currentdump/) { |
| |
if (isClient) { |
| |
my ($cmd,$udom,$uname,$namespace) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
my $qresult=''; |
| |
my $proname=propath($udom,$uname); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File', |
| |
"$proname/$namespace.db", |
| |
&GDBM_READER(),0640)) { |
| |
# Structure of %data: |
| |
# $data{$symb}->{$parameter}=$value; |
| |
# $data{$symb}->{'v.'.$parameter}=$version; |
| |
# since $parameter will be unescaped, we do not |
| |
# have to worry about silly parameter names... |
| |
my %data = (); |
| |
while (my ($key,$value) = each(%hash)) { |
| |
my ($v,$symb,$param) = split(/:/,$key); |
| |
next if ($v eq 'version' || $symb eq 'keys'); |
| |
next if (exists($data{$symb}) && |
| |
exists($data{$symb}->{$param}) && |
| |
$data{$symb}->{'v.'.$param} > $v); |
| |
$data{$symb}->{$param}=$value; |
| |
$data{$symb}->{'v.'.$param}=$v; |
| |
} |
| |
if (untie(%hash)) { |
| |
while (my ($symb,$param_hash) = each(%data)) { |
| |
while(my ($param,$value) = each (%$param_hash)){ |
| |
next if ($param =~ /^v\./); |
| |
$qresult.=$symb.':'.$param.'='.$value.'&'; |
| |
} |
| |
} |
| |
chop($qresult); |
| |
print $client "$qresult\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting currentdump\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting currentdump\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
} |
| |
# ------------------------------------------------------------------------ dump |
| |
} elsif ($userinput =~ /^dump/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$regexp) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
if (defined($regexp)) { |
| |
$regexp=&unescape($regexp); |
| |
} else { |
| |
$regexp='.'; |
| |
} |
| |
my $qresult=''; |
| |
my $proname=propath($udom,$uname); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
| |
while (my ($key,$value) = each(%hash)) { |
| |
if ($regexp eq '.') { |
| |
$qresult.=$key.'='.$value.'&'; |
| |
} else { |
| |
my $unescapeKey = &unescape($key); |
| |
if (eval('$unescapeKey=~/$regexp/')) { |
| |
$qresult.="$key=$value&"; |
| |
} |
| |
} |
| |
} |
| |
if (untie(%hash)) { |
| |
chop($qresult); |
| |
print $client "$qresult\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting dump\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting dump\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ----------------------------------------------------------------------- store |
| |
} elsif ($userinput =~ /^store/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$rid,$what) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
if ($namespace ne 'roles') { |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
my @pairs=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
| |
unless ($namespace=~/^nohist\_/) { |
| |
my $hfh; |
| |
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
| |
print $hfh "P:$now:$rid:$what\n"; |
| |
} |
| |
} |
| |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
| |
my $key; |
| |
$hash{"version:$rid"}++; |
| |
my $version=$hash{"version:$rid"}; |
| |
my $allkeys=''; |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
$allkeys.=$key.':'; |
| |
$hash{"$version:$rid:$key"}=$value; |
| |
} |
| |
$hash{"$version:$rid:timestamp"}=$now; |
| |
$allkeys.='timestamp'; |
| |
$hash{"$version:keys:$rid"}=$allkeys; |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting store\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting store\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# --------------------------------------------------------------------- restore |
| |
} elsif ($userinput =~ /^restore/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$uname,$namespace,$rid) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
chomp($rid); |
| |
my $proname=propath($udom,$uname); |
| |
my $qresult=''; |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
| |
my $version=$hash{"version:$rid"}; |
| |
$qresult.="version=$version&"; |
| |
my $scope; |
| |
for ($scope=1;$scope<=$version;$scope++) { |
| |
my $vkeys=$hash{"$scope:keys:$rid"}; |
| |
my @keys=split(/:/,$vkeys); |
| |
my $key; |
| |
$qresult.="$scope:keys=$vkeys&"; |
| |
foreach $key (@keys) { |
| |
$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; |
| |
} |
| |
} |
| |
if (untie(%hash)) { |
| |
$qresult=~s/\&$//; |
| |
print $client "$qresult\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting restore\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting restore\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------------------------------------- chatsend |
| |
} elsif ($userinput =~ /^chatsend/) { |
| |
if(isClient) { |
| |
my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); |
| |
&chatadd($cdom,$cnum,$newpost); |
| |
print $client "ok\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# -------------------------------------------------------------------- chatretr |
| |
} elsif ($userinput =~ /^chatretr/) { |
| |
if(isClient) { |
| |
my |
| |
($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); |
| |
my $reply=''; |
| |
foreach (&getchat($cdom,$cnum,$udom,$uname)) { |
| |
$reply.=&escape($_).':'; |
| |
} |
| |
$reply=~s/\:$//; |
| |
print $client $reply."\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------- querysend |
| |
} elsif ($userinput =~ /^querysend/) { |
| |
if (isClient) { |
| |
my ($cmd,$query, |
| |
$arg1,$arg2,$arg3)=split(/\:/,$userinput); |
| |
$query=~s/\n*$//g; |
| |
print $client "". |
| |
sqlreply("$clientname\&$query". |
| |
"\&$arg1"."\&$arg2"."\&$arg3")."\n"; |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ------------------------------------------------------------------ queryreply |
| |
} elsif ($userinput =~ /^queryreply/) { |
| |
if(isClient) { |
| |
my ($cmd,$id,$reply)=split(/:/,$userinput); |
| |
my $store; |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
if ($store=IO::File->new(">$execdir/tmp/$id")) { |
| |
$reply=~s/\&/\n/g; |
| |
print $store $reply; |
| |
close $store; |
| |
my $store2=IO::File->new(">$execdir/tmp/$id.end"); |
| |
print $store2 "done\n"; |
| |
close $store2; |
| |
print $client "ok\n"; |
| |
} |
| |
else { |
| |
print $client "error: ".($!+0) |
| |
." IO::File->new Failed ". |
| |
"while attempting queryreply\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ----------------------------------------------------------------- courseidput |
| |
} elsif ($userinput =~ /^courseidput/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
| |
chomp($what); |
| |
$udom=~s/\W//g; |
| |
my $proname= |
| |
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; |
| |
my $now=time; |
| |
my @pairs=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$descr,$inst_code)=split(/=/,$pair); |
| |
$hash{$key}=$descr.':'.$inst_code.':'.$now; |
| |
} |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting courseidput\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting courseidput\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ---------------------------------------------------------------- courseiddump |
| |
} elsif ($userinput =~ /^courseiddump/) { |
| |
if(isClient) { |
| |
my ($cmd,$udom,$since,$description) |
| |
=split(/:/,$userinput); |
| |
if (defined($description)) { |
| |
$description=&unescape($description); |
| |
} else { |
| |
$description='.'; |
| |
} |
| |
unless (defined($since)) { $since=0; } |
| |
my $qresult=''; |
| |
my $proname= |
| |
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
| |
while (my ($key,$value) = each(%hash)) { |
| |
my ($descr,$lasttime,$inst_code); |
| |
if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { |
| |
($descr,$inst_code,$lasttime)=($1,$2,$3); |
| |
} else { |
| |
($descr,$lasttime) = split(/\:/,$value); |
| |
} |
| |
if ($lasttime<$since) { next; } |
| |
if ($description eq '.') { |
| |
$qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
| |
} else { |
| |
my $unescapeVal = &unescape($descr); |
| |
if (eval('$unescapeVal=~/\Q$description\E/i')) { |
| |
$qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
| |
} |
| |
} |
| |
} |
| |
if (untie(%hash)) { |
| |
chop($qresult); |
| |
print $client "$qresult\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting courseiddump\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting courseiddump\n"; |
| |
} |
| |
} else { |
| |
Reply($client, "refused\n", $userinput); |
| |
|
| |
} |
| |
# ----------------------------------------------------------------------- idput |
| |
} elsif ($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); |
| |
|
| |
} |
| |
# ----------------------------------------- portfolio directory list (portls) |
| |
} elsif ($userinput =~ /^portls/) { |
| |
if(isClient) { |
| |
my ($cmd,$uname,$udom)=split(/:/,$userinput); |
| |
my $udir=propath($udom,$uname).'/userfiles/portfolio'; |
| |
my $dirLine=''; |
| |
my $dirContents=''; |
| |
if (opendir(LSDIR,$udir.'/')){ |
| |
while ($dirLine = readdir(LSDIR)){ |
| |
$dirContents = $dirContents.$dirLine.'<br />'; |
| |
} |
| |
} else { |
| |
$dirContents = "No directory found\n"; |
| |
} |
| |
print $client $dirContents."\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? |
| |
} elsif ($userinput =~/^autorun:/) { |
| |
if (isClient) { |
| |
my ($cmd,$cdom) = split(/:/,$userinput); |
| |
my $outcome = &localenroll::run($cdom); |
| |
print $client "$outcome\n"; |
| |
} else { |
| |
print $client "0\n"; |
| |
} |
| |
#------------------------------- get official sections (for auto-enrollment). |
| |
} elsif ($userinput =~/^autogetsections:/) { |
| |
if (isClient) { |
| |
my ($cmd,$coursecode,$cdom)=split(/:/,$userinput); |
| |
my @secs = &localenroll::get_sections($coursecode,$cdom); |
| |
my $seclist = &escape(join(':',@secs)); |
| |
print $client "$seclist\n"; |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
#----------------------- validate owner of new course section (for auto-enrollment). |
| |
} elsif ($userinput =~/^autonewcourse:/) { |
| |
if (isClient) { |
| |
my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput); |
| |
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); |
| |
print $client "$outcome\n"; |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
#-------------- validate course section in schedule of classes (for auto-enrollment). |
| |
} elsif ($userinput =~/^autovalidatecourse:/) { |
| |
if (isClient) { |
| |
my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput); |
| |
my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom); |
| |
print $client "$outcome\n"; |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
#--------------------------- create password for new user (for auto-enrollment). |
| |
} elsif ($userinput =~/^autocreatepassword:/) { |
| |
if (isClient) { |
| |
my ($cmd,$authparam,$cdom)=split(/:/,$userinput); |
| |
my ($create_passwd,$authchk); |
| |
($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom); |
| |
print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n"; |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
#--------------------------- read and remove temporary files (for auto-enrollment). |
| |
} elsif ($userinput =~/^autoretrieve:/) { |
| |
if (isClient) { |
| |
my ($cmd,$filename) = split(/:/,$userinput); |
| |
my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; |
| |
if ( (-e $source) && ($filename ne '') ) { |
| |
my $reply = ''; |
| |
if (open(my $fh,$source)) { |
| |
while (<$fh>) { |
| |
chomp($_); |
| |
$_ =~ s/^\s+//g; |
| |
$_ =~ s/\s+$//g; |
| |
$reply .= $_; |
| |
} |
| |
close($fh); |
| |
print $client &escape($reply)."\n"; |
| |
# unlink($source); |
| |
} else { |
| |
print $client "error\n"; |
| |
} |
| |
} else { |
| |
print $client "error\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
#--------------------- read and retrieve institutional code format (for support form). |
| |
} elsif ($userinput =~/^autoinstcodeformat:/) { |
| |
if (isClient) { |
| |
my $reply; |
| |
my($cmd,$cdom,$course) = split(/:/,$userinput); |
| |
my @pairs = split/\&/,$course; |
| |
my %instcodes = (); |
| |
my %codes = (); |
| |
my @codetitles = (); |
| |
my %cat_titles = (); |
| |
my %cat_order = (); |
| |
foreach (@pairs) { |
| |
my ($key,$value) = split/=/,$_; |
| |
$instcodes{&unescape($key)} = &unescape($value); |
| |
} |
| |
my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order); |
| |
if ($formatreply eq 'ok') { |
| |
my $codes_str = &hash2str(%codes); |
| |
my $codetitles_str = &array2str(@codetitles); |
| |
my $cat_titles_str = &hash2str(%cat_titles); |
| |
my $cat_order_str = &hash2str(%cat_order); |
| |
print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
# ------------------------------------------------------------- unknown command |
| |
|
| |
} else { |
| |
# unknown command |
| |
print $client "unknown_cmd\n"; |
| |
} |
| |
# -------------------------------------------------------------------- complete |
| |
Debug("process_request - returning 1"); |
| |
return 1; |
| |
} |
| # |
# |
| # Decipher encoded traffic |
# Decipher encoded traffic |
| # Parameters: |
# Parameters: |
|
Line 1065 sub get_request {
|
Line 2689 sub get_request {
|
| sub decipher { |
sub decipher { |
| my ($input) = @_; |
my ($input) = @_; |
| my $output = ''; |
my $output = ''; |
| |
|
| |
|
| if($cipher) { |
if($cipher) { |
| my($enc, $enclength, $encinput) = split(/:/, $input); |
my($enc, $enclength, $encinput) = split(/:/, $input); |
| for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { |
for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { |
|
Line 1107 sub decipher {
|
Line 2731 sub decipher {
|
| # register a duplicate command handler. |
# register a duplicate command handler. |
| # |
# |
| sub register_handler { |
sub register_handler { |
| my ($request_name, |
my ($request_name,$procedure,$must_encode, $client_ok,$manager_ok) = @_; |
| $procedure, |
|
| $must_encode, |
|
| $client_ok, |
|
| $manager_ok) = @_; |
|
| |
|
| # Don't allow duplication# |
# Don't allow duplication# |
| |
|
|
Line 1396 sub checkchildren {
|
Line 3016 sub checkchildren {
|
| } |
} |
| } |
} |
| sleep 5; |
sleep 5; |
| $SIG{ALRM} = sub { die "timeout" }; |
$SIG{ALRM} = sub { Debug("timeout"); |
| |
die "timeout"; }; |
| $SIG{__DIE__} = 'DEFAULT'; |
$SIG{__DIE__} = 'DEFAULT'; |
| &status("Checking on the children (waiting for reports)"); |
&status("Checking on the children (waiting for reports)"); |
| foreach (sort keys %children) { |
foreach (sort keys %children) { |
|
Line 1448 sub Debug {
|
Line 3069 sub Debug {
|
| # request - Original request from client. |
# request - Original request from client. |
| # |
# |
| sub Reply { |
sub Reply { |
| |
alarm(120); |
| |
my $fd = shift; |
| |
my $reply = shift; |
| |
my $request = shift; |
| |
|
| my ($fd, $reply, $request) = @_; |
my ($fd, $reply, $request) = @_; |
| |
|
| print $fd $reply; |
print $fd $reply; |
| Debug("Request was $request Reply was $reply"); |
Debug("Request was $request Reply was $reply"); |
| |
|
| |
$Transactions++; |
| |
alarm(0); |
| |
|
| |
|
| |
} |
| |
|
| |
|
| |
# |
| |
# Sub to report a failure. |
| |
# This function: |
| |
# - Increments the failure statistic counters. |
| |
# - Invokes Reply to send the error message to the client. |
| |
# Parameters: |
| |
# fd - File descriptor open on the client |
| |
# reply - Reply text to emit. |
| |
# request - The original request message (used by Reply |
| |
# to debug if that's enabled. |
| |
# Implicit outputs: |
| |
# $Failures- The number of failures is incremented. |
| |
# Reply (invoked here) sends a message to the |
| |
# client: |
| |
# |
| |
sub Failure { |
| |
my $fd = shift; |
| |
my $reply = shift; |
| |
my $request = shift; |
| |
|
| |
$Failures++; |
| |
Reply($fd, $reply, $request); # That's simple eh? |
| } |
} |
| # ------------------------------------------------------------------ Log status |
# ------------------------------------------------------------------ Log status |
| |
|
|
Line 1866 sub make_new_child {
|
Line 3519 sub make_new_child {
|
| &logthis("<font color='green'>Established connection: $clientname</font>"); |
&logthis("<font color='green'>Established connection: $clientname</font>"); |
| &status('Will listen to '.$clientname); |
&status('Will listen to '.$clientname); |
| # ------------------------------------------------------------ Process requests |
# ------------------------------------------------------------ Process requests |
| while (my $userinput=<$client>) { |
my $keep_going = 1; |
| chomp($userinput); |
my $user_input; |
| Debug("Request = $userinput\n"); |
while(($user_input = get_request) && $keep_going) { |
| &status('Processing '.$clientname.': '.$userinput); |
alarm(120); |
| my $wasenc=0; |
Debug("Main: Got $user_input\n"); |
| alarm(120); |
$keep_going = &process_request($user_input); |
| # ------------------------------------------------------------ See if encrypted |
|
| if ($userinput =~ /^enc/) { |
|
| if ($cipher) { |
|
| my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput); |
|
| $userinput=''; |
|
| for (my $encidx=0;$encidx<length($encinput);$encidx+=16) { |
|
| $userinput.= |
|
| $cipher->decrypt( |
|
| pack("H16",substr($encinput,$encidx,16)) |
|
| ); |
|
| } |
|
| $userinput=substr($userinput,0,$cmdlength); |
|
| $wasenc=1; |
|
| } |
|
| } |
|
| |
|
| # ------------------------------------------------------------- Normal commands |
|
| # ------------------------------------------------------------------------ ping |
|
| if ($userinput =~ /^ping/) { # client only |
|
| if(isClient) { |
|
| print $client "$currenthostid\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| } |
|
| # ------------------------------------------------------------------------ pong |
|
| }elsif ($userinput =~ /^pong/) { # client only |
|
| if(isClient) { |
|
| my $reply=&reply("ping",$clientname); |
|
| print $client "$currenthostid:$reply\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| } |
|
| # ------------------------------------------------------------------------ ekey |
|
| } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs |
|
| my $buildkey=time.$$.int(rand 100000); |
|
| $buildkey=~tr/1-6/A-F/; |
|
| $buildkey=int(rand 100000).$buildkey.int(rand 100000); |
|
| my $key=$currenthostid.$clientname; |
|
| $key=~tr/a-z/A-Z/; |
|
| $key=~tr/G-P/0-9/; |
|
| $key=~tr/Q-Z/0-9/; |
|
| $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; |
|
| $key=substr($key,0,32); |
|
| my $cipherkey=pack("H32",$key); |
|
| $cipher=new IDEA $cipherkey; |
|
| print $client "$buildkey\n"; |
|
| # ------------------------------------------------------------------------ load |
|
| } elsif ($userinput =~ /^load/) { # client only |
|
| if (isClient) { |
|
| my $loadavg; |
|
| { |
|
| my $loadfile=IO::File->new('/proc/loadavg'); |
|
| $loadavg=<$loadfile>; |
|
| } |
|
| $loadavg =~ s/\s.*//g; |
|
| my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; |
|
| print $client "$loadpercent\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------------------------------------- userload |
|
| } elsif ($userinput =~ /^userload/) { # client only |
|
| if(isClient) { |
|
| my $userloadpercent=&userload(); |
|
| print $client "$userloadpercent\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # |
|
| # Transactions requiring encryption: |
|
| # |
|
| # ----------------------------------------------------------------- currentauth |
|
| } elsif ($userinput =~ /^currentauth/) { |
|
| if (($wasenc==1) && isClient) { # Encoded & client only. |
|
| my ($cmd,$udom,$uname)=split(/:/,$userinput); |
|
| my $result = GetAuthType($udom, $uname); |
|
| if($result eq "nouser") { |
|
| print $client "unknown_user\n"; |
|
| } |
|
| else { |
|
| print $client "$result\n" |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| #--------------------------------------------------------------------- pushfile |
|
| } elsif($userinput =~ /^pushfile/) { # encoded & manager. |
|
| if(($wasenc == 1) && isManager) { |
|
| my $cert = GetCertificate($userinput); |
|
| if(ValidManager($cert)) { |
|
| my $reply = PushFile($userinput); |
|
| print $client "$reply\n"; |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| #--------------------------------------------------------------------- reinit |
|
| } elsif($userinput =~ /^reinit/) { # Encoded and manager |
|
| if (($wasenc == 1) && isManager) { |
|
| my $cert = GetCertificate($userinput); |
|
| if(ValidManager($cert)) { |
|
| chomp($userinput); |
|
| my $reply = ReinitProcess($userinput); |
|
| print $client "$reply\n"; |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| } |
|
| #------------------------------------------------------------------------- edit |
|
| } elsif ($userinput =~ /^edit/) { # encoded and manager: |
|
| if(($wasenc ==1) && (isManager)) { |
|
| my $cert = GetCertificate($userinput); |
|
| if(ValidManager($cert)) { |
|
| my($command, $filetype, $script) = split(/:/, $userinput); |
|
| if (($filetype eq "hosts") || ($filetype eq "domain")) { |
|
| if($script ne "") { |
|
| Reply($client, EditFile($userinput)); |
|
| } else { |
|
| Reply($client,"refused\n",$userinput); |
|
| } |
|
| } else { |
|
| Reply($client,"refused\n",$userinput); |
|
| } |
|
| } else { |
|
| Reply($client,"refused\n",$userinput); |
|
| } |
|
| } else { |
|
| Reply($client,"refused\n",$userinput); |
|
| } |
|
| # ------------------------------------------------------------------------ auth |
|
| } elsif ($userinput =~ /^auth/) { # Encoded and client only. |
|
| if (($wasenc==1) && isClient) { |
|
| my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); |
|
| chomp($upass); |
|
| $upass=unescape($upass); |
|
| my $proname=propath($udom,$uname); |
|
| my $passfilename="$proname/passwd"; |
|
| if (-e $passfilename) { |
|
| my $pf = IO::File->new($passfilename); |
|
| my $realpasswd=<$pf>; |
|
| chomp($realpasswd); |
|
| my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
|
| my $pwdcorrect=0; |
|
| if ($howpwd eq 'internal') { |
|
| &Debug("Internal auth"); |
|
| $pwdcorrect= |
|
| (crypt($upass,$contentpwd) eq $contentpwd); |
|
| } elsif ($howpwd eq 'unix') { |
|
| &Debug("Unix auth"); |
|
| if((getpwnam($uname))[1] eq "") { #no such user! |
|
| $pwdcorrect = 0; |
|
| } else { |
|
| $contentpwd=(getpwnam($uname))[1]; |
|
| my $pwauth_path="/usr/local/sbin/pwauth"; |
|
| unless ($contentpwd eq 'x') { |
|
| $pwdcorrect= |
|
| (crypt($upass,$contentpwd) eq |
|
| $contentpwd); |
|
| } |
|
| |
|
| elsif (-e $pwauth_path) { |
|
| open PWAUTH, "|$pwauth_path" or |
|
| die "Cannot invoke authentication"; |
|
| print PWAUTH "$uname\n$upass\n"; |
|
| close PWAUTH; |
|
| $pwdcorrect=!$?; |
|
| } |
|
| } |
|
| } elsif ($howpwd eq 'krb4') { |
|
| my $null=pack("C",0); |
|
| unless ($upass=~/$null/) { |
|
| my $krb4_error = &Authen::Krb4::get_pw_in_tkt |
|
| ($uname,"",$contentpwd,'krbtgt', |
|
| $contentpwd,1,$upass); |
|
| if (!$krb4_error) { |
|
| $pwdcorrect = 1; |
|
| } else { |
|
| $pwdcorrect=0; |
|
| # log error if it is not a bad password |
|
| if ($krb4_error != 62) { |
|
| &logthis('krb4:'.$uname.','. |
|
| &Authen::Krb4::get_err_txt($Authen::Krb4::error)); |
|
| } |
|
| } |
|
| } |
|
| } elsif ($howpwd eq 'krb5') { |
|
| my $null=pack("C",0); |
|
| unless ($upass=~/$null/) { |
|
| my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); |
|
| my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; |
|
| my $krbserver=&Authen::Krb5::parse_name($krbservice); |
|
| my $credentials=&Authen::Krb5::cc_default(); |
|
| $credentials->initialize($krbclient); |
|
| my $krbreturn = |
|
| &Authen::Krb5::get_in_tkt_with_password( |
|
| $krbclient,$krbserver,$upass,$credentials); |
|
| # unless ($krbreturn) { |
|
| # &logthis("Krb5 Error: ". |
|
| # &Authen::Krb5::error()); |
|
| # } |
|
| $pwdcorrect = ($krbreturn == 1); |
|
| } else { $pwdcorrect=0; } |
|
| } elsif ($howpwd eq 'localauth') { |
|
| $pwdcorrect=&localauth::localauth($uname,$upass, |
|
| $contentpwd); |
|
| } |
|
| if ($pwdcorrect) { |
|
| print $client "authorized\n"; |
|
| } else { |
|
| print $client "non_authorized\n"; |
|
| } |
|
| } else { |
|
| print $client "unknown_user\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ---------------------------------------------------------------------- passwd |
|
| } elsif ($userinput =~ /^passwd/) { # encoded and client |
|
| if (($wasenc==1) && isClient) { |
|
| my |
|
| ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); |
|
| chomp($npass); |
|
| $upass=&unescape($upass); |
|
| $npass=&unescape($npass); |
|
| &Debug("Trying to change password for $uname"); |
|
| my $proname=propath($udom,$uname); |
|
| my $passfilename="$proname/passwd"; |
|
| if (-e $passfilename) { |
|
| my $realpasswd; |
|
| { my $pf = IO::File->new($passfilename); |
|
| $realpasswd=<$pf>; } |
|
| chomp($realpasswd); |
|
| my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
|
| if ($howpwd eq 'internal') { |
|
| &Debug("internal auth"); |
|
| if (crypt($upass,$contentpwd) eq $contentpwd) { |
|
| my $salt=time; |
|
| $salt=substr($salt,6,2); |
|
| my $ncpass=crypt($npass,$salt); |
|
| { |
|
| my $pf; |
|
| if ($pf = IO::File->new(">$passfilename")) { |
|
| print $pf "internal:$ncpass\n"; |
|
| &logthis("Result of password change for $uname: pwchange_success"); |
|
| print $client "ok\n"; |
|
| } else { |
|
| &logthis("Unable to open $uname passwd to change password"); |
|
| print $client "non_authorized\n"; |
|
| } |
|
| } |
|
| |
|
| } else { |
|
| print $client "non_authorized\n"; |
|
| } |
|
| } elsif ($howpwd eq 'unix') { |
|
| # Unix means we have to access /etc/password |
|
| # one way or another. |
|
| # First: Make sure the current password is |
|
| # correct |
|
| &Debug("auth is unix"); |
|
| $contentpwd=(getpwnam($uname))[1]; |
|
| my $pwdcorrect = "0"; |
|
| my $pwauth_path="/usr/local/sbin/pwauth"; |
|
| unless ($contentpwd eq 'x') { |
|
| $pwdcorrect= |
|
| (crypt($upass,$contentpwd) eq $contentpwd); |
|
| } elsif (-e $pwauth_path) { |
|
| open PWAUTH, "|$pwauth_path" or |
|
| die "Cannot invoke authentication"; |
|
| print PWAUTH "$uname\n$upass\n"; |
|
| close PWAUTH; |
|
| &Debug("exited pwauth with $? ($uname,$upass) "); |
|
| $pwdcorrect=($? == 0); |
|
| } |
|
| if ($pwdcorrect) { |
|
| my $execdir=$perlvar{'lonDaemons'}; |
|
| &Debug("Opening lcpasswd pipeline"); |
|
| my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log"); |
|
| print $pf "$uname\n$npass\n$npass\n"; |
|
| close $pf; |
|
| my $err = $?; |
|
| my $result = ($err>0 ? 'pwchange_failure' |
|
| : 'ok'); |
|
| &logthis("Result of password change for $uname: ". |
|
| &lcpasswdstrerror($?)); |
|
| print $client "$result\n"; |
|
| } else { |
|
| print $client "non_authorized\n"; |
|
| } |
|
| } else { |
|
| print $client "auth_mode_error\n"; |
|
| } |
|
| } else { |
|
| print $client "unknown_user\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------------------------------------- makeuser |
|
| } elsif ($userinput =~ /^makeuser/) { # encoded and client. |
|
| &Debug("Make user received"); |
|
| my $oldumask=umask(0077); |
|
| if (($wasenc==1) && isClient) { |
|
| my |
|
| ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
|
| &Debug("cmd =".$cmd." $udom =".$udom. |
|
| " uname=".$uname); |
|
| chomp($npass); |
|
| $npass=&unescape($npass); |
|
| my $proname=propath($udom,$uname); |
|
| my $passfilename="$proname/passwd"; |
|
| &Debug("Password file created will be:". |
|
| $passfilename); |
|
| if (-e $passfilename) { |
|
| print $client "already_exists\n"; |
|
| } elsif ($udom ne $currentdomainid) { |
|
| print $client "not_right_domain\n"; |
|
| } else { |
|
| my @fpparts=split(/\//,$proname); |
|
| my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; |
|
| my $fperror=''; |
|
| for (my $i=3;$i<=$#fpparts;$i++) { |
|
| $fpnow.='/'.$fpparts[$i]; |
|
| unless (-e $fpnow) { |
|
| unless (mkdir($fpnow,0777)) { |
|
| $fperror="error: ".($!+0) |
|
| ." mkdir failed while attempting " |
|
| ."makeuser"; |
|
| } |
|
| } |
|
| } |
|
| unless ($fperror) { |
|
| my $result=&make_passwd_file($uname, $umode,$npass, |
|
| $passfilename); |
|
| print $client $result; |
|
| } else { |
|
| print $client "$fperror\n"; |
|
| } |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| umask($oldumask); |
|
| # -------------------------------------------------------------- changeuserauth |
|
| } elsif ($userinput =~ /^changeuserauth/) { # encoded & client |
|
| &Debug("Changing authorization"); |
|
| if (($wasenc==1) && isClient) { |
|
| my |
|
| ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
|
| chomp($npass); |
|
| &Debug("cmd = ".$cmd." domain= ".$udom. |
|
| "uname =".$uname." umode= ".$umode); |
|
| $npass=&unescape($npass); |
|
| my $proname=&propath($udom,$uname); |
|
| my $passfilename="$proname/passwd"; |
|
| if ($udom ne $currentdomainid) { |
|
| print $client "not_right_domain\n"; |
|
| } else { |
|
| my $result=&make_passwd_file($uname, $umode,$npass, |
|
| $passfilename); |
|
| print $client $result; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------ home |
|
| } elsif ($userinput =~ /^home/) { # client clear or encoded |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname)=split(/:/,$userinput); |
|
| chomp($uname); |
|
| my $proname=propath($udom,$uname); |
|
| if (-e $proname) { |
|
| print $client "found\n"; |
|
| } else { |
|
| print $client "not_found\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ---------------------------------------------------------------------- update |
|
| } elsif ($userinput =~ /^update/) { # client clear or encoded. |
|
| if(isClient) { |
|
| my ($cmd,$fname)=split(/:/,$userinput); |
|
| my $ownership=ishome($fname); |
|
| if ($ownership eq 'not_owner') { |
|
| if (-e $fname) { |
|
| my ($dev,$ino,$mode,$nlink, |
|
| $uid,$gid,$rdev,$size, |
|
| $atime,$mtime,$ctime, |
|
| $blksize,$blocks)=stat($fname); |
|
| my $now=time; |
|
| my $since=$now-$atime; |
|
| if ($since>$perlvar{'lonExpire'}) { |
|
| my $reply= |
|
| &reply("unsub:$fname","$clientname"); |
|
| unlink("$fname"); |
|
| } else { |
|
| my $transname="$fname.in.transfer"; |
|
| my $remoteurl= |
|
| &reply("sub:$fname","$clientname"); |
|
| my $response; |
|
| { |
|
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request('GET',"$remoteurl"); |
|
| $response=$ua->request($request,$transname); |
|
| } |
|
| if ($response->is_error()) { |
|
| unlink($transname); |
|
| my $message=$response->status_line; |
|
| &logthis( |
|
| "LWP GET: $message for $fname ($remoteurl)"); |
|
| } else { |
|
| if ($remoteurl!~/\.meta$/) { |
|
| my $ua=new LWP::UserAgent; |
|
| my $mrequest= |
|
| new HTTP::Request('GET',$remoteurl.'.meta'); |
|
| my $mresponse= |
|
| $ua->request($mrequest,$fname.'.meta'); |
|
| if ($mresponse->is_error()) { |
|
| unlink($fname.'.meta'); |
|
| } |
|
| } |
|
| rename($transname,$fname); |
|
| } |
|
| } |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "not_found\n"; |
|
| } |
|
| } else { |
|
| print $client "rejected\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------- fetch a user file from a remote server |
|
| } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc. |
|
| if(isClient) { |
|
| my ($cmd,$fname)=split(/:/,$userinput); |
|
| my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); |
|
| my $udir=propath($udom,$uname).'/userfiles'; |
|
| unless (-e $udir) { mkdir($udir,0770); } |
|
| if (-e $udir) { |
|
| $ufile=~s/^[\.\~]+//; |
|
| my $path = $udir; |
|
| if ($ufile =~m|(.+)/([^/]+)$|) { |
|
| my @parts=split('/',$1); |
|
| foreach my $part (@parts) { |
|
| $path .= '/'.$part; |
|
| if ((-e $path)!=1) { |
|
| mkdir($path,0770); |
|
| } |
|
| } |
|
| } |
|
| my $destname=$udir.'/'.$ufile; |
|
| my $transname=$udir.'/'.$ufile.'.in.transit'; |
|
| my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; |
|
| my $response; |
|
| { |
|
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request('GET',"$remoteurl"); |
|
| $response=$ua->request($request,$transname); |
|
| } |
|
| if ($response->is_error()) { |
|
| unlink($transname); |
|
| my $message=$response->status_line; |
|
| &logthis("LWP GET: $message for $fname ($remoteurl)"); |
|
| print $client "failed\n"; |
|
| } else { |
|
| if (!rename($transname,$destname)) { |
|
| &logthis("Unable to move $transname to $destname"); |
|
| unlink($transname); |
|
| print $client "failed\n"; |
|
| } else { |
|
| print $client "ok\n"; |
|
| } |
|
| } |
|
| } else { |
|
| print $client "not_home\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| } |
|
| # --------------------------------------------------------- remove a user file |
|
| } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc. |
|
| if(isClient) { |
|
| my ($cmd,$fname)=split(/:/,$userinput); |
|
| my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); |
|
| &logthis("$udom - $uname - $ufile"); |
|
| if ($ufile =~m|/\.\./|) { |
|
| # any files paths with /../ in them refuse |
|
| # to deal with |
|
| print $client "refused\n"; |
|
| } else { |
|
| my $udir=propath($udom,$uname); |
|
| if (-e $udir) { |
|
| my $file=$udir.'/userfiles/'.$ufile; |
|
| if (-e $file) { |
|
| unlink($file); |
|
| if (-e $file) { |
|
| print $client "failed\n"; |
|
| } else { |
|
| print $client "ok\n"; |
|
| } |
|
| } else { |
|
| print $client "not_found\n"; |
|
| } |
|
| } else { |
|
| print $client "not_home\n"; |
|
| } |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| } |
|
| # ------------------------------------------ authenticate access to a user file |
|
| } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only |
|
| if(isClient) { |
|
| my ($cmd,$fname,$session)=split(/:/,$userinput); |
|
| chomp($session); |
|
| my $reply='non_auth'; |
|
| if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
|
| $session.'.id')) { |
|
| while (my $line=<ENVIN>) { |
|
| if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; } |
|
| } |
|
| close(ENVIN); |
|
| print $client $reply."\n"; |
|
| } else { |
|
| print $client "invalid_token\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ----------------------------------------------------------------- unsubscribe |
|
| } elsif ($userinput =~ /^unsub/) { |
|
| if(isClient) { |
|
| my ($cmd,$fname)=split(/:/,$userinput); |
|
| if (-e $fname) { |
|
| print $client &unsub($fname,$clientip); |
|
| } else { |
|
| print $client "not_found\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------- subscribe |
|
| } elsif ($userinput =~ /^sub/) { |
|
| if(isClient) { |
|
| print $client &subscribe($userinput,$clientip); |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------- current version |
|
| } elsif ($userinput =~ /^currentversion/) { |
|
| if(isClient) { |
|
| my ($cmd,$fname)=split(/:/,$userinput); |
|
| print $client ¤tversion($fname)."\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------- log |
|
| } elsif ($userinput =~ /^log/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/activity.log")) { |
|
| print $hfh "$now:$clientname:$what\n"; |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." IO::File->new Failed " |
|
| ."while attempting log\n"; |
|
| } |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------- put |
|
| } elsif ($userinput =~ /^put/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$what) |
|
| =split(/:/,$userinput,5); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| if ($namespace ne 'roles') { |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| my @pairs=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File', |
|
| "$proname/$namespace.db", |
|
| &GDBM_WRCREAT(),0640)) { |
|
| unless ($namespace=~/^nohist\_/) { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/$namespace.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 put\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting put\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------- inc |
|
| } elsif ($userinput =~ /^inc:/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$what) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| if ($namespace ne 'roles') { |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| my @pairs=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File', |
|
| "$proname/$namespace.db", |
|
| &GDBM_WRCREAT(),0640)) { |
|
| unless ($namespace=~/^nohist\_/) { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; } |
|
| } |
|
| foreach my $pair (@pairs) { |
|
| my ($key,$value)=split(/=/,$pair); |
|
| # We could check that we have a number... |
|
| if (! defined($value) || $value eq '') { |
|
| $value = 1; |
|
| } |
|
| $hash{$key}+=$value; |
|
| } |
|
| if (untie(%hash)) { |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) failed ". |
|
| "while attempting inc\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting inc\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------------------------------------- rolesput |
|
| } elsif ($userinput =~ /^rolesput/) { |
|
| if(isClient) { |
|
| &Debug("rolesput"); |
|
| if ($wasenc==1) { |
|
| my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
|
| =split(/:/,$userinput); |
|
| &Debug("cmd = ".$cmd." exedom= ".$exedom. |
|
| "user = ".$exeuser." udom=".$udom. |
|
| "what = ".$what); |
|
| my $namespace='roles'; |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| my @pairs=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
| { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
|
| print $hfh "P:$now:$exedom:$exeuser:$what\n"; |
|
| } |
|
| } |
|
| |
|
| foreach my $pair (@pairs) { |
|
| my ($key,$value)=split(/=/,$pair); |
|
| &ManagePermissions($key, $udom, $uname, |
|
| &GetAuthType( $udom, |
|
| $uname)); |
|
| $hash{$key}=$value; |
|
| } |
|
| if (untie(%hash)) { |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting rolesput\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting rolesput\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------------------------------------- rolesdel |
|
| } elsif ($userinput =~ /^rolesdel/) { |
|
| if(isClient) { |
|
| &Debug("rolesdel"); |
|
| if ($wasenc==1) { |
|
| my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
|
| =split(/:/,$userinput); |
|
| &Debug("cmd = ".$cmd." exedom= ".$exedom. |
|
| "user = ".$exeuser." udom=".$udom. |
|
| "what = ".$what); |
|
| my $namespace='roles'; |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| my @rolekeys=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
| { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
|
| print $hfh "D:$now:$exedom:$exeuser:$what\n"; |
|
| } |
|
| } |
|
| foreach my $key (@rolekeys) { |
|
| delete $hash{$key}; |
|
| } |
|
| if (untie(%hash)) { |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting rolesdel\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting rolesdel\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------- get |
|
| } elsif ($userinput =~ /^get/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$what) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| chomp($what); |
|
| my @queries=split(/\&/,$what); |
|
| my $proname=propath($udom,$uname); |
|
| my $qresult=''; |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.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 get\n"; |
|
| } |
|
| } else { |
|
| if ($!+0 == 2) { |
|
| print $client "error:No such file or ". |
|
| "GDBM reported bad block error\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting get\n"; |
|
| } |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------ eget |
|
| } elsif ($userinput =~ /^eget/) { |
|
| if (isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$what) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| chomp($what); |
|
| my @queries=split(/\&/,$what); |
|
| my $proname=propath($udom,$uname); |
|
| my $qresult=''; |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
| for (my $i=0;$i<=$#queries;$i++) { |
|
| $qresult.="$hash{$queries[$i]}&"; |
|
| } |
|
| if (untie(%hash)) { |
|
| $qresult=~s/\&$//; |
|
| if ($cipher) { |
|
| my $cmdlength=length($qresult); |
|
| $qresult.=" "; |
|
| my $encqresult=''; |
|
| for |
|
| (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { |
|
| $encqresult.= |
|
| unpack("H16", |
|
| $cipher->encrypt(substr($qresult,$encidx,8))); |
|
| } |
|
| print $client "enc:$cmdlength:$encqresult\n"; |
|
| } else { |
|
| print $client "error:no_key\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting eget\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting eget\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------- del |
|
| } elsif ($userinput =~ /^del/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$what) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| my @keys=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
| unless ($namespace=~/^nohist\_/) { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; } |
|
| } |
|
| foreach my $key (@keys) { |
|
| delete($hash{$key}); |
|
| } |
|
| if (untie(%hash)) { |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting del\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting del\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------------ keys |
|
| } elsif ($userinput =~ /^keys/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| my $proname=propath($udom,$uname); |
|
| my $qresult=''; |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
| foreach my $key (keys %hash) { |
|
| $qresult.="$key&"; |
|
| } |
|
| if (untie(%hash)) { |
|
| $qresult=~s/\&$//; |
|
| print $client "$qresult\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting keys\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting keys\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ----------------------------------------------------------------- dumpcurrent |
|
| } elsif ($userinput =~ /^currentdump/) { |
|
| if (isClient) { |
|
| my ($cmd,$udom,$uname,$namespace) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| my $qresult=''; |
|
| my $proname=propath($udom,$uname); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File', |
|
| "$proname/$namespace.db", |
|
| &GDBM_READER(),0640)) { |
|
| # Structure of %data: |
|
| # $data{$symb}->{$parameter}=$value; |
|
| # $data{$symb}->{'v.'.$parameter}=$version; |
|
| # since $parameter will be unescaped, we do not |
|
| # have to worry about silly parameter names... |
|
| my %data = (); |
|
| while (my ($key,$value) = each(%hash)) { |
|
| my ($v,$symb,$param) = split(/:/,$key); |
|
| next if ($v eq 'version' || $symb eq 'keys'); |
|
| next if (exists($data{$symb}) && |
|
| exists($data{$symb}->{$param}) && |
|
| $data{$symb}->{'v.'.$param} > $v); |
|
| $data{$symb}->{$param}=$value; |
|
| $data{$symb}->{'v.'.$param}=$v; |
|
| } |
|
| if (untie(%hash)) { |
|
| while (my ($symb,$param_hash) = each(%data)) { |
|
| while(my ($param,$value) = each (%$param_hash)){ |
|
| next if ($param =~ /^v\./); |
|
| $qresult.=$symb.':'.$param.'='.$value.'&'; |
|
| } |
|
| } |
|
| chop($qresult); |
|
| print $client "$qresult\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting currentdump\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting currentdump\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| } |
|
| # ------------------------------------------------------------------------ dump |
|
| } elsif ($userinput =~ /^dump/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$regexp) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| if (defined($regexp)) { |
|
| $regexp=&unescape($regexp); |
|
| } else { |
|
| $regexp='.'; |
|
| } |
|
| my $qresult=''; |
|
| my $proname=propath($udom,$uname); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
| while (my ($key,$value) = each(%hash)) { |
|
| if ($regexp eq '.') { |
|
| $qresult.=$key.'='.$value.'&'; |
|
| } else { |
|
| my $unescapeKey = &unescape($key); |
|
| if (eval('$unescapeKey=~/$regexp/')) { |
|
| $qresult.="$key=$value&"; |
|
| } |
|
| } |
|
| } |
|
| if (untie(%hash)) { |
|
| chop($qresult); |
|
| print $client "$qresult\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting dump\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting dump\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ----------------------------------------------------------------------- store |
|
| } elsif ($userinput =~ /^store/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$rid,$what) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| if ($namespace ne 'roles') { |
|
| chomp($what); |
|
| my $proname=propath($udom,$uname); |
|
| my $now=time; |
|
| my @pairs=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
| unless ($namespace=~/^nohist\_/) { |
|
| my $hfh; |
|
| if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
|
| print $hfh "P:$now:$rid:$what\n"; |
|
| } |
|
| } |
|
| my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
|
| my $key; |
|
| $hash{"version:$rid"}++; |
|
| my $version=$hash{"version:$rid"}; |
|
| my $allkeys=''; |
|
| foreach my $pair (@pairs) { |
|
| my ($key,$value)=split(/=/,$pair); |
|
| $allkeys.=$key.':'; |
|
| $hash{"$version:$rid:$key"}=$value; |
|
| } |
|
| $hash{"$version:$rid:timestamp"}=$now; |
|
| $allkeys.='timestamp'; |
|
| $hash{"$version:keys:$rid"}=$allkeys; |
|
| if (untie(%hash)) { |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting store\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting store\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # --------------------------------------------------------------------- restore |
|
| } elsif ($userinput =~ /^restore/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$uname,$namespace,$rid) |
|
| =split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
|
| $namespace=~s/\W//g; |
|
| chomp($rid); |
|
| my $proname=propath($udom,$uname); |
|
| my $qresult=''; |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
| my $version=$hash{"version:$rid"}; |
|
| $qresult.="version=$version&"; |
|
| my $scope; |
|
| for ($scope=1;$scope<=$version;$scope++) { |
|
| my $vkeys=$hash{"$scope:keys:$rid"}; |
|
| my @keys=split(/:/,$vkeys); |
|
| my $key; |
|
| $qresult.="$scope:keys=$vkeys&"; |
|
| foreach $key (@keys) { |
|
| $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; |
|
| } |
|
| } |
|
| if (untie(%hash)) { |
|
| $qresult=~s/\&$//; |
|
| print $client "$qresult\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting restore\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting restore\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------------------------------------- chatsend |
|
| } elsif ($userinput =~ /^chatsend/) { |
|
| if(isClient) { |
|
| my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); |
|
| &chatadd($cdom,$cnum,$newpost); |
|
| print $client "ok\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # -------------------------------------------------------------------- chatretr |
|
| } elsif ($userinput =~ /^chatretr/) { |
|
| if(isClient) { |
|
| my |
|
| ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); |
|
| my $reply=''; |
|
| foreach (&getchat($cdom,$cnum,$udom,$uname)) { |
|
| $reply.=&escape($_).':'; |
|
| } |
|
| $reply=~s/\:$//; |
|
| print $client $reply."\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------- querysend |
|
| } elsif ($userinput =~ /^querysend/) { |
|
| if (isClient) { |
|
| my ($cmd,$query, |
|
| $arg1,$arg2,$arg3)=split(/\:/,$userinput); |
|
| $query=~s/\n*$//g; |
|
| print $client "". |
|
| sqlreply("$clientname\&$query". |
|
| "\&$arg1"."\&$arg2"."\&$arg3")."\n"; |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ------------------------------------------------------------------ queryreply |
|
| } elsif ($userinput =~ /^queryreply/) { |
|
| if(isClient) { |
|
| my ($cmd,$id,$reply)=split(/:/,$userinput); |
|
| my $store; |
|
| my $execdir=$perlvar{'lonDaemons'}; |
|
| if ($store=IO::File->new(">$execdir/tmp/$id")) { |
|
| $reply=~s/\&/\n/g; |
|
| print $store $reply; |
|
| close $store; |
|
| my $store2=IO::File->new(">$execdir/tmp/$id.end"); |
|
| print $store2 "done\n"; |
|
| close $store2; |
|
| print $client "ok\n"; |
|
| } |
|
| else { |
|
| print $client "error: ".($!+0) |
|
| ." IO::File->new Failed ". |
|
| "while attempting queryreply\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ----------------------------------------------------------------- courseidput |
|
| } elsif ($userinput =~ /^courseidput/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$what)=split(/:/,$userinput); |
|
| chomp($what); |
|
| $udom=~s/\W//g; |
|
| my $proname= |
|
| "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; |
|
| my $now=time; |
|
| my @pairs=split(/\&/,$what); |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
|
| foreach my $pair (@pairs) { |
|
| my ($key,$descr,$inst_code)=split(/=/,$pair); |
|
| $hash{$key}=$descr.':'.$inst_code.':'.$now; |
|
| } |
|
| if (untie(%hash)) { |
|
| print $client "ok\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting courseidput\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting courseidput\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ---------------------------------------------------------------- courseiddump |
|
| } elsif ($userinput =~ /^courseiddump/) { |
|
| if(isClient) { |
|
| my ($cmd,$udom,$since,$description) |
|
| =split(/:/,$userinput); |
|
| if (defined($description)) { |
|
| $description=&unescape($description); |
|
| } else { |
|
| $description='.'; |
|
| } |
|
| unless (defined($since)) { $since=0; } |
|
| my $qresult=''; |
|
| my $proname= |
|
| "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; |
|
| my %hash; |
|
| if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
|
| while (my ($key,$value) = each(%hash)) { |
|
| my ($descr,$lasttime,$inst_code); |
|
| if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { |
|
| ($descr,$inst_code,$lasttime)=($1,$2,$3); |
|
| } else { |
|
| ($descr,$lasttime) = split(/\:/,$value); |
|
| } |
|
| if ($lasttime<$since) { next; } |
|
| if ($description eq '.') { |
|
| $qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
|
| } else { |
|
| my $unescapeVal = &unescape($descr); |
|
| if (eval('$unescapeVal=~/\Q$description\E/i')) { |
|
| $qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
|
| } |
|
| } |
|
| } |
|
| if (untie(%hash)) { |
|
| chop($qresult); |
|
| print $client "$qresult\n"; |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." untie(GDBM) Failed ". |
|
| "while attempting courseiddump\n"; |
|
| } |
|
| } else { |
|
| print $client "error: ".($!+0) |
|
| ." tie(GDBM) Failed ". |
|
| "while attempting courseiddump\n"; |
|
| } |
|
| } else { |
|
| Reply($client, "refused\n", $userinput); |
|
| |
|
| } |
|
| # ----------------------------------------------------------------------- idput |
|
| } elsif ($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); |
|
| |
|
| } |
|
| # ----------------------------------------- portfolio directory list (portls) |
|
| } elsif ($userinput =~ /^portls/) { |
|
| if(isClient) { |
|
| my ($cmd,$uname,$udom)=split(/:/,$userinput); |
|
| my $udir=propath($udom,$uname).'/userfiles/portfolio'; |
|
| my $dirLine=''; |
|
| my $dirContents=''; |
|
| if (opendir(LSDIR,$udir.'/')){ |
|
| while ($dirLine = readdir(LSDIR)){ |
|
| $dirContents = $dirContents.$dirLine.'<br />'; |
|
| } |
|
| } else { |
|
| $dirContents = "No directory found\n"; |
|
| } |
|
| print $client $dirContents."\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(); |
|
| last; |
|
| |
|
| # ---------------------------------- 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? |
|
| } elsif ($userinput =~/^autorun:/) { |
|
| if (isClient) { |
|
| my ($cmd,$cdom) = split(/:/,$userinput); |
|
| my $outcome = &localenroll::run($cdom); |
|
| print $client "$outcome\n"; |
|
| } else { |
|
| print $client "0\n"; |
|
| } |
|
| #------------------------------- get official sections (for auto-enrollment). |
|
| } elsif ($userinput =~/^autogetsections:/) { |
|
| if (isClient) { |
|
| my ($cmd,$coursecode,$cdom)=split(/:/,$userinput); |
|
| my @secs = &localenroll::get_sections($coursecode,$cdom); |
|
| my $seclist = &escape(join(':',@secs)); |
|
| print $client "$seclist\n"; |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| #----------------------- validate owner of new course section (for auto-enrollment). |
|
| } elsif ($userinput =~/^autonewcourse:/) { |
|
| if (isClient) { |
|
| my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput); |
|
| my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); |
|
| print $client "$outcome\n"; |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| #-------------- validate course section in schedule of classes (for auto-enrollment). |
|
| } elsif ($userinput =~/^autovalidatecourse:/) { |
|
| if (isClient) { |
|
| my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput); |
|
| my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom); |
|
| print $client "$outcome\n"; |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| #--------------------------- create password for new user (for auto-enrollment). |
|
| } elsif ($userinput =~/^autocreatepassword:/) { |
|
| if (isClient) { |
|
| my ($cmd,$authparam,$cdom)=split(/:/,$userinput); |
|
| my ($create_passwd,$authchk); |
|
| ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom); |
|
| print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n"; |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| #--------------------------- read and remove temporary files (for auto-enrollment). |
|
| } elsif ($userinput =~/^autoretrieve:/) { |
|
| if (isClient) { |
|
| my ($cmd,$filename) = split(/:/,$userinput); |
|
| my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; |
|
| if ( (-e $source) && ($filename ne '') ) { |
|
| my $reply = ''; |
|
| if (open(my $fh,$source)) { |
|
| while (<$fh>) { |
|
| chomp($_); |
|
| $_ =~ s/^\s+//g; |
|
| $_ =~ s/\s+$//g; |
|
| $reply .= $_; |
|
| } |
|
| close($fh); |
|
| print $client &escape($reply)."\n"; |
|
| # unlink($source); |
|
| } else { |
|
| print $client "error\n"; |
|
| } |
|
| } else { |
|
| print $client "error\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| #--------------------- read and retrieve institutional code format (for support form). |
|
| } elsif ($userinput =~/^autoinstcodeformat:/) { |
|
| if (isClient) { |
|
| my $reply; |
|
| my($cmd,$cdom,$course) = split(/:/,$userinput); |
|
| my @pairs = split/\&/,$course; |
|
| my %instcodes = (); |
|
| my %codes = (); |
|
| my @codetitles = (); |
|
| my %cat_titles = (); |
|
| my %cat_order = (); |
|
| foreach (@pairs) { |
|
| my ($key,$value) = split/=/,$_; |
|
| $instcodes{&unescape($key)} = &unescape($value); |
|
| } |
|
| my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order); |
|
| if ($formatreply eq 'ok') { |
|
| my $codes_str = &hash2str(%codes); |
|
| my $codetitles_str = &array2str(@codetitles); |
|
| my $cat_titles_str = &hash2str(%cat_titles); |
|
| my $cat_order_str = &hash2str(%cat_order); |
|
| print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n"; |
|
| } |
|
| } else { |
|
| print $client "refused\n"; |
|
| } |
|
| # ------------------------------------------------------------- unknown command |
|
| |
|
| } else { |
|
| # unknown command |
|
| print $client "unknown_cmd\n"; |
|
| } |
|
| # -------------------------------------------------------------------- complete |
|
| alarm(0); |
alarm(0); |
| &status('Listening to '.$clientname." ($keymode)"); |
&status('Listening to '.$clientname." ($keymode)"); |
| } |
} |
| |
|
| # --------------------------------------------- client unknown or fishy, refuse |
# --------------------------------------------- client unknown or fishy, refuse |
| } else { |
} else { |
| print $client "refused\n"; |
print $client "refused\n"; |
| $client->close(); |
$client->close(); |
| &logthis("<font color='blue'>WARNING: " |
&logthis("<font color='blue'>WARNING: " |
| ."Rejected client $clientip, closing connection</font>"); |
."Rejected client $clientip, closing connection</font>"); |
| } |
} |
| } |
} |
| |
|
| # ============================================================================= |
# ============================================================================= |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom