--- loncom/lonnet/perl/lonnet.pm 2007/05/02 22:01:32 1.824.2.5 +++ loncom/lonnet/perl/lonnet.pm 2007/02/23 00:23:46 1.835 @@ -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.835 2007/02/23 00:23:46 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -990,19 +990,10 @@ my %remembered; my %accessed; 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); - } - 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}); @@ -1010,7 +1001,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()]; @@ -1033,7 +1024,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__'; @@ -1042,9 +1033,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 +1202,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 +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; @@ -2035,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= @@ -2045,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; } @@ -3466,16 +3482,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; @@ -5125,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; } @@ -5360,6 +5367,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 { @@ -7031,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'}; @@ -7048,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'}; @@ -7058,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+ @@ -7155,53 +7219,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'; } @@ -7223,6 +7293,10 @@ 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/^\///; @@ -7534,7 +7608,7 @@ sub get_iphost { 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"); + &logthis("Skipping host $id name $name no IP found"); next; } $ip=inet_ntoa($ip); @@ -7905,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