--- loncom/lonnet/perl/lonnet.pm 2007/01/03 02:00:38 1.821
+++ loncom/lonnet/perl/lonnet.pm 2007/03/02 23:43:24 1.839
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.821 2007/01/03 02:00:38 raeburn Exp $
+# $Id: lonnet.pm,v 1.839 2007/03/02 23:43:24 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -35,7 +35,7 @@ use HTTP::Headers;
use HTTP::Date;
# use Date::Parse;
use vars
-qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
+qw(%perlvar %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
@@ -149,7 +149,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 +189,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("<font color=\"blue\">WARNING:".
@@ -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(
- "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
- } else {
+ } else {
&logthis(
"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");
}
} else {
- &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
+ &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}
}
@@ -231,7 +224,7 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
- unless ($hostname{$server}) {
+ unless (&hostname($server)) {
&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");
return 'no_such_host';
@@ -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});
@@ -498,7 +517,7 @@ sub spareserver {
}
if (!$want_server_name) {
- $spare_server="http://$hostname{$spare_server}";
+ $spare_server="http://".&hostname($spare_server);
}
return $spare_server;
}
@@ -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;
@@ -740,6 +766,30 @@ sub put_dom {
}
}
+sub retrieve_inst_usertypes {
+ my ($udom) = @_;
+ my (%returnhash,@order);
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ 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 {
@@ -1176,6 +1226,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/) {
@@ -1424,15 +1475,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;
@@ -1701,15 +1754,10 @@ sub removeuserfile {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
- my ($group,$file);
- if ($fname =~ /^groups\/(\w+)\/portfolio(\/.+)$/) {
- $group = $1;
- $file = $2;
- } elsif ($fname =~ /^portfolio(\/.+)$/) {
- $file = $1;
- }
+ my $url = "/uploaded/$docudom/$docuname/$fname";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
my $sqlresult =
- &update_portfolio_table($docuname,$docudom,$group.$file,
+ &update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,
'delete');
}
@@ -1734,15 +1782,10 @@ sub renameuserfile {
my $newmeta = $new.'.meta';
my $metaresult =
&renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
- my ($group,$file);
- if ($old =~ /^groups\/(\w+)\/portfolio(\/.+)$/) {
- $group = $1;
- $file = $2;
- } elsif ($old =~ /^portfolio(\/.+)$/) {
- $file = $1;
- }
+ my $url = "/uploaded/$docudom/$docuname/$old";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
my $sqlresult =
- &update_portfolio_table($docuname,$docudom,$group.$file,
+ &update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,
'delete');
}
@@ -2008,7 +2051,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=
@@ -2018,11 +2061,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;
}
@@ -2228,7 +2295,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)));
@@ -2897,7 +2964,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 '')) {
@@ -3070,7 +3137,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
@@ -3104,7 +3187,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=();
@@ -3129,6 +3212,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}) &&
@@ -3541,12 +3626,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_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
+ } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
$type = 2;
$udom = $1;
$unum = $2;
@@ -4110,7 +4195,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);
@@ -4142,7 +4227,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}}).'%%';
@@ -4333,7 +4418,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})) {
@@ -5073,9 +5158,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;
}
@@ -5308,6 +5391,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 {
@@ -6979,13 +7109,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'};
@@ -6996,7 +7127,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'};
@@ -7006,15 +7138,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+
@@ -7103,60 +7243,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') {
- 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/^\///;
+ $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';
}
@@ -7170,7 +7309,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 {
@@ -7178,10 +7317,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);
@@ -7271,8 +7414,9 @@ 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) {
@@ -7283,8 +7427,9 @@ sub current_machine_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) {
@@ -7294,6 +7439,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 {
@@ -7439,6 +7607,7 @@ BEGIN {
# ------------------------------------------------------------- Read hosts file
{
+ my %hostname;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
while (my $configline=<$config>) {
@@ -7455,18 +7624,36 @@ BEGIN {
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();
+
+ sub hostname {
+ my ($lonid) = @_;
+ return $hostname{$lonid};
+ }
+ sub all_hostnames {
+ return %hostname;
+ }
+}
+
+sub get_hosts_from_ip {
+ my ($ip) = @_;
+ my %iphosts = &get_iphost();
+ if (ref($iphosts{$ip})) {
+ return @{$iphosts{$ip}};
+ }
+ 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\n");
+ &logthis("Skipping host $id name $name no IP found");
next;
}
$ip=inet_ntoa($ip);
@@ -7837,6 +8024,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