--- loncom/lonnet/perl/lonnet.pm 2007/05/02 22:01:32 1.824.2.5 +++ loncom/lonnet/perl/lonnet.pm 2007/04/04 00:10:15 1.863 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.824.2.5 2007/05/02 22:01:32 albertel Exp $ +# $Id: lonnet.pm,v 1.863 2007/04/04 00:10:15 albertel 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; } @@ -722,15 +734,27 @@ sub idput { # ------------------------------------------- get items from domain db files sub get_dom { - my ($namespace,$storearr,$udom)=@_; + my ($namespace,$storearr,$udom,$uhome)=@_; my $items=''; foreach my $item (@$storearr) { $items.=&escape($item).'&'; } $items=~s/\&$//; - if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + $uhome eq ''; + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { @@ -744,17 +768,29 @@ sub get_dom { } return %returnhash; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + &logthis("get_dom failed - no homeserver and/or domain"); } } # -------------------------------------------- put items in domain db files sub put_dom { - my ($namespace,$storehash,$udom)=@_; - if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + my ($namespace,$storehash,$udom,$uhome)=@_; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + $uhome eq ''; + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { my $items=''; foreach my $item (keys(%$storehash)) { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; @@ -762,10 +798,34 @@ sub put_dom { $items=~s/\&$//; return &reply("putdom:$udom:$namespace:$items",$uhome); } else { - &logthis("put_dom failed - no primary domain server for $udom"); + &logthis("put_dom failed - no homeserver and/or domain"); } } +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 { @@ -992,10 +1052,7 @@ my $kicks=0; my $hits=0; sub make_key { my ($name,$id) = @_; - if (length($id) > 65 - && length(&escape($id)) > 200) { - $id=length($id).':'.&Digest::MD5::md5_hex($id); - } + if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } return &escape($name.':'.$id); } @@ -1042,9 +1099,7 @@ sub do_cache_new { $time=600; } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - if (!($memcache->set($id,$setvalue,$time))) { - &logthis("caching of id -> $id failed"); - } + $memcache->set($id,$setvalue,$time); # need to make a copy of $value #&make_room($id,$value,$debug); return $value; @@ -1213,6 +1268,7 @@ sub repcopy { } $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; +# FIXME: this should flock if ((-e $filename) || (-e $transname)) { return 'ok'; } my $remoteurl=subscribe($filename); if ($remoteurl =~ /^con_lost by/) { @@ -1461,15 +1517,17 @@ sub store_edited_file { } sub clean_filename { - my ($fname)=@_; + my ($fname,$args)=@_; # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; -# Get rid of everything but the actual filename - $fname=~s/^.*\/([^\/]+)$/$1/; + if (!$args->{'keep_path'}) { + # Get rid of everything but the actual filename + $fname=~s/^.*\/([^\/]+)$/$1/; + } # Replace spaces by underscores $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing - $fname=~s/[^\w\.\-]//g; + $fname=~s{[^/\w\.\-]}{}g; # Replace all .\d. sequences with _\d. so they no longer look like version # numbers $fname=~s/\.(\d+)(?=\.)/_$1/g; @@ -1482,14 +1540,21 @@ 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 +# $thumbwidth - width (pixels) of thumbnail to make for uploaded image +# $thumbheight - height (pixels) of thumbnail to make for uploaded image +# # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, + $destudom,$thumbwidth,$thumbheight)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); @@ -1536,7 +1601,7 @@ sub userfileupload { if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, - $codebase); + $codebase,$thumbwidth,$thumbheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, @@ -1546,8 +1611,9 @@ sub userfileupload { } elsif (defined($destuname)) { my $docuname=$destuname; my $docudom=$destudom; - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } else { my $docuname=$env{'user.name'}; @@ -1556,16 +1622,18 @@ sub userfileupload { $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; } - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } } sub finishuserfileupload { - my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, + $thumbwidth,$thumbheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; - my ($fnamepath,$file); + my ($fnamepath,$file,$fetchthumb); $file=$fname; if ($fname=~m|/|) { ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); @@ -1601,11 +1669,28 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } + if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { + my $input = $filepath.'/'.$file; + my $output = $filepath.'/'.'tn-'.$file; + my $thumbsize = $thumbwidth.'x'.$thumbheight; + system("convert -sample $thumbsize $input $output"); + if (-e $filepath.'/'.'tn-'.$file) { + $fetchthumb = 1; + } + } + # Notify homeserver to grep it # my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { + if ($fetchthumb) { + my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); + if ($thumbresult ne 'ok') { + &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. + $docuhome.': '.$thumbresult); + } + } # # Return the URL to it return '/uploaded/'.$path.$file; @@ -1613,7 +1698,7 @@ sub finishuserfileupload { &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. ': '.$fetchresult); return '/adm/notfound.html'; - } + } } sub extract_embedded_items { @@ -1827,8 +1912,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 @@ -1895,13 +1981,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++; @@ -2035,21 +2120,50 @@ sub get_course_adv_roles { } sub get_my_roles { - my ($uname,$udom)=@_; + 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)) { my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } - if (($tend) && ($tend<$now)) { next; } - if (($tstart) && ($now<$tstart)) { next; } + my $status = 'active'; + if (($tend) && ($tend<$now)) { + $status = 'previous'; + } + if (($tstart) && ($now<$tstart)) { + $status = 'future'; + } + if (ref($types) eq 'ARRAY') { + if (!grep(/^\Q$status\E$/,@{$types})) { + next; + } + } else { + if ($status ne 'active') { + next; + } + } my ($role,$username,$domain,$section)=split(/\:/,$entry); + if (ref($roledoms) eq 'ARRAY') { + if (!grep(/^\Q$domain\E$/,@{$roledoms})) { + next; + } + } + if (ref($roles) eq 'ARRAY') { + if (!grep(/^\Q$role\E$/,@{$roles})) { + next; + } + } $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; - } + } return %returnhash; } @@ -2059,7 +2173,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); } @@ -2095,11 +2209,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))) { @@ -2127,12 +2246,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); @@ -2153,19 +2273,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; } @@ -2255,7 +2375,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))); @@ -2924,7 +3044,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 '')) { @@ -3466,16 +3586,9 @@ sub get_portfolio_access { } if (@users > 0) { foreach my $userkey (@users) { - if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { - foreach my $item (@{$access_hash->{$userkey}{'users'}}) { - if (ref($item) eq 'HASH') { - if (($item->{'uname'} eq $env{'user.name'}) && - ($item->{'udom'} eq $env{'user.domain'})) { - return 'ok'; - } - } - } - } + if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { + return 'ok'; + } } } my %roleshash; @@ -4139,6 +4252,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) { @@ -4162,7 +4276,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); @@ -4194,7 +4308,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}}).'%%'; @@ -4291,6 +4405,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); } @@ -4385,7 +4505,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})) { @@ -4425,12 +4545,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)); @@ -4464,35 +4583,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 { @@ -4785,21 +4900,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')) { @@ -5014,7 +5127,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 @@ -5125,9 +5238,7 @@ sub is_locked { sub declutter_portfile { my ($file) = @_; - &logthis("got $file"); - $file =~ s-^(/portfolio/|portfolio/)-/-; - &logthis("ret $file"); + $file =~ s{^(/portfolio/|portfolio/)}{/}; return $file; } @@ -5360,6 +5471,53 @@ sub modify_access_controls { return ($outcome,$deloutcome,\%new_values,\%translation); } +sub make_public_indefinitely { + my ($requrl) = @_; + my $now = time; + my $action = 'activate'; + my $aclnum = 0; + if (&is_portfolio_url($requrl)) { + my (undef,$udom,$unum,$file_name,$group) = + &parse_portfolio_url($requrl); + my $current_perms = &get_portfile_permissions($udom,$unum); + my %access_controls = &get_access_controls($current_perms, + $group,$file_name); + foreach my $key (keys(%{$access_controls{$file_name}})) { + my ($num,$scope,$end,$start) = + ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); + if ($scope eq 'public') { + if ($start <= $now && $end == 0) { + $action = 'none'; + } else { + $action = 'update'; + $aclnum = $num; + } + last; + } + } + if ($action eq 'none') { + return 'ok'; + } else { + my %changes; + my $newend = 0; + my $newstart = $now; + my $newkey = $aclnum.':public_'.$newend.'_'.$newstart; + $changes{$action}{$newkey} = { + type => 'public', + time => { + start => $newstart, + end => $newend, + }, + }; + my ($outcome,$deloutcome,$new_values,$translation) = + &modify_access_controls($file_name,\%changes,$udom,$unum); + return $outcome; + } + } else { + return 'invalid'; + } +} + #------------------------------------------------------Get Marked as Read Only sub get_marked_as_readonly { @@ -5502,28 +5660,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))) { @@ -5535,18 +5692,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'); } } @@ -6109,7 +6260,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]); } } @@ -6827,7 +6979,6 @@ sub getCODE { sub rndseed { my ($symb,$courseid,$domain,$username)=@_; - my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); if (!$symb) { unless ($symb=$wsymb) { return time; } @@ -7031,13 +7182,14 @@ sub setup_random_from_rndseed { } sub latest_receipt_algorithm_id { - return 'receipt2'; + return 'receipt3'; } sub recunique { my $fucourseid=shift; my $unique; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { $unique=$env{"course.$fucourseid.internal.encseed"}; } else { $unique=$perlvar{'lonReceipt'}; @@ -7048,7 +7200,8 @@ sub recunique { sub recprefix { my $fucourseid=shift; my $prefix; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'|| + $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { $prefix=$env{"course.$fucourseid.internal.encpref"}; } else { $prefix=$perlvar{'lonHostID'}; @@ -7058,15 +7211,23 @@ sub recprefix { sub ireceipt { my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; + + my $return =&recprefix($fucourseid).'-'; + + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' || + $env{'request.state'} eq 'construct') { + $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000); + return $return; + } + my $cuname=unpack("%32C*",$funame); my $cudom=unpack("%32C*",$fudom); my $cucourseid=unpack("%32C*",$fucourseid); my $cusymb=unpack("%32C*",$fusymb); my $cunique=&recunique($fucourseid); my $cpart=unpack("%32S*",$part); - my $return =&recprefix($fucourseid).'-'; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || - $env{'request.state'} eq 'construct') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); $return.= ($cunique%$cuname+ @@ -7155,53 +7316,59 @@ sub repcopy_userfile { if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); - my ($info,$rtncode); my $uri="/uploaded/$cdom/$cnum/$filename"; if (-e "$file") { +# we already have a local copy, check it out my @fileinfo = stat($file); + my $rtncode; + my $info; my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { +# there is no such file anymore, even though we had a local copy if ($rtncode eq '404') { unlink($file); } - #my $ua=new LWP::UserAgent; - #my $request=new HTTP::Request('GET',&tokenwrapper($uri)); - #my $response=$ua->request($request); - #if ($response->is_success()) { - # return $response->content; - # } else { - # return -1; - # } return -1; } if ($info < $fileinfo[9]) { +# nice, the file we have is up-to-date, just say okay return 'ok'; + } else { +# the file is outdated, get rid of it + unlink($file); } - $info = ''; - $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp ne 'ok') { - return -1; - } - } else { - my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp ne 'ok') { - return -1; - } - my @parts = ($cdom,$cnum); - if ($filename =~ m|^(.+)/[^/]+$|) { - push @parts, split(/\//,$1); - } - my $path = $perlvar{'lonDocRoot'}.'/userfiles'; - foreach my $part (@parts) { - $path .= '/'.$part; - if (!-e $path) { - mkdir($path,0770); - } + } +# one way or the other, at this point, we don't have the file +# construct the correct path for the file + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + my $path = $perlvar{'lonDocRoot'}.'/userfiles'; + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); } } - open(FILE,">$file"); - print FILE $info; - close(FILE); +# now the path exists for sure +# get a user agent + my $ua=new LWP::UserAgent; + my $transferfile=$file.'.in.transfer'; +# FIXME: this should flock + if (-e $transferfile) { return 'ok'; } + my $request; + $uri=~s/^\///; + $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()) { + unlink($transferfile); + &logthis("Userfile repcopy failed for $uri"); + return -1; + } +# worked, rename the transfer file + rename($transferfile,$file); return 'ok'; } @@ -7215,7 +7382,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 { @@ -7223,10 +7390,14 @@ sub tokenwrapper { } } +# call with reqtype HEAD: get last modification time +# call with reqtype GET: get the file contents +# Do not call this with reqtype GET for large files! It loads everything into memory +# 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); @@ -7316,20 +7487,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) { @@ -7467,86 +7649,225 @@ sub goodbye { &logthis("Shutting down"); } -BEGIN { -# ----------------------------------- Read loncapa.conf and loncapa_apache.conf - unless ($readit) { -{ - my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); - %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; - # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); -# &logthis("Domain.tab: $domain ".$domaindescription{$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; } } - close ($fh); + + 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); + + my ($name,$what) = @_; + return if ( !exists($domain{$name}) ); + + if (!$what) { + return $domain{$name}{'description'}; + } + return $domain{$name}{$what}; + } } # ------------------------------------------------------------- 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; } + } + } + } - 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; + } + + 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; } - close($config); - # FIXME: dev server don't want this, production servers _do_ want this - #&get_iphost(); } -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\n"); - 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; } +BEGIN { + +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf + unless ($readit) { +{ + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); +} + + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -7878,6 +8199,16 @@ 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 @@ -7905,6 +8236,21 @@ and course level plaintext($short) : return value in %prp hash (rolesplain.tab); plain text explanation of a user role term +=item * + +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 =head2 User Modification @@ -8328,12 +8674,15 @@ critical subroutine =item * -get_dom($namespace,$storearr,$udomain) : returns hash with keys from array -reference filled in from namespace found in domain level on primary domain server ($udomain is optional) +get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from +array reference filled in from namespace found in domain level on either +specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). =item * -put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) +put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at +domain level either on specified domain server ($uhome) or primary domain +server ($udom and $uhome are optional) =back