|
version 1.832, 2007/02/16 01:04:19
|
version 1.863, 2007/04/04 00:10:15
|
|
Line 35 use HTTP::Headers;
|
Line 35 use HTTP::Headers;
|
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
qw(%perlvar %badServerCache %spareid |
| %libserv %pr %prp $memcache %packagetab |
%pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
%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); |
$tmpdir $_64bit %env); |
| |
|
| use IO::Socket; |
use IO::Socket; |
|
Line 146 sub logperm {
|
Line 144 sub logperm {
|
| return 1; |
return 1; |
| } |
} |
| |
|
| |
sub create_connection { |
| |
my ($hostname,$lonid) = @_; |
| |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
return 0 if (!$client); |
| |
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); |
| |
my $result = <$client>; |
| |
chomp($result); |
| |
return 1 if ($result eq 'done'); |
| |
return 0; |
| |
} |
| |
|
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
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 |
# 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 |
# process exit and the master server picking up the listen on the AF_UNIX |
|
Line 172 sub subreply {
|
Line 184 sub subreply {
|
| Timeout => 10); |
Timeout => 10); |
| if($client) { |
if($client) { |
| last; # Connected! |
last; # Connected! |
| |
} else { |
| |
&create_connection(&hostname($server),$server); |
| } |
} |
| sleep(1); # Try again later if failed connection. |
sleep(1); # Try again later if failed connection. |
| } |
} |
| my $answer; |
my $answer; |
| if ($client) { |
if ($client) { |
|
Line 189 sub subreply {
|
Line 203 sub subreply {
|
| |
|
| sub reply { |
sub reply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined(&hostname($server))) { return 'no_such_host'; } |
| my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
| if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
| &logthis("<font color=\"blue\">WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
|
Line 201 sub reply {
|
Line 215 sub reply {
|
| # ----------------------------------------------------------- Send USR1 to lonc |
# ----------------------------------------------------------- Send USR1 to lonc |
| |
|
| sub reconlonc { |
sub reconlonc { |
| my $peerfile=shift; |
&logthis("Trying to reconnect lonc"); |
| &logthis("Trying to reconnect for $peerfile"); |
|
| my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
| if (open(my $fh,"<$loncfile")) { |
if (open(my $fh,"<$loncfile")) { |
| my $loncpid=<$fh>; |
my $loncpid=<$fh>; |
|
Line 211 sub reconlonc {
|
Line 224 sub reconlonc {
|
| &logthis("lonc at pid $loncpid responding, sending USR1"); |
&logthis("lonc at pid $loncpid responding, sending USR1"); |
| kill USR1 => $loncpid; |
kill USR1 => $loncpid; |
| sleep 1; |
sleep 1; |
| if (-e "$peerfile") { return; } |
} else { |
| &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 { |
|
| &logthis( |
&logthis( |
| "<font color=\"blue\">WARNING:". |
"<font color=\"blue\">WARNING:". |
| " lonc at pid $loncpid not responding, giving up</font>"); |
" lonc at pid $loncpid not responding, giving up</font>"); |
| } |
} |
| } else { |
} else { |
| &logthis('<font color="blue">WARNING: lonc not running, giving up</font>'); |
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>'); |
| } |
} |
| } |
} |
| |
|
|
Line 231 sub reconlonc {
|
Line 238 sub reconlonc {
|
| |
|
| sub critical { |
sub critical { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| unless ($hostname{$server}) { |
unless (&hostname($server)) { |
| &logthis("<font color=\"blue\">WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
| " Critical message to unknown server ($server)</font>"); |
" Critical message to unknown server ($server)</font>"); |
| return 'no_such_host'; |
return 'no_such_host'; |
|
Line 524 sub spareserver {
|
Line 531 sub spareserver {
|
| } |
} |
| |
|
| if (!$want_server_name) { |
if (!$want_server_name) { |
| $spare_server="http://$hostname{$spare_server}"; |
$spare_server="http://".&hostname($spare_server); |
| } |
} |
| return $spare_server; |
return $spare_server; |
| } |
} |
|
Line 615 sub authenticate {
|
Line 622 sub authenticate {
|
| my ($uname,$upass,$udom)=@_; |
my ($uname,$upass,$udom)=@_; |
| $upass=&escape($upass); |
$upass=&escape($upass); |
| $uname= &LONCAPA::clean_username($uname); |
$uname= &LONCAPA::clean_username($uname); |
| my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom,1); |
| if (!$uhome) { |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| &logthis("User $uname at $udom is unknown in authenticate"); |
# 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'; |
return 'no_host'; |
| } |
} |
| my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); |
|
Line 641 sub homeserver {
|
Line 654 sub homeserver {
|
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| |
|
| if (exists($homecache{$index})) { return $homecache{$index}; } |
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' && |
next if ($ignoreBadCache ne 'true' && |
| exists($badServerCache{$tryserver})); |
exists($badServerCache{$tryserver})); |
| if ($hostdom{$tryserver} eq $udom) { |
|
| my $answer=reply("home:$udom:$uname",$tryserver); |
my $answer=reply("home:$udom:$uname",$tryserver); |
| if ($answer eq 'found') { |
if ($answer eq 'found') { |
| return $homecache{$index}=$tryserver; |
delete($badServerCache{$tryserver}); |
| } elsif ($answer eq 'no_host') { |
return $homecache{$index}=$tryserver; |
| $badServerCache{$tryserver}=1; |
} elsif ($answer eq 'no_host') { |
| } |
$badServerCache{$tryserver}=1; |
| } |
} |
| } |
} |
| return 'no_host'; |
return 'no_host'; |
| } |
} |
|
Line 663 sub idget {
|
Line 677 sub idget {
|
| my ($udom,@ids)=@_; |
my ($udom,@ids)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| |
|
| my $tryserver; |
my %servers = &get_servers($udom,'library'); |
| foreach $tryserver (keys %libserv) { |
foreach my $tryserver (keys(%servers)) { |
| if ($hostdom{$tryserver} eq $udom) { |
my $idlist=join('&',@ids); |
| my $idlist=join('&',@ids); |
$idlist=~tr/A-Z/a-z/; |
| $idlist=~tr/A-Z/a-z/; |
my $reply=&reply("idget:$udom:".$idlist,$tryserver); |
| my $reply=&reply("idget:$udom:".$idlist,$tryserver); |
my @answer=(); |
| my @answer=(); |
if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { |
| if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { |
@answer=split(/\&/,$reply); |
| @answer=split(/\&/,$reply); |
} ; |
| } ; |
my $i; |
| my $i; |
for ($i=0;$i<=$#ids;$i++) { |
| for ($i=0;$i<=$#ids;$i++) { |
if ($answer[$i]) { |
| if ($answer[$i]) { |
$returnhash{$ids[$i]}=$answer[$i]; |
| $returnhash{$ids[$i]}=$answer[$i]; |
} |
| } |
} |
| } |
} |
| } |
|
| } |
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
|
Line 722 sub idput {
|
Line 734 sub idput {
|
| # ------------------------------------------- get items from domain db files |
# ------------------------------------------- get items from domain db files |
| |
|
| sub get_dom { |
sub get_dom { |
| my ($namespace,$storearr,$udom)=@_; |
my ($namespace,$storearr,$udom,$uhome)=@_; |
| my $items=''; |
my $items=''; |
| foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
| $items.=&escape($item).'&'; |
$items.=&escape($item).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| if (!$udom) { $udom=$env{'user.domain'}; } |
if (!$udom) { |
| if (exists($domain_primary{$udom})) { |
$udom=$env{'user.domain'}; |
| my $uhome=$domain_primary{$udom}; |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} else { |
| |
$uhome eq ''; |
| |
} |
| |
} else { |
| |
if (!$uhome) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} |
| |
} |
| |
} |
| |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
|
Line 744 sub get_dom {
|
Line 768 sub get_dom {
|
| } |
} |
| return %returnhash; |
return %returnhash; |
| } else { |
} else { |
| &logthis("get_dom failed - no primary domain server for $udom"); |
&logthis("get_dom failed - no homeserver and/or domain"); |
| } |
} |
| } |
} |
| |
|
| # -------------------------------------------- put items in domain db files |
# -------------------------------------------- put items in domain db files |
| |
|
| sub put_dom { |
sub put_dom { |
| my ($namespace,$storehash,$udom)=@_; |
my ($namespace,$storehash,$udom,$uhome)=@_; |
| if (!$udom) { $udom=$env{'user.domain'}; } |
if (!$udom) { |
| if (exists($domain_primary{$udom})) { |
$udom=$env{'user.domain'}; |
| my $uhome=$domain_primary{$udom}; |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} else { |
| |
$uhome eq ''; |
| |
} |
| |
} else { |
| |
if (!$uhome) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} |
| |
} |
| |
} |
| |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $items=''; |
my $items=''; |
| foreach my $item (keys(%$storehash)) { |
foreach my $item (keys(%$storehash)) { |
| $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
|
Line 762 sub put_dom {
|
Line 798 sub put_dom {
|
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &reply("putdom:$udom:$namespace:$items",$uhome); |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
| } else { |
} else { |
| &logthis("put_dom failed - no primary domain server for $udom"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
| |
} |
| |
} |
| |
|
| |
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 |
# --------------------------------------------------- Assign a key to a student |
|
Line 990 my %remembered;
|
Line 1050 my %remembered;
|
| my %accessed; |
my %accessed; |
| my $kicks=0; |
my $kicks=0; |
| my $hits=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 { |
sub devalidate_cache_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| $memcache->delete($id); |
$memcache->delete($id); |
| delete($remembered{$id}); |
delete($remembered{$id}); |
| delete($accessed{$id}); |
delete($accessed{$id}); |
|
Line 1001 sub devalidate_cache_new {
|
Line 1067 sub devalidate_cache_new {
|
| |
|
| sub is_cached_new { |
sub is_cached_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| if (exists($remembered{$id})) { |
if (exists($remembered{$id})) { |
| if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$id}=[&gettimeofday()]; |
|
Line 1024 sub is_cached_new {
|
Line 1090 sub is_cached_new {
|
| |
|
| sub do_cache_new { |
sub do_cache_new { |
| my ($name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| my $setvalue=$value; |
my $setvalue=$value; |
| if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
| $setvalue='__undef__'; |
$setvalue='__undef__'; |
|
Line 1474 sub clean_filename {
|
Line 1540 sub clean_filename {
|
| # $coursedoc - if true up to the current course |
# $coursedoc - if true up to the current course |
| # if false |
# if false |
| # $subdir - directory in userfile to store the file into |
# $subdir - directory in userfile to store the file into |
| # $parser, $allfiles, $codebase - unknown |
# $parser - instruction to parse file for objects ($parser = parse) |
| # |
# $allfiles - reference to hash for embedded objects |
| |
# $codebase - reference to hash for codebase of java objects |
| |
# $desuname - username for permanent storage of uploaded file |
| |
# $dsetudom - domain for permanaent storage of uploaded file |
| |
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
| |
# $thumbheight - height (pixels) of thumbnail to make for uploaded image |
| |
# |
| # output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
| # or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
| |
|
| |
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
| |
$destudom,$thumbwidth,$thumbheight)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
| my $fname=$env{'form.'.$formname.'.filename'}; |
my $fname=$env{'form.'.$formname.'.filename'}; |
| $fname=&clean_filename($fname); |
$fname=&clean_filename($fname); |
|
Line 1528 sub userfileupload {
|
Line 1601 sub userfileupload {
|
| if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
| return &finishuserfileupload($docuname,$docudom, |
return &finishuserfileupload($docuname,$docudom, |
| $formname,$fname,$parser,$allfiles, |
$formname,$fname,$parser,$allfiles, |
| $codebase); |
$codebase,$thumbwidth,$thumbheight); |
| } else { |
} else { |
| $fname=$env{'form.folder'}.'/'.$fname; |
$fname=$env{'form.folder'}.'/'.$fname; |
| return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
|
Line 1538 sub userfileupload {
|
Line 1611 sub userfileupload {
|
| } elsif (defined($destuname)) { |
} elsif (defined($destuname)) { |
| my $docuname=$destuname; |
my $docuname=$destuname; |
| my $docudom=$destudom; |
my $docudom=$destudom; |
| return &finishuserfileupload($docuname,$docudom,$formname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $fname,$parser,$allfiles,$codebase); |
$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight); |
| |
|
| } else { |
} else { |
| my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
|
Line 1548 sub userfileupload {
|
Line 1622 sub userfileupload {
|
| $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| } |
} |
| return &finishuserfileupload($docuname,$docudom,$formname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $fname,$parser,$allfiles,$codebase); |
$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight); |
| } |
} |
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight) = @_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| my ($fnamepath,$file); |
my ($fnamepath,$file,$fetchthumb); |
| $file=$fname; |
$file=$fname; |
| if ($fname=~m|/|) { |
if ($fname=~m|/|) { |
| ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
|
Line 1593 sub finishuserfileupload {
|
Line 1669 sub finishuserfileupload {
|
| ' for embedded media: '.$parse_result); |
' for embedded media: '.$parse_result); |
| } |
} |
| } |
} |
| |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
| |
my $input = $filepath.'/'.$file; |
| |
my $output = $filepath.'/'.'tn-'.$file; |
| |
my $thumbsize = $thumbwidth.'x'.$thumbheight; |
| |
system("convert -sample $thumbsize $input $output"); |
| |
if (-e $filepath.'/'.'tn-'.$file) { |
| |
$fetchthumb = 1; |
| |
} |
| |
} |
| |
|
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| my $docuhome=&homeserver($docuname,$docudom); |
my $docuhome=&homeserver($docuname,$docudom); |
| my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| |
if ($fetchthumb) { |
| |
my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); |
| |
if ($thumbresult ne 'ok') { |
| |
&logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. |
| |
$docuhome.': '.$thumbresult); |
| |
} |
| |
} |
| # |
# |
| # Return the URL to it |
# Return the URL to it |
| return '/uploaded/'.$path.$file; |
return '/uploaded/'.$path.$file; |
|
Line 1605 sub finishuserfileupload {
|
Line 1698 sub finishuserfileupload {
|
| &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
| ': '.$fetchresult); |
': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
|
Line 1819 sub flushcourselogs {
|
Line 1912 sub flushcourselogs {
|
| # Write course id database (reverse lookup) to homeserver of courses |
# Write course id database (reverse lookup) to homeserver of courses |
| # Is used in pickcourse |
# Is used in pickcourse |
| # |
# |
| foreach my $crsid (keys(%courseidbuffer)) { |
foreach my $crs_home (keys(%courseidbuffer)) { |
| &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid); |
&courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home}, |
| |
$crs_home); |
| } |
} |
| # |
# |
| # File accesses |
# File accesses |
|
Line 1887 sub flushcourselogs {
|
Line 1981 sub flushcourselogs {
|
| delete $domainrolehash{$entry}; |
delete $domainrolehash{$entry}; |
| } |
} |
| foreach my $dom (keys(%domrolebuffer)) { |
foreach my $dom (keys(%domrolebuffer)) { |
| foreach my $tryserver (keys %libserv) { |
my %servers = &get_servers($dom,'library'); |
| if ($hostdom{$tryserver} eq $dom) { |
foreach my $tryserver (keys(%servers)) { |
| unless (&reply('domroleput:'.$dom.':'. |
unless (&reply('domroleput:'.$dom.':'. |
| $domrolebuffer{$dom},$tryserver) eq 'ok') { |
$domrolebuffer{$dom},$tryserver) eq 'ok') { |
| &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
| } |
} |
| } |
|
| } |
} |
| } |
} |
| $dumpcount++; |
$dumpcount++; |
|
Line 2027 sub get_course_adv_roles {
|
Line 2120 sub get_course_adv_roles {
|
| } |
} |
| |
|
| sub get_my_roles { |
sub get_my_roles { |
| my ($uname,$udom,$types,$roles,$roledoms)=@_; |
my ($uname,$udom,$context,$types,$roles,$roledoms)=@_; |
| unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
| unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
| my %dumphash= |
my %dumphash; |
| |
if ($context eq 'userroles') { |
| |
%dumphash = &dump('roles',$udom,$uname); |
| |
} else { |
| |
%dumphash= |
| &dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
| |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $now=time; |
my $now=time; |
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
|
Line 2075 sub get_my_roles {
|
Line 2173 sub get_my_roles {
|
| |
|
| sub postannounce { |
sub postannounce { |
| my ($server,$text)=@_; |
my ($server,$text)=@_; |
| unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } |
unless (&allowed('psa',&host_domain($server))) { return 'refused'; } |
| unless ($text=~/\w/) { $text=''; } |
unless ($text=~/\w/) { $text=''; } |
| return &reply('setannounce:'.&escape($text),$server); |
return &reply('setannounce:'.&escape($text),$server); |
| } |
} |
|
Line 2111 sub courseiddump {
|
Line 2209 sub courseiddump {
|
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
| foreach my $tryserver (keys %libserv) { |
my %libserv = &all_library(); |
| if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
foreach my $tryserver (keys(%libserv)) { |
| if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
if ( ( $hostidflag == 1 |
| |
&& grep(/^\Q$tryserver\E$/,@{$hostidref}) ) |
| |
|| (!defined($hostidflag)) ) { |
| |
|
| |
if ($domfilter eq '' |
| |
|| (&host_domain($tryserver) eq $domfilter)) { |
| foreach my $line ( |
foreach my $line ( |
| split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'. |
| $sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
| &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), |
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), |
| $tryserver))) { |
$tryserver))) { |
|
Line 2143 sub dcmailput {
|
Line 2246 sub dcmailput {
|
| sub dcmaildump { |
sub dcmaildump { |
| my ($dom,$startdate,$enddate,$senders) = @_; |
my ($dom,$startdate,$enddate,$senders) = @_; |
| my %returnhash=(); |
my %returnhash=(); |
| if (exists($domain_primary{$dom})) { |
|
| |
if (defined(&domain($dom,'primary'))) { |
| my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. |
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. |
| &escape($enddate).':'; |
&escape($enddate).':'; |
| my @esc_senders=map { &escape($_)} @$senders; |
my @esc_senders=map { &escape($_)} @$senders; |
| $cmd.=&escape(join('&',@esc_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); |
my ($key,$value) = split(/\=/,$line,2); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
| $returnhash{&unescape($key)} = &unescape($value); |
$returnhash{&unescape($key)} = &unescape($value); |
|
Line 2169 sub get_domain_roles {
|
Line 2273 sub get_domain_roles {
|
| } |
} |
| my $rolelist = join(':',@{$roles}); |
my $rolelist = join(':',@{$roles}); |
| my %personnel = (); |
my %personnel = (); |
| foreach my $tryserver (keys(%libserv)) { |
|
| if ($hostdom{$tryserver} eq $dom) { |
my %servers = &get_servers($dom,'library'); |
| %{$personnel{$tryserver}}=(); |
foreach my $tryserver (keys(%servers)) { |
| foreach my $line ( |
%{$personnel{$tryserver}}=(); |
| split(/\&/,&reply('domrolesdump:'.$dom.':'. |
foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'. |
| &escape($startdate).':'.&escape($enddate).':'. |
&escape($startdate).':'. |
| &escape($rolelist), $tryserver))) { |
&escape($enddate).':'. |
| my ($key,$value) = split(/\=/,$line,2); |
&escape($rolelist), $tryserver))) { |
| if (($key) && ($value)) { |
my ($key,$value) = split(/\=/,$line,2); |
| $personnel{$tryserver}{&unescape($key)} = &unescape($value); |
if (($key) && ($value)) { |
| } |
$personnel{$tryserver}{&unescape($key)} = &unescape($value); |
| } |
} |
| } |
} |
| } |
} |
| return %personnel; |
return %personnel; |
| } |
} |
|
Line 2271 sub checkin {
|
Line 2375 sub checkin {
|
| my $now=time; |
my $now=time; |
| my ($ta,$tb,$lonhost)=split(/\*/,$token); |
my ($ta,$tb,$lonhost)=split(/\*/,$token); |
| $lonhost=~tr/A-Z/a-z/; |
$lonhost=~tr/A-Z/a-z/; |
| my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; |
my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; |
| $dtoken=~s/\W/\_/g; |
$dtoken=~s/\W/\_/g; |
| my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
| split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
|
Line 2940 sub custom_roleprivs {
|
Line 3044 sub custom_roleprivs {
|
| my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; |
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; |
| my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
| my $homsvr=homeserver($rauthor,$rdomain); |
my $homsvr=homeserver($rauthor,$rdomain); |
| if ($hostname{$homsvr} ne '') { |
if (&hostname($homsvr) ne '') { |
| my ($rdummy,$roledef)= |
my ($rdummy,$roledef)= |
| &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
| if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
|
Line 4148 sub definerole {
|
Line 4252 sub definerole {
|
| sub metadata_query { |
sub metadata_query { |
| my ($query,$custom,$customshow,$server_array)=@_; |
my ($query,$custom,$customshow,$server_array)=@_; |
| my %rhash; |
my %rhash; |
| |
my %libserv = &all_library(); |
| my @server_list = (defined($server_array) ? @$server_array |
my @server_list = (defined($server_array) ? @$server_array |
| : keys(%libserv) ); |
: keys(%libserv) ); |
| for my $server (@server_list) { |
for my $server (@server_list) { |
|
Line 4171 sub log_query {
|
Line 4276 sub log_query {
|
| my ($uname,$udom,$query,%filters)=@_; |
my ($uname,$udom,$query,%filters)=@_; |
| my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
| if ($uhome eq 'no_host') { return 'error: no_host'; } |
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 $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); |
| my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
| $uhome); |
$uhome); |
|
Line 4203 sub fetch_enrollment_query {
|
Line 4308 sub fetch_enrollment_query {
|
| } else { |
} else { |
| $homeserver = &homeserver($cnum,$dom); |
$homeserver = &homeserver($cnum,$dom); |
| } |
} |
| my $host=$hostname{$homeserver}; |
my $host=&hostname($homeserver); |
| my $cmd = ''; |
my $cmd = ''; |
| foreach my $affiliate (keys %{$affiliatesref}) { |
foreach my $affiliate (keys %{$affiliatesref}) { |
| $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
|
Line 4300 sub courselog_query {
|
Line 4405 sub courselog_query {
|
| } |
} |
| |
|
| sub userlog_query { |
sub userlog_query { |
| |
# |
| |
# possible filters: |
| |
# action: log check role |
| |
# start: timestamp |
| |
# end: timestamp |
| |
# |
| my ($uname,$udom,%filters)=@_; |
my ($uname,$udom,%filters)=@_; |
| return &log_query($uname,$udom,'userlog',%filters); |
return &log_query($uname,$udom,'userlog',%filters); |
| } |
} |
|
Line 4394 sub auto_photochoice {
|
Line 4505 sub auto_photochoice {
|
| sub auto_photoupdate { |
sub auto_photoupdate { |
| my ($affiliatesref,$dom,$cnum,$photo) = @_; |
my ($affiliatesref,$dom,$cnum,$photo) = @_; |
| my $homeserver = &homeserver($cnum,$dom); |
my $homeserver = &homeserver($cnum,$dom); |
| my $host=$hostname{$homeserver}; |
my $host=&hostname($homeserver); |
| my $cmd = ''; |
my $cmd = ''; |
| my $maxtries = 1; |
my $maxtries = 1; |
| foreach my $affiliate (keys(%{$affiliatesref})) { |
foreach my $affiliate (keys(%{$affiliatesref})) { |
|
Line 4434 sub auto_instcode_format {
|
Line 4545 sub auto_instcode_format {
|
| my $courses = ''; |
my $courses = ''; |
| my @homeservers; |
my @homeservers; |
| if ($caller eq 'global') { |
if ($caller eq 'global') { |
| foreach my $tryserver (keys(%libserv)) { |
my %servers = &get_servers($codedom,'library'); |
| if ($hostdom{$tryserver} eq $codedom) { |
foreach my $tryserver (keys(%servers)) { |
| if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
| push(@homeservers,$tryserver); |
push(@homeservers,$tryserver); |
| } |
} |
| } |
|
| } |
} |
| } else { |
} else { |
| push(@homeservers,&homeserver($caller,$codedom)); |
push(@homeservers,&homeserver($caller,$codedom)); |
|
Line 4473 sub auto_instcode_format {
|
Line 4583 sub auto_instcode_format {
|
| sub auto_instcode_defaults { |
sub auto_instcode_defaults { |
| my ($domain,$returnhash,$code_order) = @_; |
my ($domain,$returnhash,$code_order) = @_; |
| my @homeservers; |
my @homeservers; |
| foreach my $tryserver (keys(%libserv)) { |
|
| if ($hostdom{$tryserver} eq $domain) { |
my %servers = &get_servers($domain,'library'); |
| if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
foreach my $tryserver (keys(%servers)) { |
| push(@homeservers,$tryserver); |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
| } |
push(@homeservers,$tryserver); |
| } |
} |
| } |
} |
| my $ok_response = 0; |
|
| my $response; |
my $response; |
| while (@homeservers > 0 && $ok_response == 0) { |
foreach my $server (@homeservers) { |
| my $server = shift(@homeservers); |
|
| $response=&reply('autoinstcodedefaults:'.$domain,$server); |
$response=&reply('autoinstcodedefaults:'.$domain,$server); |
| if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
next if ($response =~ /(con_lost|error|no_such_host|refused)/); |
| foreach my $pair (split(/\&/,$response)) { |
|
| my ($name,$value)=split(/\=/,$pair); |
foreach my $pair (split(/\&/,$response)) { |
| if ($name eq 'code_order') { |
my ($name,$value)=split(/\=/,$pair); |
| @{$code_order} = split(/\&/,&unescape($value)); |
if ($name eq 'code_order') { |
| } else { |
@{$code_order} = split(/\&/,&unescape($value)); |
| $returnhash->{&unescape($name)}=&unescape($value); |
} else { |
| } |
$returnhash->{&unescape($name)}=&unescape($value); |
| } |
} |
| $ok_response = 1; |
} |
| } |
return 'ok'; |
| } |
|
| if ($ok_response) { |
|
| return 'ok'; |
|
| } else { |
|
| return $response; |
|
| } |
} |
| |
|
| |
return $response; |
| } |
} |
| |
|
| sub auto_validate_class_sec { |
sub auto_validate_class_sec { |
|
Line 4794 sub modifyuser {
|
Line 4900 sub modifyuser {
|
| if (($uhome eq 'no_host') && |
if (($uhome eq 'no_host') && |
| (($umode && $upass) || ($umode eq 'localauth'))) { |
(($umode && $upass) || ($umode eq 'localauth'))) { |
| my $unhome=''; |
my $unhome=''; |
| if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { |
| $unhome = $desiredhome; |
$unhome = $desiredhome; |
| } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { |
} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { |
| $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; |
$unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; |
| } else { # load balancing routine for determining $unhome |
} else { # load balancing routine for determining $unhome |
| my $tryserver; |
|
| my $loadm=10000000; |
my $loadm=10000000; |
| foreach $tryserver (keys %libserv) { |
my %servers = &get_servers($udom,'library'); |
| if ($hostdom{$tryserver} eq $udom) { |
foreach my $tryserver (keys(%servers)) { |
| my $answer=reply('load',$tryserver); |
my $answer=reply('load',$tryserver); |
| if (($answer=~/\d+/) && ($answer<$loadm)) { |
if (($answer=~/\d+/) && ($answer<$loadm)) { |
| $loadm=$answer; |
$loadm=$answer; |
| $unhome=$tryserver; |
$unhome=$tryserver; |
| } |
} |
| } |
|
| } |
} |
| } |
} |
| if (($unhome eq '') || ($unhome eq 'no_host')) { |
if (($unhome eq '') || ($unhome eq 'no_host')) { |
|
Line 5023 sub createcourse {
|
Line 5127 sub createcourse {
|
| } |
} |
| # ------------------------------------------------ Check supplied server name |
# ------------------------------------------------ Check supplied server name |
| $course_server = $env{'user.homeserver'} if (! defined($course_server)); |
$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; |
return 'error:bad server name '.$course_server; |
| } |
} |
| # ------------------------------------------------------------- Make the course |
# ------------------------------------------------------------- Make the course |
|
Line 5134 sub is_locked {
|
Line 5238 sub is_locked {
|
| |
|
| sub declutter_portfile { |
sub declutter_portfile { |
| my ($file) = @_; |
my ($file) = @_; |
| &logthis("got $file"); |
$file =~ s{^(/portfolio/|portfolio/)}{/}; |
| $file =~ s-^(/portfolio/|portfolio/)-/-; |
|
| &logthis("ret $file"); |
|
| return $file; |
return $file; |
| } |
} |
| |
|
|
Line 5558 sub dirlist {
|
Line 5660 sub dirlist {
|
| return @listing_results; |
return @listing_results; |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($alternateDirectoryRoot)) { |
| my %allusers; |
my %allusers; |
| foreach my $tryserver (keys(%libserv)) { |
my %servers = &get_servers($udom,'library'); |
| if($hostdom{$tryserver} eq $udom) { |
foreach my $tryserver (keys(%servers)) { |
| my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
| $udom, $tryserver); |
$udom, $tryserver); |
| my @listing_results; |
my @listing_results; |
| if ($listing eq 'unknown_cmd') { |
if ($listing eq 'unknown_cmd') { |
| $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
| $udom, $tryserver); |
$udom, $tryserver); |
| @listing_results = split(/:/,$listing); |
@listing_results = split(/:/,$listing); |
| } else { |
} else { |
| @listing_results = |
@listing_results = |
| map { &unescape($_); } split(/:/,$listing); |
map { &unescape($_); } split(/:/,$listing); |
| } |
} |
| if ($listing_results[0] ne 'no_such_dir' && |
if ($listing_results[0] ne 'no_such_dir' && |
| $listing_results[0] ne 'empty' && |
$listing_results[0] ne 'empty' && |
| $listing_results[0] ne 'con_lost') { |
$listing_results[0] ne 'con_lost') { |
| foreach my $line (@listing_results) { |
foreach my $line (@listing_results) { |
| my ($entry) = split(/&/,$line,2); |
my ($entry) = split(/&/,$line,2); |
| $allusers{$entry} = 1; |
$allusers{$entry} = 1; |
| } |
} |
| } |
} |
| } |
|
| } |
} |
| my $alluserstr=''; |
my $alluserstr=''; |
| foreach my $user (sort(keys(%allusers))) { |
foreach my $user (sort(keys(%allusers))) { |
|
Line 5591 sub dirlist {
|
Line 5692 sub dirlist {
|
| return ('missing user name'); |
return ('missing user name'); |
| } |
} |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($alternateDirectoryRoot)) { |
| my $tryserver; |
my @all_domains = sort(&all_domains()); |
| my %alldom=(); |
foreach my $domain (@all_domains) { |
| foreach $tryserver (keys(%libserv)) { |
$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; |
| $alldom{$hostdom{$tryserver}}=1; |
} |
| } |
return @all_domains; |
| my $alldomstr=''; |
} else { |
| foreach my $domain (sort(keys(%alldom))) { |
|
| $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:'; |
|
| } |
|
| $alldomstr=~s/:$//; |
|
| return split(/:/,$alldomstr); |
|
| } else { |
|
| return ('missing domain'); |
return ('missing domain'); |
| } |
} |
| } |
} |
|
Line 6165 sub packages_tab_default {
|
Line 6260 sub packages_tab_default {
|
| $do_default=1; |
$do_default=1; |
| } elsif ($pack_type eq 'extension') { |
} elsif ($pack_type eq 'extension') { |
| push(@extension,[$package,$pack_type,$pack_part]); |
push(@extension,[$package,$pack_type,$pack_part]); |
| } else { |
} elsif ($pack_part eq $part) { |
| |
# only look at packages defaults for packages that this id is |
| push(@specifics,[$package,$pack_type,$pack_part]); |
push(@specifics,[$package,$pack_type,$pack_part]); |
| } |
} |
| } |
} |
|
Line 6883 sub getCODE {
|
Line 6979 sub getCODE {
|
| |
|
| sub rndseed { |
sub rndseed { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| |
|
| my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
| if (!$symb) { |
if (!$symb) { |
| unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
|
Line 7087 sub setup_random_from_rndseed {
|
Line 7182 sub setup_random_from_rndseed {
|
| } |
} |
| |
|
| sub latest_receipt_algorithm_id { |
sub latest_receipt_algorithm_id { |
| return 'receipt2'; |
return 'receipt3'; |
| } |
} |
| |
|
| sub recunique { |
sub recunique { |
| my $fucourseid=shift; |
my $fucourseid=shift; |
| my $unique; |
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"}; |
$unique=$env{"course.$fucourseid.internal.encseed"}; |
| } else { |
} else { |
| $unique=$perlvar{'lonReceipt'}; |
$unique=$perlvar{'lonReceipt'}; |
|
Line 7104 sub recunique {
|
Line 7200 sub recunique {
|
| sub recprefix { |
sub recprefix { |
| my $fucourseid=shift; |
my $fucourseid=shift; |
| my $prefix; |
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"}; |
$prefix=$env{"course.$fucourseid.internal.encpref"}; |
| } else { |
} else { |
| $prefix=$perlvar{'lonHostID'}; |
$prefix=$perlvar{'lonHostID'}; |
|
Line 7114 sub recprefix {
|
Line 7211 sub recprefix {
|
| |
|
| sub ireceipt { |
sub ireceipt { |
| my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; |
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 $cuname=unpack("%32C*",$funame); |
| my $cudom=unpack("%32C*",$fudom); |
my $cudom=unpack("%32C*",$fudom); |
| my $cucourseid=unpack("%32C*",$fucourseid); |
my $cucourseid=unpack("%32C*",$fucourseid); |
| my $cusymb=unpack("%32C*",$fusymb); |
my $cusymb=unpack("%32C*",$fusymb); |
| my $cunique=&recunique($fucourseid); |
my $cunique=&recunique($fucourseid); |
| my $cpart=unpack("%32S*",$part); |
my $cpart=unpack("%32S*",$part); |
| my $return =&recprefix($fucourseid).'-'; |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { |
| if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
|
| $env{'request.state'} eq 'construct') { |
|
| #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); |
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); |
| |
|
| $return.= ($cunique%$cuname+ |
$return.= ($cunique%$cuname+ |
|
Line 7254 sub repcopy_userfile {
|
Line 7359 sub repcopy_userfile {
|
| if (-e $transferfile) { return 'ok'; } |
if (-e $transferfile) { return 'ok'; } |
| my $request; |
my $request; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $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); |
my $response=$ua->request($request,$transferfile); |
| # did it work? |
# did it work? |
| if ($response->is_error()) { |
if ($response->is_error()) { |
|
Line 7277 sub tokenwrapper {
|
Line 7382 sub tokenwrapper {
|
| if ($udom && $uname && $file) { |
if ($udom && $uname && $file) { |
| $file=~s|(\?\.*)*$||; |
$file=~s|(\?\.*)*$||; |
| &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); |
&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. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| '&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
|
Line 7292 sub tokenwrapper {
|
Line 7397 sub tokenwrapper {
|
| sub getuploaded { |
sub getuploaded { |
| my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; |
$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; |
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request($reqtype,$uri); |
my $request=new HTTP::Request($reqtype,$uri); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
|
Line 7382 sub hreflocation {
|
Line 7487 sub hreflocation {
|
| } |
} |
| |
|
| sub current_machine_domains { |
sub current_machine_domains { |
| my $hostname=$hostname{$perlvar{'lonHostID'}}; |
return &machine_domains(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_domains { |
| |
my ($hostname) = @_; |
| my @domains; |
my @domains; |
| |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
| # &logthis("-$id-$name-$hostname-"); |
# &logthis("-$id-$name-$hostname-"); |
| if ($hostname eq $name) { |
if ($hostname eq $name) { |
| push(@domains,$hostdom{$id}); |
push(@domains,&host_domain($id)); |
| } |
} |
| } |
} |
| return @domains; |
return @domains; |
| } |
} |
| |
|
| sub current_machine_ids { |
sub current_machine_ids { |
| my $hostname=$hostname{$perlvar{'lonHostID'}}; |
return &machine_ids(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_ids { |
| |
my ($hostname) = @_; |
| |
$hostname ||= &hostname($perlvar{'lonHostID'}); |
| my @ids; |
my @ids; |
| |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
| # &logthis("-$id-$name-$hostname-"); |
# &logthis("-$id-$name-$hostname-"); |
| if ($hostname eq $name) { |
if ($hostname eq $name) { |
|
Line 7533 sub goodbye {
|
Line 7649 sub goodbye {
|
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| } |
} |
| |
|
| BEGIN { |
sub get_dns { |
| # ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
my ($url,$func) = @_; |
| unless ($readit) { |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| { |
foreach my $dns (<$config>) { |
| my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
next if ($dns !~ /^\^(\S*)/x); |
| %perlvar = (%perlvar,%{$configvars}); |
$dns = $1; |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',"http://$dns$url"); |
| |
my $response=$ua->request($request); |
| |
next if ($response->is_error()); |
| |
my @content = split("\n",$response->content); |
| |
&$func(\@content); |
| |
} |
| |
close($config); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
| { |
{ |
| %domaindescription = (); |
my $loaded; |
| %domain_auth_def = (); |
my %domain; |
| %domain_auth_arg_def = (); |
|
| 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; |
|
| |
|
| # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
sub parse_domain_tab { |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
my ($lines) = @_; |
| |
foreach my $line (@$lines) { |
| |
next if ($line =~ /^(\#|\s*$ )/x); |
| |
|
| |
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; |
| } |
} |
| } |
} |
| close ($fh); |
|
| |
sub load_domain_tab { |
| |
&get_dns('/adm/dns/domain',\&parse_domain_tab); |
| |
my $fh; |
| |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
| |
my @lines = <$fh>; |
| |
&parse_domain_tab(\@lines); |
| |
} |
| |
close($fh); |
| |
$loaded = 1; |
| |
} |
| |
|
| |
sub domain { |
| |
&load_domain_tab() if (!$loaded); |
| |
|
| |
my ($name,$what) = @_; |
| |
return if ( !exists($domain{$name}) ); |
| |
|
| |
if (!$what) { |
| |
return $domain{$name}{'description'}; |
| |
} |
| |
return $domain{$name}{$what}; |
| |
} |
| } |
} |
| |
|
| |
|
| # ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my %hostname; |
| |
my %hostdom; |
| |
my %libserv; |
| |
my $loaded; |
| |
|
| |
sub parse_hosts_tab { |
| |
my ($file) = @_; |
| |
foreach my $configline (@$file) { |
| |
next if ($configline =~ /^(\#|\s*$ )/x); |
| |
next if ($configline =~ /^\^/); |
| |
chomp($configline); |
| |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
| |
$name=~s/\s//g; |
| |
if ($id && $domain && $role && $name) { |
| |
$hostname{$id}=$name; |
| |
$hostdom{$id}=$domain; |
| |
if ($role eq 'library') { $libserv{$id}=$name; } |
| |
} |
| |
} |
| |
} |
| |
|
| while (my $configline=<$config>) { |
sub load_hosts_tab { |
| next if ($configline =~ /^(\#|\s*$)/); |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab); |
| chomp($configline); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
my @config = <$config>; |
| $name=~s/\s//g; |
&parse_hosts_tab(\@config); |
| if ($id && $domain && $role && $name) { |
close($config); |
| $hostname{$id}=$name; |
$loaded=1; |
| $hostdom{$id}=$domain; |
} |
| if ($role eq 'library') { $libserv{$id}=$name; } |
|
| } |
sub hostname { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $hostname{$lonid}; |
| |
} |
| |
|
| |
sub all_hostnames { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return %hostname; |
| |
} |
| |
|
| |
sub is_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return exists($libserv{$_[0]}); |
| |
} |
| |
|
| |
sub all_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return %libserv; |
| |
} |
| |
|
| |
sub get_servers { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
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; |
| |
} |
| |
} |
| |
} else { |
| |
while ( my ($host,$hostname) = each(%possible_hosts)) { |
| |
if ($hostdom{$host} eq $domain) { |
| |
$result{$host} = $hostname; |
| |
} |
| |
} |
| |
} |
| |
return %result; |
| |
} |
| |
|
| |
sub host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $hostdom{$lonid}; |
| |
} |
| |
|
| |
sub all_domains { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my %seen; |
| |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
| |
return @uniq; |
| } |
} |
| close($config); |
|
| # FIXME: dev server don't want this, production servers _do_ want this |
|
| #&get_iphost(); |
|
| } |
} |
| |
|
| sub get_iphost { |
{ |
| if (%iphost) { return %iphost; } |
my %iphost; |
| my %name_to_ip; |
my %name_to_ip; |
| foreach my $id (keys(%hostname)) { |
my %lonid_to_ip; |
| my $name=$hostname{$id}; |
sub get_hosts_from_ip { |
| my $ip; |
my ($ip) = @_; |
| if (!exists($name_to_ip{$name})) { |
my %iphosts = &get_iphost(); |
| $ip = gethostbyname($name); |
if (ref($iphosts{$ip})) { |
| if (!$ip || length($ip) ne 4) { |
return @{$iphosts{$ip}}; |
| &logthis("Skipping host $id name $name no IP found"); |
} |
| next; |
return; |
| |
} |
| |
|
| |
sub get_host_ip { |
| |
my ($lonid) = @_; |
| |
if (exists($lonid_to_ip{$lonid})) { |
| |
return $lonid_to_ip{$lonid}; |
| |
} |
| |
my $name=&hostname($lonid); |
| |
my $ip = gethostbyname($name); |
| |
return if (!$ip || length($ip) ne 4); |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
$lonid_to_ip{$lonid} = $ip; |
| |
return $ip; |
| |
} |
| |
|
| |
sub get_iphost { |
| |
if (%iphost) { return %iphost; } |
| |
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}; |
| } |
} |
| $ip=inet_ntoa($ip); |
$lonid_to_ip{$id} = $ip; |
| $name_to_ip{$name} = $ip; |
push(@{$iphost{$ip}},$id); |
| } else { |
|
| $ip = $name_to_ip{$name}; |
|
| } |
} |
| push(@{$iphost{$ip}},$id); |
return %iphost; |
| } |
} |
| return %iphost; |
|
| } |
} |
| |
|
| |
BEGIN { |
| |
|
| |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
| |
unless ($readit) { |
| |
{ |
| |
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
| |
%perlvar = (%perlvar,%{$configvars}); |
| |
} |
| |
|
| |
|
| # ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
|
Line 7944 X<userenvironment()>
|
Line 8199 X<userenvironment()>
|
| B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
| passed in @what from the requested user's environment, returns a hash |
passed in @what from the requested user's environment, returns a hash |
| |
|
| |
=item * |
| |
X<userlog_query()> |
| |
B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's |
| |
activity.log file. %filters defines filters applied when parsing the |
| |
log file. These can be start or end timestamps, or the type of action |
| |
- log to look for Login or Logout events, check for Checkin or |
| |
Checkout, role for role selection. The response is in the form |
| |
timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are |
| |
escaped strings of the action recorded in the activity.log file. |
| |
|
| =back |
=back |
| |
|
| =head2 User Roles |
=head2 User Roles |
|
Line 7973 explanation of a user role term
|
Line 8238 explanation of a user role term
|
| |
|
| =item * |
=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. |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : |
| |
All arguments are optional. Returns a hash of a roles, either for |
| |
co-author/assistant author roles for a user's Construction Space |
| |
(default), or if $context is 'user', roles for the user himself, |
| |
In the hash, keys are set to colon-sparated $uname,$udom,and $role, |
| |
and value is 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 of roles reported. If no array ref is |
| |
provided for types, will default to return only active roles. |
| |
|
| =back |
=back |
| |
|
| =head2 User Modification |
=head2 User Modification |
|
Line 8397 critical subroutine
|
Line 8674 critical subroutine
|
| |
|
| =item * |
=item * |
| |
|
| get_dom($namespace,$storearr,$udomain) : returns hash with keys from array |
get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from |
| reference filled in from namespace found in domain level on primary domain server ($udomain is optional) |
array reference filled in from namespace found in domain level on either |
| |
specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). |
| |
|
| =item * |
=item * |
| |
|
| put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) |
put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at |
| |
domain level either on specified domain server ($uhome) or primary domain |
| |
server ($udom and $uhome are optional) |
| |
|
| =back |
=back |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl