--- loncom/lond 2006/11/27 22:51:14 1.351 +++ loncom/lond 2007/03/28 22:14:33 1.365 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.351 2006/11/27 22:51:14 banghart Exp $ +# $Id: lond,v 1.365 2007/03/28 22:14:33 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -33,6 +33,7 @@ use strict; use lib '/home/httpd/lib/perl/'; use LONCAPA; use LONCAPA::Configuration; +use Apache::lonnet; use IO::Socket; use IO::File; @@ -44,13 +45,11 @@ use Digest::MD5 qw(md5_hex); use GDBM_File; use Authen::Krb4; use Authen::Krb5; -use lib '/home/httpd/lib/perl/'; use localauth; use localenroll; use localstudentphoto; use File::Copy; use File::Find; -use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); @@ -60,7 +59,7 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.351 $'; #' stupid emacs +my $VERSION='$Revision: 1.365 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -504,30 +503,30 @@ sub AdjustHostContents { my $adjusted; my $me = $perlvar{'lonHostID'}; - foreach my $line (split(/\n/,$contents)) { + foreach my $line (split(/\n/,$contents)) { if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { chomp($line); my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); if ($id eq $me) { - my $ip = gethostbyname($name); - my $ipnew = inet_ntoa($ip); - $ip = $ipnew; + my $ip = gethostbyname($name); + my $ipnew = inet_ntoa($ip); + $ip = $ipnew; # Reconstruct the host line and append to adjusted: - my $newline = "$id:$domain:$role:$name:$ip"; - if($maxcon ne "") { # Not all hosts have loncnew tuning params - $newline .= ":$maxcon:$idleto:$mincon"; - } - $adjusted .= $newline."\n"; + my $newline = "$id:$domain:$role:$name:$ip"; + if($maxcon ne "") { # Not all hosts have loncnew tuning params + $newline .= ":$maxcon:$idleto:$mincon"; + } + $adjusted .= $newline."\n"; - } else { # Not me, pass unmodified. - $adjusted .= $line."\n"; - } + } else { # Not me, pass unmodified. + $adjusted .= $line."\n"; + } } else { # Blank or comment never re-written. $adjusted .= $line."\n"; # Pass blanks and comments as is. } - } - return $adjusted; + } + return $adjusted; } # # InstallFile: Called to install an administrative file: @@ -1033,7 +1032,7 @@ sub ping_handler { sub pong_handler { my ($cmd, $tail, $replyfd) = @_; - my $reply=&reply("ping",$clientname); + my $reply=&Apache::lonnet::reply("ping",$clientname); &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); return 1; } @@ -1143,7 +1142,7 @@ sub load_handler { sub user_load_handler { my ($cmd, $tail, $replyfd) = @_; - my $userloadpercent=&userload(); + my $userloadpercent=&Apache::lonnet::userload(); &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail"); return 1; @@ -1269,6 +1268,7 @@ sub du_handler { my $code=sub { if ($_=~/\.\d+\./) { return;} if ($_=~/\.meta$/) { return;} + if (-d $_) { return;} $total_size+=(stat($_))[7]; }; chdir($ududir); @@ -1850,13 +1850,13 @@ sub update_resource_handler { my $now=time; my $since=$now-$atime; if ($since>$perlvar{'lonExpire'}) { - my $reply=&reply("unsub:$fname","$clientname"); + my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname"); &devalidate_meta_cache($fname); unlink("$fname"); unlink("$fname.meta"); } else { my $transname="$fname.in.transfer"; - my $remoteurl=&reply("sub:$fname","$clientname"); + my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname"); my $response; alarm(120); { @@ -1901,22 +1901,12 @@ sub devalidate_meta_cache { my ($url) = @_; use Cache::Memcached; my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); - $url = &declutter($url); + $url = &Apache::lonnet::declutter($url); $url =~ s-\.meta$--; my $id = &escape('meta:'.$url); $memcache->delete($id); } -sub declutter { - my $thisfn=shift; - $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; - $thisfn=~s/^\///; - $thisfn=~s|^adm/wrapper/||; - $thisfn=~s|^adm/coursedocs/showdoc/||; - $thisfn=~s/^res\///; - $thisfn=~s/\?.+$//; - return $thisfn; -} # # Fetch a user file from a remote server to the user's home directory # userfiles subdir. @@ -3054,8 +3044,8 @@ sub restore_handler { my $userinput = "$cmd:$tail"; # Only used for logging purposes. my ($udom,$uname,$namespace,$rid) = split(/:/,$tail); - $namespace = &LONCAPA::clean_username($namespace); $namespace=~s/\//\_/g; + $namespace = &LONCAPA::clean_username($namespace); chomp($rid); my $qresult=''; @@ -3293,13 +3283,14 @@ sub put_course_id_handler { foreach my $pair (@pairs) { my ($key,$courseinfo) = split(/=/,$pair,2); $courseinfo =~ s/=/:/g; - - my @current_items = split(/:/,$hashref->{$key}); + my @current_items = split(/:/,$hashref->{$key},-1); shift(@current_items); # remove description pop(@current_items); # remove last access my $numcurrent = scalar(@current_items); - - my @new_items = split(/:/,$courseinfo); + if ($numcurrent > 3) { + $numcurrent = 3; + } + my @new_items = split(/:/,$courseinfo,-1); my $numnew = scalar(@new_items); if ($numcurrent > 0) { if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 @@ -3599,7 +3590,7 @@ sub get_domain_handler { return 1; } -®ister_handler("getdom", \&get_id_handler, 0, 1, 0); +®ister_handler("getdom", \&get_domain_handler, 0, 1, 0); # @@ -4451,10 +4442,10 @@ sub get_institutional_code_format_handle \%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); + my $codes_str = &Apache::lonnet::hash2str(%codes); + my $codetitles_str = &Apache::lonnet::array2str(@codetitles); + my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles); + my $cat_order_str = &Apache::lonnet::hash2str(%cat_order); &Reply($client, $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':' .$cat_order_str."\n", @@ -4630,6 +4621,31 @@ sub student_photo_handler { } ®ister_handler("studentphoto", \&student_photo_handler, 0, 1, 0); +sub inst_usertypes_handler { + my ($cmd, $domain, $client) = @_; + my $res; + my $userinput = $cmd.":".$domain; # For logging purposes. + my (%typeshash,@order); + if (&localenroll::inst_usertypes($domain,\%typeshash,\@order) eq 'ok') { + if (keys(%typeshash) > 0) { + foreach my $key (keys(%typeshash)) { + $res.=&escape($key).'='.&escape($typeshash{$key}).'&'; + } + } + $res=~s/\&$//; + $res .= ':'; + if (@order > 0) { + foreach my $item (@order) { + $res .= &escape($item).'&'; + } + } + $res=~s/\&$//; + } + &Reply($client, "$res\n", $userinput); + return 1; +} +®ister_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0); + # mkpath makes all directories for a file, expects an absolute path with a # file or a trailing / if just a dir is passed # returns 1 on success 0 on failure @@ -5261,63 +5277,6 @@ sub status { $0='lond: '.$what.' '.$local; } -# ----------------------------------------------------------- Send USR1 to lonc - -sub reconlonc { - my $peerfile=shift; - &logthis("Trying to reconnect for $peerfile"); - my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; - if (my $fh=IO::File->new("$loncfile")) { - my $loncpid=<$fh>; - chomp($loncpid); - if (kill 0 => $loncpid) { - &logthis("lonc at pid $loncpid responding, sending USR1"); - kill USR1 => $loncpid; - } else { - &logthis( - "CRITICAL: " - ."lonc at pid $loncpid not responding, giving up"); - } - } else { - &logthis('CRITICAL: lonc not running, giving up'); - } -} - -# -------------------------------------------------- Non-critical communication - -sub subreply { - my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; - my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - print $sclient "sethost:$server:$cmd\n"; - my $answer=<$sclient>; - chomp($answer); - if (!$answer) { $answer="con_lost"; } - return $answer; -} - -sub reply { - my ($cmd,$server)=@_; - my $answer; - if ($server ne $currenthostid) { - $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - $answer=subreply("ping",$server); - if ($answer ne $server) { - &logthis("sub reply: answer != server answer is $answer, server is $server"); - &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server}); - } - $answer=subreply($cmd,$server); - } - } else { - $answer='self_reply'; - } - return $answer; -} - # -------------------------------------------------------------- Talk to lonsql sub sql_reply { @@ -5466,8 +5425,8 @@ sub make_new_child { # my $tmpsnum=0; # Now global #---------------------------------------------------- kerberos 5 initialization &Authen::Krb5::init_context(); - unless (($dist eq 'fedora5') || ($dist eq 'fedora4') - || ($dist eq 'suse9.3')) { + unless (($dist eq 'fedora5') || ($dist eq 'fedora4') || + ($dist eq 'fedora6') || ($dist eq 'suse9.3')) { &Authen::Krb5::init_ets(); } @@ -5880,7 +5839,8 @@ sub validate_user { my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; my $krbserver = &Authen::Krb5::parse_name($krbservice); my $credentials= &Authen::Krb5::cc_default(); - $credentials->initialize($krbclient); + $credentials->initialize(&Authen::Krb5::parse_name($user.'@' + .$contentpwd)); my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, $krbserver, $password, @@ -5893,7 +5853,12 @@ sub validate_user { # Authenticate via installation specific authentcation method: $validated = &localauth::localauth($user, $password, - $contentpwd); + $contentpwd, + $domain); + if ($validated < 0) { + &logthis("localauth for $contentpwd $user:$domain returned a $validated"); + $validated = 0; + } } else { # Unrecognized auth is also bad. $validated = 0; } @@ -5919,8 +5884,7 @@ sub addline { my ($fname,$hostid,$ip,$newline)=@_; my $contents; my $found=0; - my $expr='^'.$hostid.':'.$ip.':'; - $expr =~ s/\./\\\./g; + my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':'; my $sh; if ($sh=IO::File->new("$fname.subscription")) { while (my $subline=<$sh>) { @@ -6299,96 +6263,6 @@ sub version { return "version:$VERSION"; } -#There is a copy of this in lonnet.pm -sub userload { - my $numusers=0; - { - opendir(LONIDS,$perlvar{'lonIDsDir'}); - my $filename; - my $curtime=time; - while ($filename=readdir(LONIDS)) { - if ($filename eq '.' || $filename eq '..') {next;} - my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; - if ($curtime-$mtime < 1800) { $numusers++; } - } - closedir(LONIDS); - } - my $userloadpercent=0; - my $maxuserload=$perlvar{'lonUserLoadLim'}; - if ($maxuserload) { - $userloadpercent=100*$numusers/$maxuserload; - } - $userloadpercent=sprintf("%.2f",$userloadpercent); - 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) 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.