--- loncom/lond 2010/05/22 14:36:13 1.441 +++ loncom/lond 2014/06/09 16:58:22 1.467.2.8 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.441 2010/05/22 14:36:13 raeburn Exp $ +# $Id: lond,v 1.467.2.8 2014/06/09 16:58:22 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -52,13 +52,14 @@ use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); use Apache::lonnet; +use Mail::Send; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.441 $'; #' stupid emacs +my $VERSION='$Revision: 1.467.2.8 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -66,7 +67,9 @@ my $currentdomainid; my $client; my $clientip; # IP address of client. my $clientname; # LonCAPA name of client. -my $clientversion; # LonCAPA version running on client +my $clientversion; # LonCAPA version running on client. +my $clienthomedom; # LonCAPA domain of homeID for client. + # primary library server. my $server; @@ -417,8 +420,11 @@ sub ReadManagerTable { my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; if (!open (MANAGERS, $tablename)) { - logthis('No manager table. Nobody can manage!!'); - return; + my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'}); + if (&Apache::lonnet::is_LC_dns($hostname)) { + &logthis('No manager table. Nobody can manage!!'); + } + return; } while(my $host = ) { chomp($host); @@ -443,7 +449,7 @@ sub ReadManagerTable { } } else { logthis(' existing host'." $host\n"); - $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber + $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber } } } @@ -505,7 +511,8 @@ sub AdjustHostContents { my $me = $perlvar{'lonHostID'}; foreach my $line (split(/\n/,$contents)) { - if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { + if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) || + ($line =~ /^\s*\^/))) { chomp($line); my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); if ($id eq $me) { @@ -593,11 +600,8 @@ sub InstallFile { # # ConfigFileFromSelector: converts a configuration file selector # into a configuration file pathname. -# It's probably no longer necessary to preserve -# special handling of hosts or domain as those -# files have been superceded by dns_hosts, dns_domain. -# The default action is just to prepend the directory -# and append .tab +# Supports the following file selectors: +# hosts, domain, dns_hosts, dns_domain # # # Parameters: @@ -610,12 +614,9 @@ sub ConfigFileFromSelector { my $tablefile; my $tabledir = $perlvar{'lonTabDir'}.'/'; - if ($selector eq "hosts") { - $tablefile = $tabledir."hosts.tab"; - } elsif ($selector eq "domain") { - $tablefile = $tabledir."domain.tab"; - } else { - $tablefile = $tabledir.$selector.'.tab'; + if (($selector eq "hosts") || ($selector eq "domain") || + ($selector eq "dns_hosts") || ($selector eq "dns_domain")) { + $tablefile = $tabledir.$selector.'.tab'; } return $tablefile; @@ -636,7 +637,7 @@ sub ConfigFileFromSelector { # String to send to client ("ok" or "refused" if bad file). # sub PushFile { - my $request = shift; + my $request = shift; my ($command, $filename, $contents) = split(":", $request, 3); &Debug("PushFile"); @@ -644,6 +645,8 @@ sub PushFile { # supported: # hosts.tab ($filename eq host). # domain.tab ($filename eq domain). + # dns_hosts.tab ($filename eq dns_host). + # dns_domain.tab ($filename eq dns_domain). # Construct the destination filename or reject the request. # # lonManage is supposed to ensure this, however this session could be @@ -664,6 +667,44 @@ sub PushFile { if($filename eq "host") { $contents = AdjustHostContents($contents); + } elsif ($filename eq 'dns_host' || $filename eq 'dns_domain') { + if ($contents eq '') { + &logthis(' Pushfile: unable to install ' + .$tablefile." - no data received from push. "); + return 'error: push had no data'; + } + if (&Apache::lonnet::get_host_ip($clientname)) { + my $clienthost = &Apache::lonnet::hostname($clientname); + if ($managers{$clientip} eq $clientname) { + my $clientprotocol = $Apache::lonnet::protocol{$clientname}; + $clientprotocol = 'http' if ($clientprotocol ne 'https'); + my $url = '/adm/'.$filename; + $url =~ s{_}{/}; + my $ua=new LWP::UserAgent; + $ua->timeout(60); + my $request=new HTTP::Request('GET',"$clientprotocol://$clienthost$url"); + my $response=$ua->request($request); + if ($response->is_error()) { + &logthis(' Pushfile: unable to install ' + .$tablefile." - error attempting to pull data. "); + return 'error: pull failed'; + } else { + my $result = $response->content; + chomp($result); + unless ($result eq $contents) { + &logthis(' Pushfile: unable to install ' + .$tablefile." - pushed data and pulled data differ. "); + my $pushleng = length($contents); + my $pullleng = length($result); + if ($pushleng != $pullleng) { + return "error: $pushleng vs $pullleng bytes"; + } else { + return "error: mismatch push and pull"; + } + } + } + } + } } # Install the new file: @@ -674,12 +715,32 @@ sub PushFile { .$tablefile." $! "); return "error:$!"; } else { - &logthis(' Installed new '.$tablefile - .""); - + &logthis(' Installed new '.$tablefile + ." - transaction by: $clientname ($clientip)"); + my $adminmail = $perlvar{'lonAdmEMail'}; + my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); + if ($admindom ne '') { + my %domconfig = + &Apache::lonnet::get_dom('configuration',['contacts'],$admindom); + if (ref($domconfig{'contacts'}) eq 'HASH') { + if ($domconfig{'contacts'}{'adminemail'} ne '') { + $adminmail = $domconfig{'contacts'}{'adminemail'}; + } + } + } + if ($adminmail =~ /^[^\@]+\@[^\@]+$/) { + my $msg = new Mail::Send; + $msg->to($adminmail); + $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'}); + $msg->add('Content-type','text/plain; charset=UTF-8'); + if (my $fh = $msg->open()) { + print $fh 'Update to '.$tablefile.' from Cluster Manager '. + "$clientname ($clientip)\n"; + $fh->close; + } + } } - # Indicate success: return "ok"; @@ -1071,7 +1132,7 @@ sub pong_handler { # Implicit Inputs: # $currenthostid - Global variable that carries the name of the host # known as. -# $clientname - Global variable that carries the name of the hsot we're connected to. +# $clientname - Global variable that carries the name of the host we're connected to. # Returns: # 1 - Ok to continue processing. # 0 - Program should exit. @@ -1110,7 +1171,7 @@ sub establish_key_handler { # Implicit Inputs: # $currenthostid - Global variable that carries the name of the host # known as. -# $clientname - Global variable that carries the name of the hsot we're connected to. +# $clientname - Global variable that carries the name of the host we're connected to. # Returns: # 1 - Ok to continue processing. # 0 - Program should exit. @@ -1119,6 +1180,8 @@ sub establish_key_handler { sub load_handler { my ($cmd, $tail, $replyfd) = @_; + + # Get the load average from /proc/loadavg and calculate it as a percentage of # the allowed load limit as set by the perl global variable lonLoadLim @@ -1147,7 +1210,7 @@ sub load_handler { # Implicit Inputs: # $currenthostid - Global variable that carries the name of the host # known as. -# $clientname - Global variable that carries the name of the hsot we're connected to. +# $clientname - Global variable that carries the name of the host we're connected to. # Returns: # 1 - Ok to continue processing. # 0 - Program should exit @@ -1656,6 +1719,23 @@ sub server_loncaparev_handler { } ®ister_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0); +sub server_homeID_handler { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + &Reply($client,\$perlvar{'lonHostID'},$userinput); + return 1; +} +®ister_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0); + +sub server_distarch_handler { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + my $reply = &distro_and_arch(); + &Reply($client,\$reply,$userinput); + return 1; +} +®ister_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0); + # Process a reinit request. Reinit requests that either # lonc or lond be reinitialized so that an updated # host.tab or domain.tab can be processed. @@ -1765,15 +1845,49 @@ sub authenticate_handler { # upass - User's password. # checkdefauth - Pass to validate_user() to try authentication # with default auth type(s) if no user account. + # clientcancheckhost - Passed by clients with functionality in lonauth.pm + # to check if session can be hosted. - my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail); + my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail); &Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth"); chomp($upass); $upass=&unescape($upass); my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth); if($pwdcorrect) { - &Reply( $client, "authorized\n", $userinput); + my $canhost = 1; + unless ($clientcancheckhost) { + my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); + my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); + my @intdoms; + my $internet_names = &Apache::lonnet::get_internet_names($clientname); + if (ref($internet_names) eq 'ARRAY') { + @intdoms = @{$internet_names}; + } + unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) { + my ($remote,$hosted); + my $remotesession = &get_usersession_config($udom,'remotesession'); + if (ref($remotesession) eq 'HASH') { + $remote = $remotesession->{'remote'} + } + my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession'); + if (ref($hostedsession) eq 'HASH') { + $hosted = $hostedsession->{'hosted'}; + } + my $loncaparev = $clientversion; + if ($loncaparev eq '') { + $loncaparev = $Apache::lonnet::loncaparevs{$clientname}; + } + $canhost = &Apache::lonnet::can_host_session($udom,$clientname, + $loncaparev, + $remote,$hosted); + } + } + if ($canhost) { + &Reply( $client, "authorized\n", $userinput); + } else { + &Reply( $client, "not_allowed_to_host\n", $userinput); + } # # Bad credentials: Failed to authorize # @@ -2111,7 +2225,10 @@ sub update_resource_handler { my $transname="$fname.in.transfer"; my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname"); my $response; - alarm(120); +# FIXME: cannot replicate files that take more than two minutes to transfer? +# alarm(120); +# FIXME: this should use the LWP mechanism, not internal alarms. + alarm(1200); { my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',"$remoteurl"); @@ -2119,11 +2236,13 @@ sub update_resource_handler { } alarm(0); if ($response->is_error()) { +# FIXME: we should probably clean up here instead of just whine unlink($transname); my $message=$response->status_line; &logthis("LWP GET: $message for $fname ($remoteurl)"); } else { if ($remoteurl!~/\.meta$/) { +# FIXME: isn't there an internal LWP mechanism for this? alarm(120); { my $ua=new LWP::UserAgent; @@ -2197,7 +2316,10 @@ sub fetch_user_file_handler { my $destname=$udir.'/'.$ufile; my $transname=$udir.'/'.$ufile.'.in.transit'; - my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; + my $clientprotocol=$Apache::lonnet::protocol{$clientname}; + $clientprotocol = 'http' if ($clientprotocol ne 'https'); + my $clienthost = &Apache::lonnet::hostname($clientname); + my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname; my $response; Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname"); alarm(120); @@ -2373,7 +2495,6 @@ sub user_has_session_handler { my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail)); - &logthis("Looking for $udom $uname"); opendir(DIR,$perlvar{'lonIDsDir'}); my $filename; while ($filename=readdir(DIR)) { @@ -3104,7 +3225,7 @@ sub dump_with_regexp { my $userinput = "$cmd:$tail"; - my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail); + my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail); if (defined($regexp)) { $regexp=&unescape($regexp); } else { @@ -3122,16 +3243,38 @@ sub dump_with_regexp { } my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); + my $skipcheck; if ($hashref) { my $qresult=''; my $count=0; + if ($extra ne '') { + $extra = &Apache::lonnet::thaw_unescape($extra); + $skipcheck = $extra->{'skipcheck'}; + } + my @ids = &Apache::lonnet::current_machine_ids(); + my (%homecourses,$major,$minor,$now); + if (($namespace eq 'roles') && (!$skipcheck)) { + my $loncaparev = $clientversion; + if ($loncaparev eq '') { + $loncaparev = $Apache::lonnet::loncaparevs{$clientname}; + } + if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) { + $major = $1; + $minor = $2; + } + $now = time; + } while (my ($key,$value) = each(%$hashref)) { if ($namespace eq 'roles') { - if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_(cc|co|in|ta|ep|ad|st|cr)/) { - if ($clientversion =~ /^(\d+)\.(\d+)$/) { - my $major = $1; - my $minor = $2; - next if (($major < 2) || (($major == 2) && ($minor < 9))); + if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) { + my $cdom = $1; + my $cnum = $2; + unless ($skipcheck) { + my ($role,$end,$start) = split(/\_/,$value); + if (!$end || $end > $now) { + next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major, + $minor,\%homecourses,\@ids)); + } } } } @@ -3151,6 +3294,12 @@ sub dump_with_regexp { } } if (&untie_user_hash($hashref)) { + if (($namespace eq 'roles') && (!$skipcheck)) { + if (keys(%homecourses) > 0) { + $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count, + $range,$start,$end,$major,$minor); + } + } chop($qresult); &Reply($client, \$qresult, $userinput); } else { @@ -3728,6 +3877,9 @@ sub put_course_id_hash_handler { # createdafter - include courses for which creation date followed this date. # creationcontext - include courses created in specified context # +# domcloner - flag to indicate if user can create CCs in course's domain. +# If so, ability to clone course is automatic. +# # $client - The socket open on the client. # Returns: # 1 - Continue processing. @@ -3740,7 +3892,7 @@ sub dump_course_id_handler { my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter, - $creationcontext) =split(/:/,$tail); + $creationcontext,$domcloner) =split(/:/,$tail); my $now = time; my ($cloneruname,$clonerudom,%cc_clone); if (defined($description)) { @@ -3813,9 +3965,8 @@ sub dump_course_id_handler { } else { $creationcontext = '.'; } - my $unpack = 1; - if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && + if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && $typefilter eq '.') { $unpack = 0; } @@ -3844,7 +3995,9 @@ sub dump_course_id_handler { next if ($since > 1); } $is_hash = 1; - if (defined($clonerudom)) { + if ($domcloner) { + $canclone = 1; + } elsif (defined($clonerudom)) { if ($items->{'cloners'}) { my @cloneable = split(',',$items->{'cloners'}); if (@cloneable) { @@ -3877,7 +4030,7 @@ sub dump_course_id_handler { if ($items->{'owner'} eq $cloner) { $canclone = 1; } - } elsif ($cloner eq $udom.':'.$items->{'owner'}) { + } elsif ($cloner eq $items->{'owner'}.':'.$udom) { $canclone = 1; } if ($canclone) { @@ -4197,6 +4350,7 @@ sub put_domain_handler { sub get_domain_handler { my ($cmd, $tail, $client) = @_; + my $userinput = "$client:$tail"; my ($udom,$namespace,$what)=split(/:/,$tail,3); @@ -4341,7 +4495,8 @@ sub get_id_handler { sub put_dcmail_handler { my ($cmd,$tail,$client) = @_; my $userinput = "$cmd:$tail"; - + + my ($udom,$what)=split(/:/,$tail); chomp($what); my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); @@ -4605,7 +4760,7 @@ sub tmp_put_handler { } my ($id,$store); $tmpsnum++; - if ($context eq 'resetpw') { + if (($context eq 'resetpw') || ($context eq 'createaccount')) { $id = &md5_hex(&md5_hex(time.{}.rand().$$)); } else { $id = $$.'_'.$clientip.'_'.$tmpsnum; @@ -4923,10 +5078,11 @@ sub get_sections_handler { sub validate_course_owner_handler { my ($cmd, $tail, $client) = @_; my $userinput = "$cmd:$tail"; - my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); + my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail); $owner = &unescape($owner); - my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); + $coowners = &unescape($coowners); + my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners); &Reply($client, \$outcome, $userinput); @@ -5914,7 +6070,7 @@ if (-e $pidfile) { $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, Type => SOCK_STREAM, Proto => 'tcp', - Reuse => 1, + ReuseAddr => 1, Listen => 10 ) or die "making socket: $@\n"; @@ -5977,9 +6133,12 @@ sub HUPSMAN { # sig # a setuid perl script that can be root for us to do this job. # sub ReloadApache { - my $execdir = $perlvar{'lonDaemons'}; - my $script = $execdir."/apachereload"; - system($script); + if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) { + my $execdir = $perlvar{'lonDaemons'}; + my $script = $execdir."/apachereload"; + system($script); + unlink('/tmp/lock_apachereload'); # Remove the lock file. + } } # @@ -6152,7 +6311,7 @@ sub logstatus { sub initnewstatus { my $docdir=$perlvar{'lonDocRoot'}; my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); - my $now=time; + my $now=time(); my $local=localtime($now); print $fh "LOND status $local - parent $$\n\n"; opendir(DIR,"$docdir/lon-status/londchld"); @@ -6241,9 +6400,17 @@ $SIG{USR2} = \&UpdateHosts; # Read the host hashes: &Apache::lonnet::load_hosts_tab(); +my %iphost = &Apache::lonnet::get_iphost(1); my $dist=`$perlvar{'lonDaemons'}/distprobe`; +my $arch = `uname -i`; +chomp($arch); +if ($arch eq 'unknown') { + $arch = `uname -m`; + chomp($arch); +} + # -------------------------------------------------------------- # Accept connections. When a connection comes in, it is validated # and if good, a child process is created to process transactions @@ -6301,6 +6468,7 @@ sub make_new_child { or die "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = $clientip; &status('Started child '.$pid); + close($client); return; } else { # Child can *not* return from this subroutine. @@ -6309,6 +6477,14 @@ sub make_new_child { #don't get intercepted $SIG{USR1}= \&logstatus; $SIG{ALRM}= \&timeout; + + # + # Block sigpipe as it gets thrownon socket disconnect and we want to + # deal with that as a read faiure instead. + # + my $blockset = POSIX::SigSet->new(SIGPIPE); + sigprocmask(SIG_BLOCK, $blockset); + $lastlog='Forked '; $status='Forked'; @@ -6393,7 +6569,7 @@ sub make_new_child { my $cipherkey = pack("H32", $key); $cipher = new IDEA($cipherkey); print $client "ok:local\n"; - &logthis('' . "Successful local authentication "); $keymode = "local" } else { @@ -6457,6 +6633,9 @@ sub make_new_child { # ------------------------------------------------------------ Process requests my $keep_going = 1; my $user_input; + my $clienthost = &Apache::lonnet::hostname($clientname); + my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost); + $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID); while(($user_input = get_request) && $keep_going) { alarm(120); Debug("Main: Got $user_input\n"); @@ -7029,7 +7208,9 @@ sub subscribe { # the metadata unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } $fname=~s/\/home\/httpd\/html\/res/raw/; - $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname; + my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}}; + $protocol = 'http' if ($protocol ne 'https'); + $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname; $result="$fname\n"; } } else { @@ -7187,7 +7368,7 @@ sub sethost { eq &Apache::lonnet::get_host_ip($hostid)) { $currenthostid =$hostid; $currentdomainid=&Apache::lonnet::host_domain($hostid); - &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); +# &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); } else { &logthis("Requested host id $hostid not an alias of ". $perlvar{'lonHostID'}." refusing connection"); @@ -7202,6 +7383,186 @@ sub version { return "version:$VERSION"; } +sub get_usersession_config { + my ($dom,$name) = @_; + my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom); + if (defined($cached)) { + return $usersessionconf; + } else { + my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom); + if (ref($domconfig{'usersessions'}) eq 'HASH') { + &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600); + return $domconfig{'usersessions'}; + } + } + return; +} + +sub releasereqd_check { + my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_; + my $home = &Apache::lonnet::homeserver($cnum,$cdom); + return if ($home eq 'no_host'); + my ($reqdmajor,$reqdminor,$displayrole); + if ($cnum =~ /$LONCAPA::match_community/) { + if ($major eq '' && $minor eq '') { + return unless ((ref($ids) eq 'ARRAY') && + (grep(/^\Q$home\E$/,@{$ids}))); + } else { + $reqdmajor = 2; + $reqdminor = 9; + return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); + } + } + my $hashid = $cdom.':'.$cnum; + my ($courseinfo,$cached) = + &Apache::lonnet::is_cached_new('courseinfo',$hashid); + if (defined($cached)) { + if (ref($courseinfo) eq 'HASH') { + if (exists($courseinfo->{'releaserequired'})) { + my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'}); + return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); + } + } + } else { + if (ref($ids) eq 'ARRAY') { + if (grep(/^\Q$home\E$/,@{$ids})) { + if (ref($homecourses) eq 'HASH') { + if (ref($homecourses->{$hashid}) eq 'ARRAY') { + push(@{$homecourses->{$hashid}},{$key=>$value}); + } else { + $homecourses->{$hashid} = [{$key=>$value}]; + } + } + return; + } + } + my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home); + if (ref($courseinfo) eq 'HASH') { + if (exists($courseinfo->{'releaserequired'})) { + my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'}); + return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); + } + } else { + return; + } + } + return 1; +} + +sub get_courseinfo_hash { + my ($cnum,$cdom,$home) = @_; + my %info; + eval { + local($SIG{ALRM}) = sub { die "timeout\n"; }; + local($SIG{__DIE__})='DEFAULT'; + alarm(3); + %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.'); + alarm(0); + }; + if ($@) { + if ($@ eq "timeout\n") { + &logthis("WARNING courseiddump for $cnum:$cdom from $home timedout"); + } else { + &logthis("WARNING unexpected error during eval of call for courseiddump from $home"); + } + } else { + if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') { + my $hashid = $cdom.':'.$cnum; + return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600); + } + } + return; +} + +sub check_homecourses { + my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_; + my ($result,%addtocache); + my $yesterday = time - 24*3600; + if (ref($homecourses) eq 'HASH') { + my (%okcourses,%courseinfo,%recent); + my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); + if ($hashref) { + while (my ($key,$value) = each(%$hashref)) { + my $unesc_key = &unescape($key); + if ($unesc_key =~ /^lasttime:(\w+)$/) { + my $cid = $1; + $cid =~ s/_/:/; + if ($value > $yesterday ) { + $recent{$cid} = 1; + } + next; + } + my $items = &Apache::lonnet::thaw_unescape($value); + if (ref($items) eq 'HASH') { + my $hashid = $unesc_key; + $hashid =~ s/_/:/; + $courseinfo{$hashid} = $items; + if (ref($homecourses->{$hashid}) eq 'ARRAY') { + my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'}); + if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) { + $okcourses{$hashid} = 1; + } + } + } + } + unless (&untie_domain_hash($hashref)) { + &logthis('Failed to untie tied hash for nohist_courseids.db'); + } + } else { + &logthis('Failed to tie hash for nohist_courseids.db'); + return; + } + foreach my $hashid (keys(%recent)) { + my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid); + unless ($cached) { + &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600); + } + } + foreach my $hashid (keys(%{$homecourses})) { + next if ($recent{$hashid}); + &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600); + } + foreach my $hashid (keys(%okcourses)) { + if (ref($homecourses->{$hashid}) eq 'ARRAY') { + foreach my $role (@{$homecourses->{$hashid}}) { + if (ref($role) eq 'HASH') { + while (my ($key,$value) = each(%{$role})) { + if ($regexp eq '.') { + $count++; + if (defined($range) && $count >= $end) { last; } + if (defined($range) && $count < $start) { next; } + $result.=$key.'='.$value.'&'; + } else { + my $unescapeKey = &unescape($key); + if (eval('$unescapeKey=~/$regexp/')) { + $count++; + if (defined($range) && $count >= $end) { last; } + if (defined($range) && $count < $start) { next; } + $result.="$key=$value&"; + } + } + } + } + } + } + } + } + return $result; +} + +sub useable_role { + my ($reqdmajor,$reqdminor,$major,$minor) = @_; + if ($reqdmajor ne '' && $reqdminor ne '') { + return if (($major eq '' && $minor eq '') || + ($major < $reqdmajor) || + (($major == $reqdmajor) && ($minor < $reqdminor))); + } + return 1; +} + +sub distro_and_arch { + return $dist.':'.$arch; +} # ----------------------------------- POD (plain old documentation, CPAN style)