--- loncom/lonnet/perl/lonnet.pm 2007/03/17 04:13:06 1.824.2.3 +++ loncom/lonnet/perl/lonnet.pm 2007/03/12 17:07:43 1.847 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.824.2.3 2007/03/17 04:13:06 albertel Exp $ +# $Id: lonnet.pm,v 1.847 2007/03/12 17:07:43 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; @@ -149,7 +147,7 @@ sub logperm { # -------------------------------------------------- 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 @@ -189,7 +187,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 +199,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 +208,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 +222,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 +515,7 @@ sub spareserver { } if (!$want_server_name) { - $spare_server="http://$hostname{$spare_server}"; + $spare_server="http://".&hostname($spare_server); } return $spare_server; } @@ -615,9 +606,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 +638,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 +661,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 +725,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 +749,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 +762,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,16 +1010,10 @@ 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=&make_key($name,$id); + $id=&escape($name.':'.$id); $memcache->delete($id); delete($remembered{$id}); delete($accessed{$id}); @@ -1007,7 +1021,7 @@ sub devalidate_cache_new { sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&make_key($name,$id); + $id=&escape($name.':'.$id); if (exists($remembered{$id})) { if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; @@ -1030,7 +1044,7 @@ sub is_cached_new { sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - $id=&make_key($name,$id); + $id=&escape($name.':'.$id); my $setvalue=$value; if (!defined($setvalue)) { $setvalue='__undef__'; @@ -1208,6 +1222,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/) { @@ -1456,15 +1471,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; @@ -1822,8 +1839,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 @@ -1890,13 +1908,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++; @@ -2030,7 +2047,7 @@ sub get_course_adv_roles { } sub get_my_roles { - my ($uname,$udom)=@_; + my ($uname,$udom,$types,$roles,$roledoms)=@_; unless (defined($uname)) { $uname=$env{'user.name'}; } unless (defined($udom)) { $udom=$env{'user.domain'}; } my %dumphash= @@ -2040,11 +2057,35 @@ sub get_my_roles { 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; } @@ -2054,7 +2095,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); } @@ -2090,11 +2131,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))) { @@ -2122,12 +2168,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); @@ -2148,19 +2195,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; } @@ -2250,7 +2297,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))); @@ -2919,7 +2966,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 '')) { @@ -4127,6 +4174,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) { @@ -4150,7 +4198,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); @@ -4182,7 +4230,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}}).'%%'; @@ -4373,7 +4421,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})) { @@ -4413,12 +4461,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)); @@ -4452,35 +4499,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 { @@ -4773,21 +4816,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')) { @@ -5002,7 +5043,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 @@ -5113,9 +5154,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; } @@ -5348,6 +5387,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 { @@ -5490,28 +5576,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))) { @@ -5523,18 +5608,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'); } } @@ -7019,13 +7098,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'}; @@ -7036,7 +7116,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'}; @@ -7046,15 +7127,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+ @@ -7143,53 +7232,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'; } @@ -7203,7 +7298,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 { @@ -7211,10 +7306,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); @@ -7304,20 +7403,22 @@ sub hreflocation { } sub current_machine_domains { - my $hostname=$hostname{$perlvar{'lonHostID'}}; + my $hostname=&hostname($perlvar{'lonHostID'}); 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'}}; + my $hostname=&hostname($perlvar{'lonHostID'}); my @ids; + my %hostname = &all_hostnames(); while( my($id, $name) = each(%hostname)) { # &logthis("-$id-$name-$hostname-"); if ($hostname eq $name) { @@ -7465,36 +7566,44 @@ BEGIN { # ------------------------------------------------------------ Read domain file { - %domaindescription = (); - %domain_auth_def = (); - %domain_auth_arg_def = (); + my %domain; + 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; + next if ($line =~ /^(\#|\s*$ )/); - # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); + 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: $domain ".$domaindescription{$domain} ); } } close ($fh); + + sub domain { + my ($name,$what) = @_; + return if ( !exists($domain{$name}) ); + + if (!$what) { + return $domain{$name}{'description'}; + } + return $domain{$name}{$what}; + } } # ------------------------------------------------------------- Read hosts file { + my %hostname; + my %hostdom; + my %libserv; open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { @@ -7511,28 +7620,90 @@ BEGIN { close($config); # FIXME: dev server don't want this, production servers _do_ want this #&get_iphost(); -} -sub get_iphost { - if (%iphost) { return %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; + sub hostname { + my ($lonid) = @_; + return $hostname{$lonid}; + } + + sub all_hostnames { + return %hostname; + } + + sub is_library { + return exists($libserv{$_[0]}); + } + + sub all_library { + return %libserv; + } + + sub get_servers { + 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; + } } - $ip=inet_ntoa($ip); - $name_to_ip{$name} = $ip; } else { - $ip = $name_to_ip{$name}; + while ( my ($host,$hostname) = each(%possible_hosts)) { + if ($hostdom{$host} eq $domain) { + $result{$host} = $hostname; + } + } + } + return %result; + } + + sub host_domain { + my ($lonid) = @_; + return $hostdom{$lonid}; + } + + sub all_domains { + my %seen; + my @uniq = grep(!$seen{$_}++, values(%hostdom)); + return @uniq; + } +} + +{ + my %iphost; + sub get_hosts_from_ip { + my ($ip) = @_; + my %iphosts = &get_iphost(); + if (ref($iphosts{$ip})) { + return @{$iphosts{$ip}}; } - push(@{$iphost{$ip}},$id); + return; + } + + sub get_iphost { + if (%iphost) { return %iphost; } + my %name_to_ip; + 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}; + } + push(@{$iphost{$ip}},$id); + } + return %iphost; } - return %iphost; } # ------------------------------------------------------ Read spare server file @@ -7893,6 +8064,19 @@ 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,$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. + =back =head2 User Modification