--- loncom/lond 2004/06/17 10:15:46 1.195 +++ loncom/lond 2004/08/02 21:02:20 1.205.2.1 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.195 2004/06/17 10:15:46 foxr Exp $ +# $Id: lond,v 1.205.2.1 2004/08/02 21:02:20 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -50,13 +50,14 @@ use File::Copy; use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; +use Fcntl qw(:flock); my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.195 $'; #' stupid emacs +my $VERSION='$Revision: 1.205.2.1 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; @@ -69,6 +70,8 @@ my $clientname; # LonCAPA name of clie my $server; my $thisserver; # DNS of us. +my $keymode; + # # Connection type is: # client - All client actions are allowed @@ -352,7 +355,6 @@ sub ReadManagerTable { while(my $host = ) { chomp($host); if ($host =~ "^#") { # Comment line. - logthis(' Skipping line: '. "$host\n"); next; } if (!defined $hostip{$host}) { # This is a non cluster member @@ -1144,10 +1146,11 @@ sub checkchildren { &logthis('Going to check on the children'); my $docdir=$perlvar{'lonDocRoot'}; foreach (sort keys %children) { - sleep 1; + #sleep 1; unless (kill 'USR1' => $_) { &logthis ('Child '.$_.' is dead'); &logstatus($$.' is dead'); + delete($children{$_}); } } sleep 5; @@ -1165,6 +1168,7 @@ sub checkchildren { #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; #$execdir=$perlvar{'lonDaemons'}; #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; + delete($children{$_}); alarm(0); } } @@ -1172,6 +1176,7 @@ sub checkchildren { $SIG{ALRM} = 'DEFAULT'; $SIG{__DIE__} = \&catchexception; &status("Finished checking children"); + &logthis('Finished Checking children'); } # --------------------------------------------------------------------- Logging @@ -1216,17 +1221,19 @@ sub logstatus { &status("Doing logging"); my $docdir=$perlvar{'lonDocRoot'}; { - my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); - print $fh $$."\t".$clientname."\t".$currenthostid."\t" - .$status."\t".$lastlog."\n"; - $fh->close(); - } - &status("Finished londstatus.txt"); - { my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); - print $fh $status."\n".$lastlog."\n".time; + print $fh $status."\n".$lastlog."\n".time."\n$keymode"; $fh->close(); } + &status("Finished $$.txt"); + { + open(LOG,">>$docdir/lon-status/londstatus.txt"); + flock(LOG,LOCK_EX); + print LOG $$."\t".$clientname."\t".$currenthostid."\t" + .$status."\t".$lastlog."\t $keymode\n"; + flock(DB,LOCK_UN); + close(LOG); + } &status("Finished logging"); } @@ -1527,6 +1534,25 @@ sub make_new_child { # If the remote is attempting a local init... give that a try: # my ($i, $inittype) = split(/:/, $remotereq); + + # If the connection type is ssl, but I didn't get my + # certificate files yet, then I'll drop back to + # insecure (if allowed). + + if($inittype eq "ssl") { + my ($ca, $cert) = lonssl::CertificateFile; + my $kfile = lonssl::KeyFile; + if((!$ca) || + (!$cert) || + (!$kfile)) { + $inittype = ""; # This forces insecure attempt. + &logthis(" Certificates not " + ."installed -- trying insecure auth"); + } + else { # SSL certificates are in place so + } # Leave the inittype alone. + } + if($inittype eq "local") { my $key = LocalConnection($client, $remotereq); if($key) { @@ -1537,6 +1563,7 @@ sub make_new_child { print $client "ok:local\n"; &logthis('"); + $keymode = "local" } else { Debug("Failed to get local key"); $clientok = 0; @@ -1550,7 +1577,8 @@ sub make_new_child { my $cipherkey = pack("H32", $key); $cipher = new IDEA($cipherkey); &logthis('' - ."Successfull ssl authentication "); + ."Successfull ssl authentication with $clientname "); + $keymode = "ssl"; } else { $clientok = 0; @@ -1562,8 +1590,9 @@ sub make_new_child { if($ok) { $clientok = 1; &logthis('' - ."Successful insecure authentication "); + ."Successful insecure authentication with $clientname "); print $client "ok\n"; + $keymode = "insecure"; } else { &logthis('' ."Attempted insecure connection disallowed "); @@ -2812,8 +2841,8 @@ sub make_new_child { my %hash; if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value.':'.$now; + my ($key,$descr,$inst_code)=split(/=/,$pair); + $hash{$key}=$descr.':'.$inst_code.':'.$now; } if (untie(%hash)) { print $client "ok\n"; @@ -2848,14 +2877,19 @@ sub make_new_child { my %hash; if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { while (my ($key,$value) = each(%hash)) { - my ($descr,$lasttime)=split(/\:/,$value); + 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.'&'; + $qresult.=$key.'='.$descr.':'.$inst_code.'&'; } else { my $unescapeVal = &unescape($descr); if (eval('$unescapeVal=~/\Q$description\E/i')) { - $qresult.="$key=$descr&"; + $qresult.=$key.'='.$descr.':'.$inst_code.'&'; } } } @@ -3009,6 +3043,24 @@ sub make_new_child { 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.'
'; + } + } else { + $dirContents = "No directory found\n"; + } + print $client $dirContents."\n"; + } else { + Reply($client, "refused\n", $userinput); + } # -------------------------------------------------------------------------- ls } elsif ($userinput =~ /^ls/) { if(isClient) { @@ -3096,53 +3148,54 @@ sub make_new_child { print $client "refused\n"; } #------------------------------- is auto-enrollment enabled? - } elsif ($userinput =~/^autorun/) { + } elsif ($userinput =~/^autorun:/) { if (isClient) { - my $outcome = &localenroll::run(); + 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/) { + } elsif ($userinput =~/^autogetsections:/) { if (isClient) { - my ($cmd,$coursecode)=split(/:/,$userinput); - my @secs = &localenroll::get_sections($coursecode); + 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/) { + } elsif ($userinput =~/^autonewcourse:/) { if (isClient) { - my ($cmd,$course_id,$owner)=split(/:/,$userinput); - my $outcome = &localenroll::new_course($course_id,$owner); + 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/) { + } elsif ($userinput =~/^autovalidatecourse:/) { if (isClient) { - my ($cmd,$course_id)=split(/:/,$userinput); - my $outcome=&localenroll::validate_courseID($course_id); + 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/) { + } elsif ($userinput =~/^autocreatepassword:/) { if (isClient) { - my ($cmd,$authparam)=split(/:/,$userinput); - my ($create_passwd,$authchk) = @_; - ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam); + 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/) { + } elsif ($userinput =~/^autoretrieve:/) { if (isClient) { my ($cmd,$filename) = split(/:/,$userinput); my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; @@ -3167,6 +3220,32 @@ sub make_new_child { } 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 { @@ -3175,7 +3254,7 @@ sub make_new_child { } # -------------------------------------------------------------------- complete alarm(0); - &status('Listening to '.$clientname); + &status('Listening to '.$clientname." ($keymode)"); } # --------------------------------------------- client unknown or fishy, refuse } else { @@ -3574,6 +3653,73 @@ sub userload { return $userloadpercent; } +# Routines for serializing arrays and hashes (copies from lonnet) + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + +sub arrayref2str { + my ($arrayref) = @_; + my $result='__ARRAY_REF__'; + foreach my $elem (@$arrayref) { + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); + } else { + $result.=&escape($elem).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; + return $result; +} + +sub hash2str { + my (%hash) = @_; + my $result=&hashref2str(\%hash); + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; + return $result; +} + +sub hashref2str { + my ($hashref)=@_; + my $result='__HASH_REF__'; + foreach (sort(keys(%$hashref))) { + if (ref($_) eq 'ARRAY') { + $result.=&arrayref2str($_).'='; + } elsif (ref($_) eq 'HASH') { + $result.=&hashref2str($_).'='; + } elsif (ref($_)) { + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); + } else { + if ($_) {$result.=&escape($_).'=';} else { last; } + } + + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); + } else { + $result.=&escape($hashref->{$_}).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_HASH_REF__'; + return $result; +} # ----------------------------------- POD (plain old documentation, CPAN style)