--- loncom/lonnet/perl/lonnet.pm 2007/02/23 00:23:46 1.835 +++ loncom/lonnet/perl/lonnet.pm 2007/04/03 17:51:50 1.858 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.835 2007/02/23 00:23:46 albertel Exp $ +# $Id: lonnet.pm,v 1.858 2007/04/03 17:51:50 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -35,12 +35,10 @@ use HTTP::Headers; use HTTP::Date; # use Date::Parse; use vars -qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom - %libserv %pr %prp $memcache %packagetab +qw(%perlvar %badServerCache %spareid + %pr %prp $memcache %packagetab %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf - %domaindescription %domain_auth_def %domain_auth_arg_def - %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary $tmpdir $_64bit %env); use IO::Socket; @@ -146,10 +144,24 @@ sub logperm { return 1; } +sub create_connection { + my ($hostname,$lonid) = @_; + my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, + Type => SOCK_STREAM, + Timeout => 10); + return 0 if (!$client); + print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); + my $result = <$client>; + chomp($result); + return 1 if ($result eq 'done'); + return 0; +} + + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; + my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server); # # With loncnew process trimming, there's a timing hole between lonc server # process exit and the master server picking up the listen on the AF_UNIX @@ -172,8 +184,10 @@ sub subreply { Timeout => 10); if($client) { last; # Connected! + } else { + &create_connection(&hostname($server),$server); } - sleep(1); # Try again later if failed connection. + sleep(1); # Try again later if failed connection. } my $answer; if ($client) { @@ -189,7 +203,7 @@ sub subreply { sub reply { my ($cmd,$server)=@_; - unless (defined($hostname{$server})) { return 'no_such_host'; } + unless (defined(&hostname($server))) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". @@ -201,8 +215,7 @@ sub reply { # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { - my $peerfile=shift; - &logthis("Trying to reconnect for $peerfile"); + &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; if (open(my $fh,"<$loncfile")) { my $loncpid=<$fh>; @@ -211,19 +224,13 @@ sub reconlonc { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; sleep 1; - if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, give it another try"); - sleep 5; - if (-e "$peerfile") { return; } - &logthis( - "WARNING: $peerfile still not there, giving up"); - } else { + } else { &logthis( "WARNING:". " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('WARNING: lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } @@ -231,7 +238,7 @@ sub reconlonc { sub critical { my ($cmd,$server)=@_; - unless ($hostname{$server}) { + unless (&hostname($server)) { &logthis("WARNING:". " Critical message to unknown server ($server)"); return 'no_such_host'; @@ -524,7 +531,7 @@ sub spareserver { } if (!$want_server_name) { - $spare_server="http://$hostname{$spare_server}"; + $spare_server="http://".&hostname($spare_server); } return $spare_server; } @@ -615,9 +622,15 @@ sub authenticate { my ($uname,$upass,$udom)=@_; $upass=&escape($upass); $uname= &LONCAPA::clean_username($uname); - my $uhome=&homeserver($uname,$udom); - if (!$uhome) { - &logthis("User $uname at $udom is unknown in authenticate"); + my $uhome=&homeserver($uname,$udom,1); + if ((!$uhome) || ($uhome eq 'no_host')) { +# Maybe the machine was offline and only re-appeared again recently? + &reconlonc(); +# One more + my $uhome=&homeserver($uname,$udom,1); + if ((!$uhome) || ($uhome eq 'no_host')) { + &logthis("User $uname at $udom is unknown in authenticate"); + } return 'no_host'; } my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); @@ -641,18 +654,19 @@ sub homeserver { my $index="$uname:$udom"; if (exists($homecache{$index})) { return $homecache{$index}; } - my $tryserver; - foreach $tryserver (keys %libserv) { + + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { next if ($ignoreBadCache ne 'true' && exists($badServerCache{$tryserver})); - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("home:$udom:$uname",$tryserver); - if ($answer eq 'found') { - return $homecache{$index}=$tryserver; - } elsif ($answer eq 'no_host') { - $badServerCache{$tryserver}=1; - } - } + + my $answer=reply("home:$udom:$uname",$tryserver); + if ($answer eq 'found') { + delete($badServerCache{$tryserver}); + return $homecache{$index}=$tryserver; + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } return 'no_host'; } @@ -663,24 +677,22 @@ sub idget { my ($udom,@ids)=@_; my %returnhash=(); - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $idlist=join('&',@ids); - $idlist=~tr/A-Z/a-z/; - my $reply=&reply("idget:$udom:".$idlist,$tryserver); - my @answer=(); - if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { - @answer=split(/\&/,$reply); - } ; - my $i; - for ($i=0;$i<=$#ids;$i++) { - if ($answer[$i]) { - $returnhash{$ids[$i]}=$answer[$i]; - } - } - } - } + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { + my $idlist=join('&',@ids); + $idlist=~tr/A-Z/a-z/; + my $reply=&reply("idget:$udom:".$idlist,$tryserver); + my @answer=(); + if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { + @answer=split(/\&/,$reply); + } ; + my $i; + for ($i=0;$i<=$#ids;$i++) { + if ($answer[$i]) { + $returnhash{$ids[$i]}=$answer[$i]; + } + } + } return %returnhash; } @@ -729,8 +741,8 @@ sub get_dom { } $items=~s/\&$//; if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { @@ -753,8 +765,8 @@ sub get_dom { sub put_dom { my ($namespace,$storehash,$udom)=@_; if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); my $items=''; foreach my $item (keys(%$storehash)) { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; @@ -766,6 +778,30 @@ sub put_dom { } } +sub retrieve_inst_usertypes { + my ($udom) = @_; + my (%returnhash,@order); + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); + my $rep=&reply("inst_usertypes:$udom",$uhome); + my ($hashitems,$orderitems) = split(/:/,$rep); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@order,&unescape($item)); + } + } else { + &logthis("get_dom failed - no primary domain server for $udom"); + } + return (\%returnhash,\@order); +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -990,10 +1026,16 @@ my %remembered; my %accessed; my $kicks=0; my $hits=0; +sub make_key { + my ($name,$id) = @_; + if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } + return &escape($name.':'.$id); +} + sub devalidate_cache_new { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); $memcache->delete($id); delete($remembered{$id}); delete($accessed{$id}); @@ -1001,7 +1043,7 @@ sub devalidate_cache_new { sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); if (exists($remembered{$id})) { if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; @@ -1024,7 +1066,7 @@ sub is_cached_new { sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { $setvalue='__undef__'; @@ -1474,8 +1516,12 @@ sub clean_filename { # $coursedoc - if true up to the current course # if false # $subdir - directory in userfile to store the file into -# $parser, $allfiles, $codebase - unknown -# +# $parser - instruction to parse file for objects ($parser = parse) +# $allfiles - reference to hash for embedded objects +# $codebase - reference to hash for codebase of java objects +# $desuname - username for permanent storage of uploaded file +# $dsetudom - domain for permanaent storage of uploaded file +# # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse @@ -1593,6 +1639,7 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } + # Notify homeserver to grep it # my $docuhome=&homeserver($docuname,$docudom); @@ -1605,7 +1652,7 @@ sub finishuserfileupload { &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. ': '.$fetchresult); return '/adm/notfound.html'; - } + } } sub extract_embedded_items { @@ -1819,8 +1866,9 @@ sub flushcourselogs { # Write course id database (reverse lookup) to homeserver of courses # Is used in pickcourse # - foreach my $crsid (keys(%courseidbuffer)) { - &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid); + foreach my $crs_home (keys(%courseidbuffer)) { + &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home}, + $crs_home); } # # File accesses @@ -1887,13 +1935,12 @@ sub flushcourselogs { delete $domainrolehash{$entry}; } foreach my $dom (keys(%domrolebuffer)) { - foreach my $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $dom) { - unless (&reply('domroleput:'.$dom.':'. - $domrolebuffer{$dom},$tryserver) eq 'ok') { - &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); - } - } + my %servers = &get_servers($dom,'library'); + foreach my $tryserver (keys(%servers)) { + unless (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { + &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); + } } } $dumpcount++; @@ -2027,11 +2074,16 @@ sub get_course_adv_roles { } sub get_my_roles { - my ($uname,$udom,$types,$roles,$roledoms)=@_; + my ($uname,$udom,$context,$types,$roles,$roledoms)=@_; unless (defined($uname)) { $uname=$env{'user.name'}; } unless (defined($udom)) { $udom=$env{'user.domain'}; } - my %dumphash= + my %dumphash; + if ($context eq 'userroles') { + %dumphash = &dump('roles',$udom,$uname); + } else { + %dumphash= &dump('nohist_userroles',$udom,$uname); + } my %returnhash=(); my $now=time; foreach my $entry (keys(%dumphash)) { @@ -2075,7 +2127,7 @@ sub get_my_roles { sub postannounce { my ($server,$text)=@_; - unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless (&allowed('psa',&host_domain($server))) { return 'refused'; } unless ($text=~/\w/) { $text=''; } return &reply('setannounce:'.&escape($text),$server); } @@ -2111,11 +2163,16 @@ sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } - foreach my $tryserver (keys %libserv) { - if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { - if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + my %libserv = &all_library(); + foreach my $tryserver (keys(%libserv)) { + if ( ( $hostidflag == 1 + && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) + || (!defined($hostidflag)) ) { + + if ($domfilter eq '' + || (&host_domain($tryserver) eq $domfilter)) { foreach my $line ( - split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'. $sincefilter.':'.&escape($descfilter).':'. &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), $tryserver))) { @@ -2143,12 +2200,13 @@ sub dcmailput { sub dcmaildump { my ($dom,$startdate,$enddate,$senders) = @_; my %returnhash=(); - if (exists($domain_primary{$dom})) { + + if (defined(&domain($dom,'primary'))) { my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. &escape($enddate).':'; my @esc_senders=map { &escape($_)} @$senders; $cmd.=&escape(join('&',@esc_senders)); - foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { my ($key,$value) = split(/\=/,$line,2); if (($key) && ($value)) { $returnhash{&unescape($key)} = &unescape($value); @@ -2169,19 +2227,19 @@ sub get_domain_roles { } my $rolelist = join(':',@{$roles}); my %personnel = (); - foreach my $tryserver (keys(%libserv)) { - if ($hostdom{$tryserver} eq $dom) { - %{$personnel{$tryserver}}=(); - foreach my $line ( - split(/\&/,&reply('domrolesdump:'.$dom.':'. - &escape($startdate).':'.&escape($enddate).':'. - &escape($rolelist), $tryserver))) { - my ($key,$value) = split(/\=/,$line,2); - if (($key) && ($value)) { - $personnel{$tryserver}{&unescape($key)} = &unescape($value); - } - } - } + + my %servers = &get_servers($dom,'library'); + foreach my $tryserver (keys(%servers)) { + %{$personnel{$tryserver}}=(); + foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'. + &escape($startdate).':'. + &escape($enddate).':'. + &escape($rolelist), $tryserver))) { + my ($key,$value) = split(/\=/,$line,2); + if (($key) && ($value)) { + $personnel{$tryserver}{&unescape($key)} = &unescape($value); + } + } } return %personnel; } @@ -2271,7 +2329,7 @@ sub checkin { my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; + my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); @@ -2940,7 +2998,7 @@ sub custom_roleprivs { my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); my $homsvr=homeserver($rauthor,$rdomain); - if ($hostname{$homsvr} ne '') { + if (&hostname($homsvr) ne '') { my ($rdummy,$roledef)= &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); if (($rdummy ne 'con_lost') && ($roledef ne '')) { @@ -4148,6 +4206,7 @@ sub definerole { sub metadata_query { my ($query,$custom,$customshow,$server_array)=@_; my %rhash; + my %libserv = &all_library(); my @server_list = (defined($server_array) ? @$server_array : keys(%libserv) ); for my $server (@server_list) { @@ -4171,7 +4230,7 @@ sub log_query { my ($uname,$udom,$query,%filters)=@_; my $uhome=&homeserver($uname,$udom); if ($uhome eq 'no_host') { return 'error: no_host'; } - my $uhost=$hostname{$uhome}; + my $uhost=&hostname($uhome); my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); @@ -4203,7 +4262,7 @@ sub fetch_enrollment_query { } else { $homeserver = &homeserver($cnum,$dom); } - my $host=$hostname{$homeserver}; + my $host=&hostname($homeserver); my $cmd = ''; foreach my $affiliate (keys %{$affiliatesref}) { $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; @@ -4300,6 +4359,12 @@ sub courselog_query { } sub userlog_query { +# +# possible filters: +# action: log check role +# start: timestamp +# end: timestamp +# my ($uname,$udom,%filters)=@_; return &log_query($uname,$udom,'userlog',%filters); } @@ -4394,7 +4459,7 @@ sub auto_photochoice { sub auto_photoupdate { my ($affiliatesref,$dom,$cnum,$photo) = @_; my $homeserver = &homeserver($cnum,$dom); - my $host=$hostname{$homeserver}; + my $host=&hostname($homeserver); my $cmd = ''; my $maxtries = 1; foreach my $affiliate (keys(%{$affiliatesref})) { @@ -4434,12 +4499,11 @@ sub auto_instcode_format { my $courses = ''; my @homeservers; if ($caller eq 'global') { - foreach my $tryserver (keys(%libserv)) { - if ($hostdom{$tryserver} eq $codedom) { - if (!grep(/^\Q$tryserver\E$/,@homeservers)) { - push(@homeservers,$tryserver); - } - } + my %servers = &get_servers($codedom,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } } } else { push(@homeservers,&homeserver($caller,$codedom)); @@ -4473,35 +4537,31 @@ sub auto_instcode_format { sub auto_instcode_defaults { my ($domain,$returnhash,$code_order) = @_; my @homeservers; - foreach my $tryserver (keys(%libserv)) { - if ($hostdom{$tryserver} eq $domain) { - if (!grep(/^\Q$tryserver\E$/,@homeservers)) { - push(@homeservers,$tryserver); - } - } + + my %servers = &get_servers($domain,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } } - my $ok_response = 0; + my $response; - while (@homeservers > 0 && $ok_response == 0) { - my $server = shift(@homeservers); + foreach my $server (@homeservers) { $response=&reply('autoinstcodedefaults:'.$domain,$server); - if ($response !~ /(con_lost|error|no_such_host|refused)/) { - foreach my $pair (split(/\&/,$response)) { - my ($name,$value)=split(/\=/,$pair); - if ($name eq 'code_order') { - @{$code_order} = split(/\&/,&unescape($value)); - } else { - $returnhash->{&unescape($name)}=&unescape($value); - } - } - $ok_response = 1; - } - } - if ($ok_response) { - return 'ok'; - } else { - return $response; + next if ($response =~ /(con_lost|error|no_such_host|refused)/); + + foreach my $pair (split(/\&/,$response)) { + my ($name,$value)=split(/\=/,$pair); + if ($name eq 'code_order') { + @{$code_order} = split(/\&/,&unescape($value)); + } else { + $returnhash->{&unescape($name)}=&unescape($value); + } + } + return 'ok'; } + + return $response; } sub auto_validate_class_sec { @@ -4794,21 +4854,19 @@ sub modifyuser { if (($uhome eq 'no_host') && (($umode && $upass) || ($umode eq 'localauth'))) { my $unhome=''; - if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { + if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { $unhome = $desiredhome; } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; } else { # load balancing routine for determining $unhome - my $tryserver; my $loadm=10000000; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply('load',$tryserver); - if (($answer=~/\d+/) && ($answer<$loadm)) { - $loadm=$answer; - $unhome=$tryserver; - } - } + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { + my $answer=reply('load',$tryserver); + if (($answer=~/\d+/) && ($answer<$loadm)) { + $loadm=$answer; + $unhome=$tryserver; + } } } if (($unhome eq '') || ($unhome eq 'no_host')) { @@ -5023,7 +5081,7 @@ sub createcourse { } # ------------------------------------------------ Check supplied server name $course_server = $env{'user.homeserver'} if (! defined($course_server)); - if (! exists($libserv{$course_server})) { + if (! &is_library($course_server)) { return 'error:bad server name '.$course_server; } # ------------------------------------------------------------- Make the course @@ -5556,28 +5614,27 @@ sub dirlist { return @listing_results; } elsif(!defined($alternateDirectoryRoot)) { my %allusers; - foreach my $tryserver (keys(%libserv)) { - if($hostdom{$tryserver} eq $udom) { - my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); - my @listing_results; - if ($listing eq 'unknown_cmd') { - $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); - @listing_results = split(/:/,$listing); - } else { - @listing_results = - map { &unescape($_); } split(/:/,$listing); - } - if ($listing_results[0] ne 'no_such_dir' && - $listing_results[0] ne 'empty' && - $listing_results[0] ne 'con_lost') { - foreach my $line (@listing_results) { - my ($entry) = split(/&/,$line,2); - $allusers{$entry} = 1; - } - } - } + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { + my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + @listing_results = split(/:/,$listing); + } else { + @listing_results = + map { &unescape($_); } split(/:/,$listing); + } + if ($listing_results[0] ne 'no_such_dir' && + $listing_results[0] ne 'empty' && + $listing_results[0] ne 'con_lost') { + foreach my $line (@listing_results) { + my ($entry) = split(/&/,$line,2); + $allusers{$entry} = 1; + } + } } my $alluserstr=''; foreach my $user (sort(keys(%allusers))) { @@ -5589,18 +5646,12 @@ sub dirlist { return ('missing user name'); } } elsif(!defined($alternateDirectoryRoot)) { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys(%libserv)) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - foreach my $domain (sort(keys(%alldom))) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:'; - } - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); - } else { + my @all_domains = sort(&all_domains()); + foreach my $domain (@all_domains) { + $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; + } + return @all_domains; + } else { return ('missing domain'); } } @@ -6163,7 +6214,8 @@ sub packages_tab_default { $do_default=1; } elsif ($pack_type eq 'extension') { push(@extension,[$package,$pack_type,$pack_part]); - } else { + } elsif ($pack_part eq $part) { + # only look at packages defaults for packages that this id is push(@specifics,[$package,$pack_type,$pack_part]); } } @@ -6881,7 +6933,6 @@ sub getCODE { sub rndseed { my ($symb,$courseid,$domain,$username)=@_; - my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); if (!$symb) { unless ($symb=$wsymb) { return time; } @@ -7262,7 +7313,7 @@ sub repcopy_userfile { if (-e $transferfile) { return 'ok'; } my $request; $uri=~s/^\///; - $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri); + $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri); my $response=$ua->request($request,$transferfile); # did it work? if ($response->is_error()) { @@ -7285,7 +7336,7 @@ sub tokenwrapper { if ($udom && $uname && $file) { $file=~s|(\?\.*)*$||; &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); - return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. + return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -7300,7 +7351,7 @@ sub tokenwrapper { sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; - $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; + $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; my $ua=new LWP::UserAgent; my $request=new HTTP::Request($reqtype,$uri); my $response=$ua->request($request); @@ -7390,20 +7441,31 @@ sub hreflocation { } sub current_machine_domains { - my $hostname=$hostname{$perlvar{'lonHostID'}}; + return &machine_domains(&hostname($perlvar{'lonHostID'})); +} + +sub machine_domains { + my ($hostname) = @_; my @domains; + my %hostname = &all_hostnames(); while( my($id, $name) = each(%hostname)) { # &logthis("-$id-$name-$hostname-"); if ($hostname eq $name) { - push(@domains,$hostdom{$id}); + push(@domains,&host_domain($id)); } } return @domains; } sub current_machine_ids { - my $hostname=$hostname{$perlvar{'lonHostID'}}; + return &machine_ids(&hostname($perlvar{'lonHostID'})); +} + +sub machine_ids { + my ($hostname) = @_; + $hostname ||= &hostname($perlvar{'lonHostID'}); my @ids; + my %hostname = &all_hostnames(); while( my($id, $name) = each(%hostname)) { # &logthis("-$id-$name-$hostname-"); if ($hostname eq $name) { @@ -7542,6 +7604,7 @@ sub goodbye { } BEGIN { + # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { @@ -7549,76 +7612,218 @@ BEGIN { %perlvar = (%perlvar,%{$configvars}); } +sub get_dns { + my ($url,$func) = @_; + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + $dns = $1; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"http://$dns$url"); + my $response=$ua->request($request); + next if ($response->is_error()); + my @content = split("\n",$response->content); + &$func(\@content); + } + close($config); +} # ------------------------------------------------------------ Read domain file { - %domaindescription = (); - %domain_auth_def = (); - %domain_auth_arg_def = (); - my $fh; - if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { - while (my $line = <$fh>) { - next if ($line =~ /^(\#|\s*$)/); -# next if /^\#/; - chomp $line; - my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); - $domain_auth_def{$domain}=$def_auth; - $domain_auth_arg_def{$domain}=$def_auth_arg; - $domaindescription{$domain}=$domain_description; - $domain_lang_def{$domain}=$def_lang; - $domain_city{$domain}=$city; - $domain_longi{$domain}=$longi; - $domain_lati{$domain}=$lati; - $domain_primary{$domain}=$primary; + my $loaded; + my %domain; + + sub parse_domain_tab { + my ($lines) = @_; + foreach my $line (@$lines) { + next if ($line =~ /^(\#|\s*$ )/x); + + chomp($line); + my ($name,@elements) = split(/:/,$line,9); + my %this_domain; + foreach my $field ('description', 'auth_def', 'auth_arg_def', + 'lang_def', 'city', 'longi', 'lati', + 'primary') { + $this_domain{$field} = shift(@elements); + } + $domain{$name} = \%this_domain; + &logthis("Domain.tab: $name ".$domain{$name}{'description'} ); + } + } + + sub load_domain_tab { + &get_dns('/adm/dns/domain',\&parse_domain_tab); + my $fh; + if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { + my @lines = <$fh>; + &parse_domain_tab(\@lines); + } + close($fh); + $loaded = 1; + } + + sub domain { + &load_domain_tab() if (!$loaded); - # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); -# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + my ($name,$what) = @_; + return if ( !exists($domain{$name}) ); + + if (!$what) { + return $domain{$name}{'description'}; } + return $domain{$name}{$what}; } - close ($fh); } # ------------------------------------------------------------- Read hosts file { - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + my %hostname; + my %hostdom; + my %libserv; + my $loaded; + + sub parse_hosts_tab { + my ($file) = @_; + foreach my $configline (@$file) { + next if ($configline =~ /^(\#|\s*$ )/x); + next if ($configline =~ /^\^/); + chomp($configline); + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { + $hostname{$id}=$name; + $hostdom{$id}=$domain; + if ($role eq 'library') { $libserv{$id}=$name; } + } + &logthis("Hosts.tab: $name ".$id ); + } + } - while (my $configline=<$config>) { - next if ($configline =~ /^(\#|\s*$)/); - chomp($configline); - my ($id,$domain,$role,$name)=split(/:/,$configline); - $name=~s/\s//g; - if ($id && $domain && $role && $name) { - $hostname{$id}=$name; - $hostdom{$id}=$domain; - if ($role eq 'library') { $libserv{$id}=$name; } - } + sub load_hosts_tab { + &get_dns('/adm/dns/hosts',\&parse_hosts_tab); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + my @config = <$config>; + &parse_hosts_tab(\@config); + close($config); + $loaded=1; } - close($config); + # FIXME: dev server don't want this, production servers _do_ want this #&get_iphost(); + + sub hostname { + &load_hosts_tab() if (!$loaded); + + my ($lonid) = @_; + return $hostname{$lonid}; + } + + sub all_hostnames { + &load_hosts_tab() if (!$loaded); + + return %hostname; + } + + sub is_library { + &load_hosts_tab() if (!$loaded); + + return exists($libserv{$_[0]}); + } + + sub all_library { + &load_hosts_tab() if (!$loaded); + + return %libserv; + } + + sub get_servers { + &load_hosts_tab() if (!$loaded); + + my ($domain,$type) = @_; + my %possible_hosts = ($type eq 'library') ? %libserv + : %hostname; + my %result; + if (ref($domain) eq 'ARRAY') { + while ( my ($host,$hostname) = each(%possible_hosts)) { + if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) { + $result{$host} = $hostname; + } + } + } else { + while ( my ($host,$hostname) = each(%possible_hosts)) { + if ($hostdom{$host} eq $domain) { + $result{$host} = $hostname; + } + } + } + return %result; + } + + sub host_domain { + &load_hosts_tab() if (!$loaded); + + my ($lonid) = @_; + return $hostdom{$lonid}; + } + + sub all_domains { + &load_hosts_tab() if (!$loaded); + + my %seen; + my @uniq = grep(!$seen{$_}++, values(%hostdom)); + return @uniq; + } } -sub get_iphost { - if (%iphost) { return %iphost; } +{ + my %iphost; my %name_to_ip; - foreach my $id (keys(%hostname)) { - my $name=$hostname{$id}; - my $ip; - if (!exists($name_to_ip{$name})) { - $ip = gethostbyname($name); - if (!$ip || length($ip) ne 4) { - &logthis("Skipping host $id name $name no IP found"); - next; + my %lonid_to_ip; + sub get_hosts_from_ip { + my ($ip) = @_; + my %iphosts = &get_iphost(); + if (ref($iphosts{$ip})) { + return @{$iphosts{$ip}}; + } + return; + } + + sub get_host_ip { + my ($lonid) = @_; + if (exists($lonid_to_ip{$lonid})) { + return $lonid_to_ip{$lonid}; + } + my $name=&hostname($lonid); + my $ip = gethostbyname($name); + return if (!$ip || length($ip) ne 4); + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + $lonid_to_ip{$lonid} = $ip; + return $ip; + } + + sub get_iphost { + if (%iphost) { return %iphost; } + my %hostname = &all_hostnames(); + foreach my $id (keys(%hostname)) { + my $name=$hostname{$id}; + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found"); + next; + } + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; } - $ip=inet_ntoa($ip); - $name_to_ip{$name} = $ip; - } else { - $ip = $name_to_ip{$name}; + $lonid_to_ip{$id} = $ip; + push(@{$iphost{$ip}},$id); } - push(@{$iphost{$ip}},$id); + return %iphost; } - return %iphost; } # ------------------------------------------------------ Read spare server file @@ -7952,6 +8157,10 @@ X B: gets the values of the keys passed in @what from the requested user's environment, returns a hash +=item * +X +B: retrieves data from a user's activity.log file. %filters defines filters applied when parsing the log file. These can be start or end timestamps, or the type of action - log to look for Login or Logout events, check for Checkin or Checkout, role for role selection. The response is in the form timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are escaped strings of the action recorded in the activity.log file. + =back =head2 User Roles @@ -7981,16 +8190,18 @@ explanation of a user role term =item * -get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are -optional. Returns a hash of a user's roles, with keys set to -colon-sparated $uname,$udom,and $role, and value set to -colon-separated start and end times for the role. If no username and -domain are specified, will default to current user/domain. Types, -roles, and roledoms are references to arrays, of role statuses -(active, future or previous), roles (e.g., cc,in, st etc.) and domains -of the roles which can be used to restrict the list if roles -reported. If no array ref is provided for types, will default to -return only active roles. +get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : +All arguments are optional. Returns a hash of a roles, either for +co-author/assistant author roles for a user's Construction Space +(default), or if $context is 'user', roles for the user himself, +In the hash, keys are set to colon-sparated $uname,$udom,and $role, +and value is set to colon-separated start and end times for the role. +If no username and domain are specified, will default to current +user/domain. Types, roles, and roledoms are references to arrays, +of role statuses (active, future or previous), roles +(e.g., cc,in, st etc.) and domains of the roles which can be used +to restrict the list of roles reported. If no array ref is +provided for types, will default to return only active roles. =back