--- loncom/lonnet/perl/lonnet.pm 2007/01/18 21:02:06 1.828 +++ loncom/lonnet/perl/lonnet.pm 2007/02/23 15:49:23 1.836 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.828 2007/01/18 21:02:06 www Exp $ +# $Id: lonnet.pm,v 1.836 2007/02/23 15:49:23 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -201,8 +201,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 +210,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'); } } @@ -367,6 +360,26 @@ sub transfer_profile_to_env { } } +sub timed_flock { + my ($file,$lock_type) = @_; + my $failed=0; + eval { + local $SIG{__DIE__}='DEFAULT'; + local $SIG{ALRM}=sub { + $failed=1; + die("failed lock"); + }; + alarm(13); + flock($file,$lock_type); + alarm(0); + }; + if ($failed) { + return undef; + } else { + return 1; + } +} + # ---------------------------------------------------------- Append Environment sub appenv { @@ -381,8 +394,11 @@ sub appenv { $env{$key}=$newenv{$key}; } } - if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), - 0640)) { + open(my $env_file,$env{'user.environment'}); + if (&timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { while (my ($key,$value) = each(%newenv)) { $disk_env{$key} = $value; } @@ -399,8 +415,11 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), - 0640)) { + open(my $env_file,$env{'user.environment'}); + if (&timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { if ($key=~/^$delthis/) { delete($env{$key}); @@ -589,9 +608,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); @@ -621,7 +646,8 @@ sub homeserver { exists($badServerCache{$tryserver})); if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); - if ($answer eq 'found') { + if ($answer eq 'found') { + delete($badServerCache{$tryserver}); return $homecache{$index}=$tryserver; } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; @@ -1425,15 +1451,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; @@ -1999,7 +2027,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= @@ -2009,11 +2037,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; } @@ -5082,9 +5134,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; } @@ -7035,13 +7085,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'}; @@ -7052,7 +7103,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'}; @@ -7062,15 +7114,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+ @@ -7202,13 +7262,7 @@ sub repcopy_userfile { if (-e $transferfile) { return 'ok'; } my $request; $uri=~s/^\///; - if (&homeserver($cnum,$cdom) eq $perlvar{'lonHostID'}) { -# if this is my own server, get it via tokenwrapper - $request=new HTTP::Request('GET',&tokenwrapper('/'.$uri)); - } else { -# get it from another server, raw request - $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()) { @@ -7925,6 +7979,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