--- loncom/lonnet/perl/lonnet.pm 2006/11/27 20:35:10 1.808 +++ loncom/lonnet/perl/lonnet.pm 2007/01/18 21:02:06 1.828 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.808 2006/11/27 20:35:10 albertel Exp $ +# $Id: lonnet.pm,v 1.828 2007/01/18 21:02:06 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -53,7 +53,6 @@ use Time::HiRes qw( gettimeofday tv_inte use Cache::Memcached; use Digest::MD5; use Math::Random; -use lib '/home/httpd/lib/perl'; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; @@ -878,6 +877,25 @@ sub devalidate_getsection_cache { &devalidate_cache_new('getsection',$hashid); } +sub courseid_to_courseurl { + my ($courseid) = @_; + #already url style courseid + return $courseid if ($courseid =~ m{^/}); + + if (exists($env{'course.'.$courseid.'.num'})) { + my $cnum = $env{'course.'.$courseid.'.num'}; + my $cdom = $env{'course.'.$courseid.'.domain'}; + return "/$cdom/$cnum"; + } + + my %courseinfo=&Apache::lonnet::coursedescription($courseid); + if (exists($courseinfo{'num'})) { + return "/$courseinfo{'domain'}/$courseinfo{'num'}"; + } + + return undef; +} + sub getsection { my ($udom,$unam,$courseid)=@_; my $cachetime=1800; @@ -901,14 +919,13 @@ sub getsection { # If there is more than one expired role, choose the one which ended last. # If there is a role which has expired, return it. # - foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$line,2); - $key=&unescape($key); + $courseid = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$unam,$courseid); + foreach my $key (keys(%roleshash)) { next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; if ($key eq $courseid.'_st') { $section=''; } - my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key})); my $now=time; if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; @@ -1159,6 +1176,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/) { @@ -1684,6 +1702,12 @@ sub removeuserfile { if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { my $metafile = $fname.'.meta'; my $metaresult = &removeuserfile($docuname,$docudom,$metafile); + my $url = "/uploaded/$docudom/$docuname/$fname"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my $sqlresult = + &update_portfolio_table($docuname,$docudom,$file, + 'portfolio_metadata',$group, + 'delete'); } } return $result; @@ -1706,6 +1730,12 @@ sub renameuserfile { my $newmeta = $new.'.meta'; my $metaresult = &renameuserfile($docuname,$docudom,$oldmeta,$newmeta); + my $url = "/uploaded/$docudom/$docuname/$old"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my $sqlresult = + &update_portfolio_table($docuname,$docudom,$file, + 'portfolio_metadata',$group, + 'delete'); } } return $result; @@ -1772,7 +1802,7 @@ sub flushcourselogs { if ($entry =~ /___count$/) { my ($dom,$name); ($dom,$name,undef)= - ($entry=~m{___($match_domain)/($match_username)/(.*)___count$}); + ($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { my $cid = $env{'request.course.id'}; @@ -1793,7 +1823,7 @@ sub flushcourselogs { } } } else { - my ($dom,$name) = ($entry=~m{___($match_domain)/($match_username)/(.*)___(\w+)$}); + my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); my %temphash=($entry => $accesshash{$entry}); if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { delete $accesshash{$entry}; @@ -2732,6 +2762,7 @@ sub coursedescription { if (!$args->{'one_time'}) { $envhash{'course.'.$normalid.'.last_cache'}=time; } + if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { @@ -2887,7 +2918,7 @@ sub group_roleprivs { if (($tend!=0) && ($tend<$now)) { $access = 0; } if (($tstart!=0) && ($tstart>$now)) { $access=0; } if ($access) { - my ($course,$group) = ($area =~ m|(/$match_domain/$match_username)/([^/]+)$|); + my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|); $$allgroups{$course}{$group} .=':'.$group_privs; } } @@ -2918,7 +2949,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_username)(/?\w*)-) { + if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) { $trole = $1; $area = $2; $sec = $3; @@ -3030,7 +3061,23 @@ sub dump { sub dumpstore { my ($namespace,$udomain,$uname,$regexp,$range)=@_; - return &dump($namespace,$udomain,$uname,$regexp,$range); + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + return %returnhash; } # -------------------------------------------------------------- keys interface @@ -3043,6 +3090,7 @@ sub getkeys { my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); my @keyarray=(); foreach my $key (split(/\&/,$rep)) { + next if ($key =~ /^error: 2 /); push(@keyarray,&unescape($key)); } return @keyarray; @@ -3063,7 +3111,7 @@ sub currentdump { if ($rep eq "unknown_cmd") { # an old lond will not know currentdump # Do a dump and make it look like a currentdump - my @tmp = &dump($courseid,$sdom,$sname,'.'); + my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); return if ($tmp[0] =~ /^(error:|no_such_host)/); my %hash = @tmp; @tmp=(); @@ -3088,6 +3136,8 @@ sub convert_dump_to_currentdump{ # we might run in to problems with parameter names =~ /^v\./ while (my ($key,$value) = each(%hash)) { my ($v,$symb,$param) = split(/:/,$key); + $symb = &unescape($symb); + $param = &unescape($param); next if ($v eq 'version' || $symb eq 'keys'); next if (exists($returnhash{$symb}) && exists($returnhash{$symb}->{$param}) && @@ -3301,6 +3351,22 @@ sub portfolio_access { my ($requrl) = @_; my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); my $result = &get_portfolio_access($udom,$unum,$file_name,$group); + if ($result) { + my %setters; + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); + if ($startblock && $endblock) { + return 'B'; + } + } else { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } + } + } if ($result eq 'ok') { return 'F'; } elsif ($result =~ /^[^:]+:guest_/) { @@ -3376,7 +3442,7 @@ sub get_portfolio_access { my (%allgroups,%allroles); my ($start,$end,$role,$sec,$group); foreach my $envkey (%env) { - if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_username)/?([^/]*)$-) { + if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { my $cid = $2.'_'.$3; if ($1 eq 'gr') { $group = $4; @@ -3389,7 +3455,7 @@ sub get_portfolio_access { } $allroles{$cid}{$1}{$sec} = $env{$envkey}; } - } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_username)/?([^/]*)$-) { + } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) { my $cid = $2.'_'.$3; if ($4 eq '') { $sec = 'none'; @@ -3484,12 +3550,12 @@ sub parse_portfolio_url { my ($type,$udom,$unum,$group,$file_name); - if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) { + if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) { $type = 1; $udom = $1; $unum = $2; $file_name = $3; - } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_username)/groups/([^/]+)/portfolio/(.+)$-) { + } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) { $type = 2; $udom = $1; $unum = $2; @@ -3509,7 +3575,7 @@ sub is_portfolio_url { sub is_portfolio_file { my ($file) = @_; - if (($file =~ /^portfolio/) || ($file =~ /^groups\/$match_username\/portfolio/)) { + if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { return 1; } return; @@ -3521,7 +3587,7 @@ sub is_portfolio_file { sub customaccess { my ($priv,$uri)=@_; my ($urole,$urealm)=split(/\./,$env{'request.role'},2); - my ($udom,$ucrs,$usec)=split(/\//,$urealm); + my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm); $udom = &LONCAPA::clean_domain($udom); $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; @@ -3554,12 +3620,21 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb)=@_; + my ($priv,$uri,$symb,$role)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); - + + if ($priv eq 'evb') { +# Evade communication block restrictions for specified role in a course + if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) { + return $1; + } else { + return; + } + } + if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) @@ -3572,7 +3647,14 @@ sub allowed { my ($space,$domain,$name,@dir)=split('/',$uri); if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { - return 'F'; + my %setters; + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } else { + return 'F'; + } } # bre access to group portfolio for rgf priv in group, or mdg or vcg in course. @@ -3848,6 +3930,8 @@ sub allowed { unless ($env{'request.course.id'}) { if ($thisallowed eq 'A') { return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; } else { return '1'; } @@ -3915,6 +3999,8 @@ sub allowed { if ($thisallowed eq 'A') { return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; } return 'F'; } @@ -4041,6 +4127,18 @@ sub log_query { return get_query_reply($queryid); } +# -------------------------- Update MySQL table for portfolio file + +sub update_portfolio_table { + my ($uname,$udom,$file_name,$query,$group,$action) = @_; + my $homeserver = &homeserver($uname,$udom); + my $queryid= + &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). + ':'.&escape($file_name).':'.$action,$homeserver); + my $reply = &get_query_reply($queryid); + return $reply; +} + # ------- Request retrieval of institutional classlists for course(s) sub fetch_enrollment_query { @@ -4365,13 +4463,8 @@ sub auto_validate_class_sec { # ------------------------------------------------------- Course Group routines sub get_coursegroups { - my ($cdom,$cnum,$group) = @_; - return(&dump('coursegroups',$cdom,$cnum,$group)); -} - -sub get_deleted_groups { - my ($cdom,$cnum,$group) = @_; - return(&dump('deleted_groups',$cdom,$cnum,$group)); + my ($cdom,$cnum,$group,$namespace) = @_; + return(&dump($namespace,$cdom,$cnum,$group)); } sub modify_coursegroup { @@ -4379,18 +4472,26 @@ sub modify_coursegroup { return(&put('coursegroups',$groupsettings,$cdom,$cnum)); } -sub delete_coursegroup { - my ($cdom,$cnum,$group) = @_; - my %curr_group = &get_coursegroups($cdom,$cnum,$group); +sub toggle_coursegroup_status { + my ($cdom,$cnum,$group,$action) = @_; + my ($from_namespace,$to_namespace); + if ($action eq 'delete') { + $from_namespace = 'coursegroups'; + $to_namespace = 'deleted_groups'; + } else { + $from_namespace = 'deleted_groups'; + $to_namespace = 'coursegroups'; + } + my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace); if (my $tmp = &error(%curr_group)) { &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom); return ('read error',$tmp); } else { my %savedsettings = %curr_group; - my $result = &put('deleted_groups',\%savedsettings,$cdom,$cnum); + my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum); my $deloutcome; if ($result eq 'ok') { - $deloutcome = &del('coursegroups',[$group],$cdom,$cnum); + $deloutcome = &del($from_namespace,[$group],$cdom,$cnum); } else { return ('write error',$result); } @@ -4425,7 +4526,7 @@ sub get_active_groups { my $now = time; my %groups = (); foreach my $key (keys(%env)) { - if ($key =~ m-user\.role\.gr\./($match_domain)/($match_username)/(\w+)$-) { + if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) { my ($start,$end) = split(/\./,$env{$key}); if (($end!=0) && ($end<$now)) { next; } if (($start!=0) && ($start>$now)) { next; } @@ -4453,38 +4554,34 @@ sub get_users_groups { @usersgroups = split(/:/,$grouplist); } else { $grouplist = ''; - my %roleshash = &dump('roles',$udom,$uname,$courseid); - my ($tmp) = keys(%roleshash); - if ($tmp=~/^error:/) { - &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); - } else { - my $access_end = $env{'course.'.$courseid. - '.default_enrollment_end_date'}; - my $now = time; - foreach my $key (keys(%roleshash)) { - if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { - my $group = $1; - if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { - my $start = $2; - my $end = $1; - if ($start == -1) { next; } # deleted from group - if (($start!=0) && ($start>$now)) { next; } - if (($end!=0) && ($end<$now)) { - if ($access_end && $access_end < $now) { - if ($access_end - $end < 86400) { - push(@usersgroups,$group); - } + my $courseurl = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$uname,$courseurl); + my $access_end = $env{'course.'.$courseid. + '.default_enrollment_end_date'}; + my $now = time; + foreach my $key (keys(%roleshash)) { + if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) { + my $group = $1; + if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { + my $start = $2; + my $end = $1; + if ($start == -1) { next; } # deleted from group + if (($start!=0) && ($start>$now)) { next; } + if (($end!=0) && ($end<$now)) { + if ($access_end && $access_end < $now) { + if ($access_end - $end < 86400) { + push(@usersgroups,$group); } - next; } - push(@usersgroups,$group); + next; } + push(@usersgroups,$group); } } - @usersgroups = &sort_course_groups($courseid,@usersgroups); - $grouplist = join(':',@usersgroups); - &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); } + @usersgroups = &sort_course_groups($courseid,@usersgroups); + $grouplist = join(':',@usersgroups); + &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); } return @usersgroups; } @@ -4531,7 +4628,7 @@ sub assignrole { my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; - $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4541,8 +4638,7 @@ sub assignrole { $mrole='cr'; } elsif ($role =~ /^gr\//) { my $cwogrp=$url; - $cwogrp=~s{^/($match_domain)/($match_username)/.*} - {$1/$2}x; + $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; unless (&allowed('mdg',$cwogrp)) { &logthis('Refused group assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4552,7 +4648,7 @@ sub assignrole { $mrole='gr'; } else { my $cwosec=$url; - $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4918,6 +5014,16 @@ ENDINITMAP return '/'.$udom.'/'.$uname; } +sub is_course { + my ($cdom,$cnum) = @_; + my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, + undef,'.'); + if (exists($courses{$cdom.'_'.$cnum})) { + return 1; + } + return 0; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { @@ -5196,12 +5302,68 @@ sub modify_access_controls { # remove lock my @del_lock = ($file_name."\0".'locked_access_records'); my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + my ($file,$group); + if (&is_course($domain,$user)) { + ($group,$file) = split(/\//,$file_name,2); + } else { + $file = $file_name; + } + my $sqlresult = + &update_portfolio_table($user,$domain,$file,'portfolio_access', + $group); } else { $outcome = "error: could not obtain lockfile\n"; } 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 { @@ -5431,7 +5593,7 @@ sub stat_file { my ($udom,$uname,$file,$dir); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = - ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_username)/?(.*)-); + ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; $dir = &propath($udom,$uname); } @@ -6996,61 +7158,66 @@ sub repcopy_userfile { if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = - ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_username)/+(.*)|); - my ($info,$rtncode); + ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); 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') { - my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($uri)); - my $response=$ua->request($request); - if ($response->is_success()) { - $info=$response->content; - } else { - 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/^\///; + 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); + } + 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'; } @@ -7072,6 +7239,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/^\///; @@ -7118,7 +7289,7 @@ sub filelocation { $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= - ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_username)/+(.*)$-); + ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); my $home=&homeserver($uname,$udom); my $is_me=0; my @ids=¤t_machine_ids(); @@ -7158,7 +7329,7 @@ sub hreflocation { } elsif ($file=~m-/home/($match_username)/public_html/-) { $file=~s-^/home/($match_username)/public_html/-/~$1/-; } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { - $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_username)/userfiles/ + $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ -/uploaded/$1/$2/-x; } return $file; @@ -7188,6 +7359,29 @@ sub current_machine_ids { return @ids; } +sub additional_machine_domains { + my @domains; + open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); + while( my $line = <$fh>) { + $line =~ s/\s//g; + push(@domains,$line); + } + return @domains; +} + +sub default_login_domain { + my $domain = $perlvar{'lonDefDomain'}; + my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0]; + foreach my $posdom (¤t_machine_domains(), + &additional_machine_domains()) { + if (lc($posdom) eq lc($testdomain)) { + $domain=$posdom; + last; + } + } + return $domain; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -7360,7 +7554,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); @@ -7712,8 +7906,7 @@ passed in @what from the requested user' =item * -allowed($priv,$uri) : check for a user privilege; returns codes for allowed -actions +allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions F: full access U,I,K: authentication modes (cxx only) '': forbidden