--- loncom/lond 2003/03/18 22:51:03 1.115 +++ loncom/lond 2003/03/28 18:26:28 1.122 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.115 2003/03/18 22:51:03 albertel Exp $ +# $Id: lond,v 1.122 2003/03/28 18:26:28 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -73,6 +73,8 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; +my $VERSION='$Revision: 1.122 $'; #' stupid emacs +my $remoteVERSION; my $currenthostid; my $currentdomainid; # @@ -199,7 +201,7 @@ while ($configline=) { $hostid{$ip}=$id; $hostdom{$id}=$domain; $hostip{$id}=$ip; - if ($id eq $perlvar{'lonHostId'}) { $thisserver=$name; } + if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } $PREFORK++; } close(CONFIG); @@ -515,22 +517,6 @@ while (1) { make_new_child($client); } -sub init_host_and_domain { - my ($remotereq) = @_; - my (undef,$hostid)=split(/:/,$remotereq); - if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } - if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { - $currenthostid=$hostid; - $currentdomainid=$hostdom{$hostid}; - &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); - } else { - &logthis("Requested host id $hostid not an alias of ". - $perlvar{'lonHostID'}." refusing connection"); - return 0; - } - return 1; -} - sub make_new_child { my $client; my $pid; @@ -592,14 +578,7 @@ sub make_new_child { my $remotereq=<$client>; $remotereq=~s/[^\w:]//g; if ($remotereq =~ /^init/) { - if (!&init_host_and_domain($remotereq)) { - &status("Got bad init message, exiting"); - print $client "refused\n"; - $client->close(); - &logthis("WARNING: " - ."Bad init message $remotereq, closing connection"); - exit; - } + &sethost("sethost:$perlvar{'lonHostID'}"); my $challenge="$$".time; print $client "$challenge\n"; &status( @@ -1091,7 +1070,7 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); $hash{$key}=$value; @@ -1133,7 +1112,7 @@ sub make_new_child { } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); &ManagePermissions($key, $udom, $uname, @@ -1157,6 +1136,48 @@ sub make_new_child { } else { print $client "refused\n"; } +# -------------------------------------------------------------------- rolesdel + } elsif ($userinput =~ /^rolesdel/) { + &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 $hfh; + if ( + $hfh=IO::File->new(">>$proname/$namespace.hist") + ) { + print $hfh "D:$now:$exedom:$exeuser:$what\n"; + } + } + my @rolekeys=split(/\&/,$what); + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach $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"; + } # ------------------------------------------------------------------------- get } elsif ($userinput =~ /^get/) { my ($cmd,$udom,$uname,$namespace,$what) @@ -1167,7 +1188,7 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -1199,7 +1220,7 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -1245,7 +1266,7 @@ sub make_new_child { ) { print $hfh "D:$now:$what\n"; } } my @keys=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { foreach $key (@keys) { delete($hash{$key}); } @@ -1269,7 +1290,7 @@ sub make_new_child { $namespace=~s/\W//g; my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { foreach $key (keys %hash) { $qresult.="$key&"; } @@ -1387,7 +1408,7 @@ sub make_new_child { } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { my @previouskeys=split(/&/,$hash{"keys:$rid"}); my $key; $hash{"version:$rid"}++; @@ -1425,7 +1446,7 @@ sub make_new_child { chomp($rid); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { my $version=$hash{"version:$rid"}; $qresult.="version=$version&"; my $scope; @@ -1458,9 +1479,10 @@ sub make_new_child { print $client "ok\n"; # -------------------------------------------------------------------- chatretr } elsif ($userinput =~ /^chatretr/) { - my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); + my + ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); my $reply=''; - foreach (&getchat($cdom,$cnum)) { + foreach (&getchat($cdom,$cnum,$udom,$uname)) { $reply.=&escape($_).':'; } $reply=~s/\:$//; @@ -1492,6 +1514,71 @@ sub make_new_child { ." IO::File->new Failed ". "while attempting queryreply\n"; } +# ----------------------------------------------------------------- courseidput + } elsif ($userinput =~ /^courseidput/) { + 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); + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + foreach $pair (@pairs) { + ($key,$value)=split(/=/,$pair); + $hash{$key}=$value.':'.$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"; + } +# ---------------------------------------------------------------- courseiddump + } elsif ($userinput =~ /^courseiddump/) { + 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"; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + while (($key,$value) = each(%hash)) { + my ($descr,$lasttime)=split(/\:/,$value); + if ($lasttime<$since) { next; } + if ($regexp eq '.') { + $qresult.=$key.'='.$descr.'&'; + } else { + my $unescapeVal = &unescape($descr); + if (eval('$unescapeVal=~/$description/i')) { + $qresult.="$key=$descr&"; + } + } + } + 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"; + } # ----------------------------------------------------------------------- idput } elsif ($userinput =~ /^idput/) { my ($cmd,$udom,$what)=split(/:/,$userinput); @@ -1506,7 +1593,7 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); $hash{$key}=$value; @@ -1531,7 +1618,7 @@ sub make_new_child { my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; my @queries=split(/\&/,$what); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -1632,6 +1719,10 @@ sub make_new_child { $client->close(); last; # ------------------------------------------------------------- unknown command + } elsif ($userinput =~ /^sethost:/) { + print $client &sethost($userinput)."\n"; + } elsif ($userinput =~/^version:/) { + print $client &version($userinput)."\n"; } else { # unknown command print $client "unknown_cmd\n"; @@ -1743,7 +1834,7 @@ sub addline { } sub getchat { - my ($cdom,$cname)=@_; + my ($cdom,$cname,$udom,$uname)=@_; my %hash; my $proname=&propath($cdom,$cname); my @entries=(); @@ -1947,6 +2038,28 @@ sub make_passwd_file { return $result; } +sub sethost { + my ($remotereq) = @_; + my (undef,$hostid)=split(/:/,$remotereq); + if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } + if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { + $currenthostid=$hostid; + $currentdomainid=$hostdom{$hostid}; + &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); + } else { + &logthis("Requested host id $hostid not an alias of ". + $perlvar{'lonHostID'}." refusing connection"); + return 'unable_to_set'; + } + return 'ok'; +} + +sub version { + my ($userinput)=@_; + $remoteVERSION=(split(/:/,$userinput))[1]; + return "version:$VERSION"; +} + # ----------------------------------- POD (plain old documentation, CPAN style) =head1 NAME