--- loncom/lonnet/perl/lonnet.pm 2010/06/03 00:07:17 1.1067 +++ loncom/lonnet/perl/lonnet.pm 2010/07/17 20:02:13 1.1073 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1067 2010/06/03 00:07:17 www Exp $ +# $Id: lonnet.pm,v 1.1073 2010/07/17 20:02:13 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -76,7 +76,7 @@ use HTTP::Date; use Image::Magick; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir - $_64bit %env %protocol); + $_64bit %env %protocol %loncaparevs); my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, @@ -196,7 +196,7 @@ sub get_server_timezone { } sub get_server_loncaparev { - my ($dom,$lonhost) = @_; + my ($dom,$lonhost,$ignore_cache,$caller) = @_; if (defined($lonhost)) { if (!defined(&hostname($lonhost))) { undef($lonhost); @@ -211,14 +211,45 @@ sub get_server_loncaparev { } } if (defined($lonhost)) { - my $cachetime = 24*3600; - my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); - if (defined($cached)) { - return $loncaparev; - } else { - my $loncaparev = &reply('serverloncaparev',$lonhost); - return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); + my $cachetime = 12*3600; + if (!$ignore_cache) { + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); + if (defined($cached)) { + return $loncaparev; + } } + my ($answer,$loncaparev); + my @ids=¤t_machine_ids(); + if (grep(/^\Q$lonhost\E$/,@ids)) { + $answer = $perlvar{'lonVersion'}; + if ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { + $loncaparev = $1; + } + } else { + $answer = &reply('serverloncaparev',$lonhost); + if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { + if ($caller eq 'loncron') { + my $ua=new LWP::UserAgent; + $ua->timeout(20); + my $protocol = $protocol{$lonhost}; + $protocol = 'http' if ($protocol ne 'https'); + my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; + my $request=new HTTP::Request('GET',$url); + my $response=$ua->request($request); + unless ($response->is_error()) { + my $content = $response->content; + if ($content =~ /

VERSION\:\s*([\d.\-]+)<\/p>/) { + $loncaparev = $1; + } + } + } else { + $loncaparev = $loncaparevs{$lonhost}; + } + } elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { + $loncaparev = $1; + } + } + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); } } @@ -710,7 +741,7 @@ sub compare_server_load { my $userloadans = &reply('userload',$try_server); if ($loadans !~ /\d/ && $userloadans !~ /\d/) { - next; #didn't get a number from the server + return; #didn't get a number from the server } my $load; @@ -811,7 +842,7 @@ sub queryauthenticate { # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { - my ($uname,$upass,$udom,$checkdefauth)=@_; + my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_; $upass=&escape($upass); $uname= &LONCAPA::clean_username($uname); my $uhome=&homeserver($uname,$udom,1); @@ -834,7 +865,7 @@ sub authenticate { return 'no_host'; } } - my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); + my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome); if ($answer eq 'authorized') { if ($newhome) { &logthis("User $uname at $udom authorized by $uhome, but needs account"); @@ -852,6 +883,63 @@ sub authenticate { return 'no_host'; } +sub can_host_session { + my ($udom,$machinedom,$remoterev,$remotesessions,$hostedsessions) = @_; + my $canhost = 1; + if (ref($remotesessions) eq 'HASH') { + if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') { + if (grep(/^\Q$machinedom\E$/,@{$remotesessions->{'excludedomain'}})) { + $canhost = 0; + } else { + $canhost = 1; + } + } + if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') { + if (grep(/^\Q$machinedom\E$/,@{$remotesessions->{'includedomain'}})) { + $canhost = 1; + } else { + $canhost = 0; + } + } + if ($canhost) { + if ($remotesessions->{'version'} ne '') { + my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/); + if ($reqmajor ne '' && $reqminor ne '') { + if ($remoterev =~ /^\'?(\d+)\.(\d+)/) { + my $major = $1; + my $minor = $2; + if (($major < $reqmajor ) || + (($major == $reqmajor) && ($minor < $reqminor))) { + $canhost = 0; + } + } else { + $canhost = 0; + } + } + } + } + } + if ($canhost) { + if (ref($hostedsessions) eq 'HASH') { + if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { + if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) { + $canhost = 0; + } else { + $canhost = 1; + } + } + if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { + if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) { + $canhost = 1; + } else { + $canhost = 0; + } + } + } + } + return $canhost; +} + # ---------------------- Find the homebase for a user from domain's lib servers my %homecache; @@ -1328,7 +1416,7 @@ sub get_domain_defaults { my %domconfig = &Apache::lonnet::get_dom('configuration',['defaults','quotas', 'requestcourses','inststatus', - 'coursedefaults'],$domain); + 'coursedefaults','usersessions'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -1368,6 +1456,14 @@ sub get_domain_defaults { $domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; } } + if (ref($domconfig{'usersessions'}) eq 'HASH') { + if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { + $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'}; + } + if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { + $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; + } + } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -3035,7 +3131,7 @@ sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, - $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_; + $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -3057,7 +3153,8 @@ sub courseiddump { $showhidden.':'.$caller.':'.&escape($cloner).':'. &escape($cc_clone).':'.$cloneonly.':'. &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext),$tryserver); + &escape($creationcontext).':'.$domcloner, + $tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -8131,6 +8228,7 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata my %metaentry; +my %importedpartids; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -8157,6 +8255,10 @@ sub metadata { if (defined($cached)) { return $result->{':'.$what}; } } { +# Imported parts would go here + my %importedids=(); + my @origfileimportpartids=(); + my $importedparts=0; # # Is this a recursive call for a library? # @@ -8240,7 +8342,7 @@ sub metadata { # This is not a package - some other kind of start tag # my $entry=$token->[1]; - my $unikey; + my $unikey=''; if ($entry eq 'import') { # @@ -8250,10 +8352,42 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - - $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; + + my $importmode=$token->[2]->{'importmode'}; + if ($importmode eq 'problem') { +# Import as problem/response + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + } elsif ($importmode eq 'part') { +# Import as part(s) + $importedparts=1; +# We need to get the original file and the imported file to get the part order correct +# Good news: we do not need to worry about nested libraries, since parts cannot be nested +# Load and inspect original file + if ($#origfileimportpartids<0) { + undef(%importedpartids); + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + my $origfile=&getfile($origfilelocation); + @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + } + +# Load and inspect imported file + my $impfile=&getfile($location); + my @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + if ($#impfilepartids>=0) { +# This problem had parts + $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); + } else { +# Importing by turning a single problem into a problem part +# It gets the import-tags ID as part-ID + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); + $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; + } + } else { +# Normal import + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } } if ($depthcount<20) { @@ -8264,7 +8398,8 @@ sub metadata { $metaentry{':'.$meta}=$metaentry{':'.$meta}; $metathesekeys{$meta}=1; } - } + + } } else { # # Not importing, some other kind of non-package, non-library start tag @@ -8346,6 +8481,22 @@ sub metadata { grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); $metaentry{':packages'} = join(',',@uniq_packages); + if ($importedparts) { +# We had imported parts and need to rebuild partorder + $metaentry{':partorder'}=''; + $metathesekeys{'partorder'}=1; + for (my $index=0;$index<$#origfileimportpartids;$index+=2) { + if ($origfileimportpartids[$index] eq 'part') { +# original part, part of the problem + $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; + } else { +# we have imported parts at this position + $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; + } + } + $metaentry{':partorder'}=~s/^\,//; + } + $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); @@ -9948,6 +10099,24 @@ BEGIN { close($config); } +# ---------------------------------------------------------- Read loncaparev table +{ + if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { + if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { + while (my $configline=<$config>) { + chomp($configline); + my ($hostid,$loncaparev)=split(/:/,$configline); + $loncaparevs{$hostid}=$loncaparev; + } + close($config); + } + } +} + +sub all_loncaparevs { + return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10); +} + # ------------- set up temporary directory { $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; @@ -10178,9 +10347,14 @@ authentication scheme =item * X -B: try to +B: try to authenticate user from domain's lib servers (first use the current one). C<$upass> should be the users password. +$checkdefauth is optional (value is 1 if a check should be made to + authenticate user using default authentication method, and allow + account creation if username does not have account in the domain). +$clientcancheckhost is optional (value is 1 if checking whether the + server can host will occur on the client side in lonauth.pm). =item * X