--- loncom/lonnet/perl/lonnet.pm 2007/03/03 02:16:10 1.844
+++ loncom/lonnet/perl/lonnet.pm 2007/10/01 21:52:57 1.916
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.844 2007/03/03 02:16:10 albertel Exp $
+# $Id: lonnet.pm,v 1.916 2007/10/01 21:52:57 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,24 +31,21 @@ package Apache::lonnet;
use strict;
use LWP::UserAgent();
-use HTTP::Headers;
use HTTP::Date;
# use Date::Parse;
-use vars
-qw(%perlvar %badServerCache %iphost %spareid
- %libserv %pr %prp $memcache %packagetab
- %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
- %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);
+use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
+ $_64bit %env);
+
+my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
+ %userrolehash, $processmarker, $dumpcount, %coursedombuf,
+ %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
+ %courseownerbuf, %coursetypebuf);
use IO::Socket;
use GDBM_File;
use HTML::LCParser;
-use HTML::Parser;
use Fcntl qw(:flock);
-use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
+use Storable qw(thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;
use Digest::MD5;
@@ -146,6 +143,20 @@ sub logperm {
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($hostname))."\n");
+ my $result = <$client>;
+ chomp($result);
+ return 1 if ($result eq 'done');
+ return 0;
+}
+
+
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
@@ -170,10 +181,12 @@ sub subreply {
$client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,
Timeout => 10);
- if($client) {
+ if ($client) {
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;
if ($client) {
@@ -201,6 +214,24 @@ sub reply {
# ----------------------------------------------------------- Send USR1 to lonc
sub reconlonc {
+ my ($lonid) = @_;
+ my $hostname = &hostname($lonid);
+ if ($lonid) {
+ my $peerfile="$perlvar{'lonSockDir'}/$hostname";
+ if ($hostname && -e $peerfile) {
+ &logthis("Trying to reconnect lonc for $lonid ($hostname)");
+ my $client=IO::Socket::UNIX->new(Peer => $peerfile,
+ Type => SOCK_STREAM,
+ Timeout => 10);
+ if ($client) {
+ print $client ("reset_retries\n");
+ my $answer=<$client>;
+ #reset just this one.
+ }
+ }
+ return;
+ }
+
&logthis("Trying to reconnect lonc");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {
@@ -289,7 +320,10 @@ sub convert_and_load_session_env {
my ($lonidsdir,$handle)=@_;
my @profile;
{
- open(my $idf,"$lonidsdir/$handle.id");
+ open(my $idf,'+<',"$lonidsdir/$handle.id");
+ if (!$idf) {
+ return 0;
+ }
flock($idf,LOCK_SH);
@profile=<$idf>;
close($idf);
@@ -328,7 +362,10 @@ sub transfer_profile_to_env {
my $convert;
{
- open(my $idf,"$lonidsdir/$handle.id");
+ open(my $idf,'+<',"$lonidsdir/$handle.id");
+ if (!$idf) {
+ return;
+ }
flock($idf,LOCK_SH);
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
&GDBM_READER(),0640)) {
@@ -360,6 +397,34 @@ sub transfer_profile_to_env {
}
}
+# ---------------------------------------------------- Check for valid session
+sub check_for_valid_session {
+ my ($r) = @_;
+ my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
+ my $lonid=$cookies{'lonID'};
+ return undef if (!$lonid);
+
+ my $handle=&LONCAPA::clean_handle($lonid->value);
+ my $lonidsdir=$r->dir_config('lonIDsDir');
+ return undef if (!-e "$lonidsdir/$handle.id");
+
+ open(my $idf,'+<',"$lonidsdir/$handle.id");
+ return undef if (!$idf);
+
+ flock($idf,LOCK_SH);
+ my %disk_env;
+ if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
+ &GDBM_READER(),0640)) {
+ return undef;
+ }
+
+ if (!defined($disk_env{'user.name'})
+ || !defined($disk_env{'user.domain'})) {
+ return undef;
+ }
+ return $handle;
+}
+
sub timed_flock {
my ($file,$lock_type) = @_;
my $failed=0;
@@ -394,8 +459,9 @@ sub appenv {
$env{$key}=$newenv{$key};
}
}
- open(my $env_file,$env{'user.environment'});
- if (&timed_flock($env_file,LOCK_EX)
+ open(my $env_file,'+<',$env{'user.environment'});
+ if ($env_file
+ && &timed_flock($env_file,LOCK_EX)
&&
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
@@ -415,16 +481,17 @@ sub delenv {
"Attempt to delete from environment ".$delthis);
return 'error';
}
- open(my $env_file,$env{'user.environment'});
- if (&timed_flock($env_file,LOCK_EX)
+ open(my $env_file,'+<',$env{'user.environment'});
+ if ($env_file
+ && &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});
- delete($disk_env{$key});
- }
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
}
untie(%disk_env);
}
@@ -551,6 +618,27 @@ sub compare_server_load {
}
return ($spare_server,$lowest_load);
}
+
+# --------------------------- ask offload servers if user already has a session
+sub find_existing_session {
+ my ($udom,$uname) = @_;
+ foreach my $try_server (@{ $spareid{'primary'} },
+ @{ $spareid{'default'} }) {
+ return $try_server if (&has_user_session($try_server, $udom, $uname));
+ }
+ return;
+}
+
+# -------------------------------- ask if server already has a session for user
+sub has_user_session {
+ my ($lonid,$udom,$uname) = @_;
+ my $result = &reply(join(':','userhassession',
+ map {&escape($_)} ($udom,$uname)),$lonid);
+ return 1 if ($result eq 'ok');
+
+ return 0;
+}
+
# --------------------------------------------- Try to change a user's password
sub changepass {
@@ -720,21 +808,36 @@ sub idput {
# ------------------------------------------- get items from domain db files
sub get_dom {
- my ($namespace,$storearr,$udom)=@_;
+ my ($namespace,$storearr,$udom,$uhome)=@_;
my $items='';
foreach my $item (@$storearr) {
$items.=&escape($item).'&';
}
$items=~s/\&$//;
- if (!$udom) { $udom=$env{'user.domain'}; }
- if (exists($domain_primary{$udom})) {
- my $uhome=$domain_primary{$udom};
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ undef($uhome);
+ }
+ } 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 %returnhash;
+ if ($rep eq '' || $rep =~ /^error: 2 /) {
+ return %returnhash;
+ }
my @pairs=split(/\&/,$rep);
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
return @pairs;
}
- my %returnhash=();
my $i=0;
foreach my $item (@$storearr) {
$returnhash{$item}=&thaw_unescape($pairs[$i]);
@@ -742,17 +845,29 @@ sub get_dom {
}
return %returnhash;
} else {
- &logthis("get_dom failed - no primary domain server for $udom");
+ &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
}
}
# -------------------------------------------- put items in domain db files
sub put_dom {
- my ($namespace,$storehash,$udom)=@_;
- if (!$udom) { $udom=$env{'user.domain'}; }
- if (exists($domain_primary{$udom})) {
- my $uhome=$domain_primary{$udom};
+ my ($namespace,$storehash,$udom,$uhome)=@_;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ undef($uhome);
+ }
+ } else {
+ if (!$uhome) {
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ }
+ }
+ }
+ if ($udom && $uhome && ($uhome ne 'no_host')) {
my $items='';
foreach my $item (keys(%$storehash)) {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
@@ -760,15 +875,15 @@ sub put_dom {
$items=~s/\&$//;
return &reply("putdom:$udom:$namespace:$items",$uhome);
} 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 (exists($domain_primary{$udom})) {
- my $uhome=$domain_primary{$udom};
+ 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);
@@ -788,6 +903,204 @@ sub retrieve_inst_usertypes {
return (\%returnhash,\@order);
}
+sub is_domainimage {
+ my ($url) = @_;
+ if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
+ if (&domain($1) ne '') {
+ return '1';
+ }
+ }
+ return;
+}
+
+sub inst_directory_query {
+ my ($srch) = @_;
+ my $udom = $srch->{'srchdomain'};
+ my %results;
+ my $homeserver = &domain($udom,'primary');
+ my $outcome;
+ if ($homeserver ne '') {
+ my $queryid=&reply("querysend:instdirsearch:".
+ &escape($srch->{'srchby'}).':'.
+ &escape($srch->{'srchterm'}).':'.
+ &escape($srch->{'srchtype'}),$homeserver);
+ my $host=&hostname($homeserver);
+ if ($queryid !~/^\Q$host\E\_/) {
+ &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+ return;
+ }
+ my $response = &get_query_reply($queryid);
+ my $maxtries = 5;
+ my $tries = 1;
+ while (($response=~/^timeout/) && ($tries < $maxtries)) {
+ $response = &get_query_reply($queryid);
+ $tries ++;
+ }
+
+ if (!&error($response) && $response ne 'refused') {
+ if ($response eq 'unavailable') {
+ $outcome = $response;
+ } else {
+ $outcome = 'ok';
+ my @matches = split(/\n/,$response);
+ foreach my $match (@matches) {
+ my ($key,$value) = split(/=/,$match);
+ $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
+ }
+ }
+ }
+ }
+ return ($outcome,%results);
+}
+
+sub usersearch {
+ my ($srch) = @_;
+ my $dom = $srch->{'srchdomain'};
+ my %results;
+ my %libserv = &all_library();
+ my $query = 'usersearch';
+ foreach my $tryserver (keys(%libserv)) {
+ if (&host_domain($tryserver) eq $dom) {
+ my $host=&hostname($tryserver);
+ my $queryid=
+ &reply("querysend:".&escape($query).':'.
+ &escape($srch->{'srchby'}).':'.
+ &escape($srch->{'srchtype'}).':'.
+ &escape($srch->{'srchterm'}),$tryserver);
+ if ($queryid !~/^\Q$host\E\_/) {
+ &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
+ next;
+ }
+ my $reply = &get_query_reply($queryid);
+ my $maxtries = 1;
+ my $tries = 1;
+ while (($reply=~/^timeout/) && ($tries < $maxtries)) {
+ $reply = &get_query_reply($queryid);
+ $tries ++;
+ }
+ if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+ &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries);
+ } else {
+ my @matches;
+ if ($reply =~ /\n/) {
+ @matches = split(/\n/,$reply);
+ } else {
+ @matches = split(/\&/,$reply);
+ }
+ foreach my $match (@matches) {
+ my ($uname,$udom,%userhash);
+ foreach my $entry (split(/:/,$match)) {
+ my ($key,$value) =
+ map {&unescape($_);} split(/=/,$entry);
+ $userhash{$key} = $value;
+ if ($key eq 'username') {
+ $uname = $value;
+ } elsif ($key eq 'domain') {
+ $udom = $value;
+ }
+ }
+ $results{$uname.':'.$udom} = \%userhash;
+ }
+ }
+ }
+ }
+ return %results;
+}
+
+sub get_instuser {
+ my ($udom,$uname,$id) = @_;
+ my $homeserver = &domain($udom,'primary');
+ my ($outcome,%results);
+ if ($homeserver ne '') {
+ my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
+ &escape($id).':'.&escape($udom),$homeserver);
+ my $host=&hostname($homeserver);
+ if ($queryid !~/^\Q$host\E\_/) {
+ &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+ return;
+ }
+ my $response = &get_query_reply($queryid);
+ my $maxtries = 5;
+ my $tries = 1;
+ while (($response=~/^timeout/) && ($tries < $maxtries)) {
+ $response = &get_query_reply($queryid);
+ $tries ++;
+ }
+ if (!&error($response) && $response ne 'refused') {
+ if ($response eq 'unavailable') {
+ $outcome = $response;
+ } else {
+ $outcome = 'ok';
+ my @matches = split(/\n/,$response);
+ foreach my $match (@matches) {
+ my ($key,$value) = split(/=/,$match);
+ $results{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
+ }
+ my %userinfo;
+ if (ref($results{$uname}) eq 'HASH') {
+ %userinfo = %{$results{$uname}};
+ }
+ return ($outcome,%userinfo);
+}
+
+sub inst_rulecheck {
+ my ($udom,$uname,$rules) = @_;
+ my %returnhash;
+ if ($udom ne '') {
+ if (ref($rules) eq 'ARRAY') {
+ @{$rules} = map {&escape($_);} (@{$rules});
+ my $rulestr = join(':',@{$rules});
+ my $homeserver=&domain($udom,'primary');
+ if (($homeserver ne '') && ($homeserver ne 'no_host')) {
+ my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.
+ &escape($uname).':'.$rulestr,
+ $homeserver));
+ if ($response ne 'refused') {
+ my @pairs=split(/\&/,$response);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ }
+ }
+ }
+ }
+ return %returnhash;
+}
+
+sub inst_userrules {
+ my ($udom) = @_;
+ my (%ruleshash,@ruleorder);
+ if ($udom ne '') {
+ my $homeserver=&domain($udom,'primary');
+ if (($homeserver ne '') && ($homeserver ne 'no_host')) {
+ my $response=&reply('instuserrules:'.&escape($udom),
+ $homeserver);
+ if (($response ne 'refused') && ($response ne 'error') &&
+ ($response ne 'no_such_host')) {
+ my ($hashitems,$orderitems) = split(/:/,$response);
+ my @pairs=split(/\&/,$hashitems);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $ruleshash{$key}=&thaw_unescape($value);
+ }
+ my @esc_order = split(/\&/,$orderitems);
+ foreach my $item (@esc_order) {
+ push(@ruleorder,&unescape($item));
+ }
+ }
+ }
+ }
+ return (\%ruleshash,\@ruleorder);
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -1012,10 +1325,19 @@ my %remembered;
my %accessed;
my $kicks=0;
my $hits=0;
+sub make_key {
+ my ($name,$id) = @_;
+ if (length($id) > 65
+ && length(&escape($id)) > 200) {
+ $id=length($id).':'.&Digest::MD5::md5_hex($id);
+ }
+ return &escape($name.':'.$id);
+}
+
sub devalidate_cache_new {
my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
- $id=&escape($name.':'.$id);
+ $id=&make_key($name,$id);
$memcache->delete($id);
delete($remembered{$id});
delete($accessed{$id});
@@ -1023,7 +1345,7 @@ sub devalidate_cache_new {
sub is_cached_new {
my ($name,$id,$debug) = @_;
- $id=&escape($name.':'.$id);
+ $id=&make_key($name,$id);
if (exists($remembered{$id})) {
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
$accessed{$id}=[&gettimeofday()];
@@ -1046,7 +1368,7 @@ sub is_cached_new {
sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;
- $id=&escape($name.':'.$id);
+ $id=&make_key($name,$id);
my $setvalue=$value;
if (!defined($setvalue)) {
$setvalue='__undef__';
@@ -1055,7 +1377,11 @@ sub do_cache_new {
$time=600;
}
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
- $memcache->set($id,$setvalue,$time);
+ my $result = $memcache->set($id,$setvalue,$time);
+ if (! $result) {
+ &logthis("caching of id -> $id failed");
+ $memcache->disconnect_all();
+ }
# need to make a copy of $value
#&make_room($id,$value,$debug);
return $value;
@@ -1317,7 +1643,7 @@ sub ssi {
my $request;
$form{'no_update_last_known'}=1;
-
+ &Apache::lonenc::check_encrypt(\$fn);
if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
@@ -1496,14 +1822,21 @@ sub clean_filename {
# $coursedoc - if true up to the current course
# if false
# $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>
# or /adm/notfound.html if failure to upload occurse
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'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -1550,7 +1883,7 @@ sub userfileupload {
if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,
- $codebase);
+ $codebase,$thumbwidth,$thumbheight);
} else {
$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,
@@ -1560,8 +1893,9 @@ sub userfileupload {
} elsif (defined($destuname)) {
my $docuname=$destuname;
my $docudom=$destudom;
- return &finishuserfileupload($docuname,$docudom,$formname,
- $fname,$parser,$allfiles,$codebase);
+ return &finishuserfileupload($docuname,$docudom,$formname,$fname,
+ $parser,$allfiles,$codebase,
+ $thumbwidth,$thumbheight);
} else {
my $docuname=$env{'user.name'};
@@ -1570,16 +1904,18 @@ sub userfileupload {
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
}
- return &finishuserfileupload($docuname,$docudom,$formname,
- $fname,$parser,$allfiles,$codebase);
+ return &finishuserfileupload($docuname,$docudom,$formname,$fname,
+ $parser,$allfiles,$codebase,
+ $thumbwidth,$thumbheight);
}
}
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 $filepath=$perlvar{'lonDocRoot'};
- my ($fnamepath,$file);
+ my ($fnamepath,$file,$fetchthumb);
$file=$fname;
if ($fname=~m|/|) {
($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
@@ -1615,11 +1951,28 @@ sub finishuserfileupload {
' 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
#
my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
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 '/uploaded/'.$path.$file;
@@ -1627,7 +1980,7 @@ sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);
return '/adm/notfound.html';
- }
+ }
}
sub extract_embedded_items {
@@ -1651,13 +2004,16 @@ sub extract_embedded_items {
while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {
my ($tagname, $attr) = ($t->[1],$t->[2]);
- push (@state, $tagname);
+ push(@state, $tagname);
if (lc($tagname) eq 'allow') {
&add_filetype($allfiles,$attr->{'src'},'src');
}
if (lc($tagname) eq 'img') {
&add_filetype($allfiles,$attr->{'src'},'src');
}
+ if (lc($tagname) eq 'a') {
+ &add_filetype($allfiles,$attr->{'href'},'href');
+ }
if (lc($tagname) eq 'script') {
if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');
@@ -1899,7 +2255,7 @@ sub flushcourselogs {
#
my %domrolebuffer = ();
foreach my $entry (keys %domainrolehash) {
- my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
+ my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).
'='.&escape($domainrolehash{$entry});
@@ -2004,6 +2360,14 @@ sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;
}
+ if (($env{'request.role'} =~ /dc\./) &&
+ (($trole=~/^au/) || ($trole=~/^in/) ||
+ ($trole=~/^cc/) || ($trole=~/^ep/) ||
+ ($trole=~/^cr/) || ($trole=~/^ta/))) {
+ $userrolehash
+ {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
+ =$tend.':'.$tstart;
+ }
if (($trole=~/^dc/) || ($trole=~/^ad/) ||
($trole=~/^li/) || ($trole=~/^li/) ||
($trole=~/^au/) || ($trole=~/^dg/) ||
@@ -2049,15 +2413,25 @@ sub get_course_adv_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($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);
+ }
my %returnhash=();
my $now=time;
foreach my $entry (keys(%dumphash)) {
- my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
+ my ($role,$tend,$tstart);
+ if ($context eq 'userroles') {
+ ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
+ } else {
+ ($tend,$tstart)=split(/\:/,$dumphash{$entry});
+ }
if (($tstart) && ($tstart<0)) { next; }
my $status = 'active';
if (($tend) && ($tend<$now)) {
@@ -2075,7 +2449,13 @@ sub get_my_roles {
next;
}
}
- my ($role,$username,$domain,$section)=split(/\:/,$entry);
+ my ($rolecode,$username,$domain,$section,$area);
+ if ($context eq 'userroles') {
+ ($area,$rolecode) = split(/_/,$entry);
+ (undef,$domain,$username,$section) = split(/\//,$area);
+ } else {
+ ($role,$username,$domain,$section) = split(/\:/,$entry);
+ }
if (ref($roledoms) eq 'ARRAY') {
if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
next;
@@ -2085,7 +2465,7 @@ sub get_my_roles {
if (!grep(/^\Q$role\E$/,@{$roles})) {
next;
}
- }
+ }
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}
return %returnhash;
@@ -2133,9 +2513,14 @@ sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
my %returnhash=();
unless ($domfilter) { $domfilter=''; }
- foreach my $tryserver (keys %libserv) {
- if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
- if ((!$domfilter) || (&host_domain($tryserver) eq $domfilter)) {
+ my %libserv = &all_library();
+ foreach my $tryserver (keys(%libserv)) {
+ if ( ( $hostidflag == 1
+ && grep(/^\Q$tryserver\E$/,@{$hostidref}) )
+ || (!defined($hostidflag)) ) {
+
+ if ($domfilter eq ''
+ || (&host_domain($tryserver) eq $domfilter)) {
foreach my $line (
split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.
$sincefilter.':'.&escape($descfilter).':'.
@@ -2165,12 +2550,13 @@ sub dcmailput {
sub dcmaildump {
my ($dom,$startdate,$enddate,$senders) = @_;
my %returnhash=();
- if (exists($domain_primary{$dom})) {
+
+ if (defined(&domain($dom,'primary'))) {
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
&escape($enddate).':';
my @esc_senders=map { &escape($_)} @$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);
if (($key) && ($value)) {
$returnhash{&unescape($key)} = &unescape($value);
@@ -3023,7 +3409,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_courseid)(/?\w*)-) {
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
$trole = $1;
$area = $2;
$sec = $3;
@@ -3504,9 +3890,16 @@ sub get_portfolio_access {
}
if (@users > 0) {
foreach my $userkey (@users) {
- if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
- return 'ok';
- }
+ if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
+ foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
+ if (ref($item) eq 'HASH') {
+ if (($item->{'uname'} eq $env{'user.name'}) &&
+ ($item->{'udom'} eq $env{'user.domain'})) {
+ return 'ok';
+ }
+ }
+ }
+ }
}
}
my %roleshash;
@@ -3666,26 +4059,40 @@ sub customaccess {
$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
- my ($effect,$realm,$role)=split(/\:/,$right);
- if ($role) {
- if ($role ne $urole) { next; }
- }
- foreach my $scope (split(/\s*\,\s*/,$realm)) {
- my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
- if ($tdom) {
- if ($tdom ne $udom) { next; }
- }
- if ($tcrs) {
- if ($tcrs ne $ucrs) { next; }
- }
- if ($tsec) {
- if ($tsec ne $usec) { next; }
- }
- $access=($effect eq 'allow');
- last;
- }
- if ($realm eq '' && $role eq '') {
- $access=($effect eq 'allow');
+ my ($effect,$realm,$role,$type)=split(/\:/,$right);
+ if ($type eq 'user') {
+ foreach my $scope (split(/\s*\,\s*/,$realm)) {
+ my ($tdom,$tuname)=split(m{/},$scope);
+ if ($tdom) {
+ if ($tdom ne $env{'user.domain'}) { next; }
+ }
+ if ($tuname) {
+ if ($tuname ne $env{'user.name'}) { next; }
+ }
+ $access=($effect eq 'allow');
+ last;
+ }
+ } else {
+ if ($role) {
+ if ($role ne $urole) { next; }
+ }
+ foreach my $scope (split(/\s*\,\s*/,$realm)) {
+ my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
+ if ($tdom) {
+ if ($tdom ne $udom) { next; }
+ }
+ if ($tcrs) {
+ if ($tcrs ne $ucrs) { next; }
+ }
+ if ($tsec) {
+ if ($tsec ne $usec) { next; }
+ }
+ $access=($effect eq 'allow');
+ last;
+ }
+ if ($realm eq '' && $role eq '') {
+ $access=($effect eq 'allow');
+ }
}
}
return $access;
@@ -4170,6 +4577,7 @@ sub definerole {
sub metadata_query {
my ($query,$custom,$customshow,$server_array)=@_;
my %rhash;
+ my %libserv = &all_library();
my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );
for my $server (@server_list) {
@@ -4213,6 +4621,23 @@ sub update_portfolio_table {
return $reply;
}
+# -------------------------- Update MySQL allusers table
+
+sub update_allusers_table {
+ my ($uname,$udom,$names) = @_;
+ my $homeserver = &homeserver($uname,$udom);
+ my $queryid=
+ &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
+ 'lastname='.&escape($names->{'lastname'}).'%%'.
+ 'firstname='.&escape($names->{'firstname'}).'%%'.
+ 'middlename='.&escape($names->{'middlename'}).'%%'.
+ 'generation='.&escape($names->{'generation'}).'%%'.
+ 'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
+ 'id='.&escape($names->{'id'}),$homeserver);
+ my $reply = &get_query_reply($queryid);
+ return $reply;
+}
+
# ------- Request retrieval of institutional classlists for course(s)
sub fetch_enrollment_query {
@@ -4247,7 +4672,7 @@ sub fetch_enrollment_query {
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {
- my @responses = split/:/,$reply;
+ my @responses = split(/:/,$reply);
if ($homeserver eq $perlvar{'lonHostID'}) {
foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line,2);
@@ -4290,8 +4715,8 @@ sub get_query_reply {
sleep 2;
if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {
- $reply.=<$fh>;
- close($fh);
+ $reply = join('',<$fh>);
+ close($fh);
} else { return 'error: reply_file_error'; }
return &unescape($reply);
}
@@ -4322,6 +4747,12 @@ sub courselog_query {
}
sub userlog_query {
+#
+# possible filters:
+# action: log check role
+# start: timestamp
+# end: timestamp
+#
my ($uname,$udom,%filters)=@_;
return &log_query($uname,$udom,'userlog',%filters);
}
@@ -4330,8 +4761,18 @@ sub userlog_query {
sub auto_run {
my ($cnum,$cdom) = @_;
- my $homeserver = &homeserver($cnum,$cdom);
- my $response = &reply('autorun:'.$cdom,$homeserver);
+ my $response = 0;
+ my $settings;
+ my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
+ if (ref($domconfig{'autoenroll'}) eq 'HASH') {
+ $settings = $domconfig{'autoenroll'};
+ if ($settings->{'run'} eq '1') {
+ $response = 1;
+ }
+ } else {
+ my $homeserver = &homeserver($cnum,$cdom);
+ $response = &reply('autorun:'.$cdom,$homeserver);
+ }
return $response;
}
@@ -4341,7 +4782,7 @@ sub auto_get_sections {
my @secs = ();
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
unless ($response eq 'refused') {
- @secs = split/:/,$response;
+ @secs = split(/:/,$response);
}
return @secs;
}
@@ -4361,15 +4802,27 @@ sub auto_validate_courseID {
}
sub auto_create_password {
- my ($cnum,$cdom,$authparam) = @_;
- my $homeserver = &homeserver($cnum,$cdom);
+ my ($cnum,$cdom,$authparam,$udom) = @_;
+ my ($homeserver,$response);
my $create_passwd = 0;
my $authchk = '';
- my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
- if ($response eq 'refused') {
- $authchk = 'refused';
+ if ($udom =~ /^$match_domain$/) {
+ $homeserver = &domain($udom,'primary');
+ }
+ if ($homeserver eq '') {
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ }
+ if ($homeserver eq '') {
+ $authchk = 'nodomain';
} else {
- ($authparam,$create_passwd,$authchk) = split/:/,$response;
+ $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
+ if ($response eq 'refused') {
+ $authchk = 'refused';
+ } else {
+ ($authparam,$create_passwd,$authchk) = split(/:/,$response);
+ }
}
return ($authparam,$create_passwd,$authchk);
}
@@ -4476,7 +4929,7 @@ sub auto_instcode_format {
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
if ($response !~ /(con_lost|error|no_such_host|refused)/) {
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
- split/:/,$response;
+ split(/:/,$response);
%{$codes} = (%{$codes},&str2hash($codes_str));
push(@{$codetitles},&str2array($codetitles_str));
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
@@ -4856,7 +5309,8 @@ sub modifyuser {
}
# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',
- ['firstname','middlename','lastname','generation'],
+ ['firstname','middlename','lastname','generation','id',
+ 'permanentemail'],
$udom,$uname);
my %names;
if ($tmp[0] =~ m/^error:.*/) {
@@ -4878,8 +5332,10 @@ sub modifyuser {
$names{'critnotification'} = $email;
$names{'permanentemail'} = $email; }
}
+ if ($uid) { $names{'id'} = $uid; }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
+ my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
@@ -5038,7 +5494,7 @@ sub createcourse {
}
# ------------------------------------------------ Check supplied server name
$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;
}
# ------------------------------------------------------------- Make the course
@@ -5174,7 +5630,7 @@ sub save_selected_files {
my ($user, $path, @files) = @_;
my $filename = $user."savedfiles";
my @other_files = &files_not_in_path($user, $path);
- open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open (OUT, '>'.$tmpdir.$filename);
foreach my $file (@files) {
print (OUT $env{'form.currentpath'}.$file."\n");
}
@@ -5766,6 +6222,13 @@ sub devalidatecourseresdata {
# --------------------------------------------------- Course Resourcedata Query
+#
+# Parameters:
+# $coursenum - Number of the course.
+# $coursedomain - Domain at which the course was created.
+# Returns:
+# A hash of the course parameters along (I think) with timestamps
+# and version info.
sub get_courseresdata {
my ($coursenum,$coursedomain)=@_;
@@ -5824,7 +6287,21 @@ sub get_userresdata {
}
return $tmp;
}
-
+#----------------------------------------------- resdata - return resource data
+# Purpose:
+# Return resource data for either users or for a course.
+# Parameters:
+# $name - Course/user name.
+# $domain - Name of the domain the user/course is registered on.
+# $type - Type of thing $name is (must be 'course' or 'user'
+# @which - Array of names of resources desired.
+# Returns:
+# The value of the first reasource in @which that is found in the
+# resource hash.
+# Exceptional Conditions:
+# If the $type passed in is not valid (not the string 'course' or
+# 'user', an undefined reference is returned.
+# If none of the resources are found, an undef is returned
sub resdata {
my ($name,$domain,$type,@which)=@_;
my $result;
@@ -6002,6 +6479,12 @@ sub EXT {
my ($map) = &decode_symb($symbparm);
return &symbread($map);
}
+ if ($space eq 'filename') {
+ if ($symbparm) {
+ return &clutter((&decode_symb($symbparm))[2]);
+ }
+ return &hreflocation('',$env{'request.filename'});
+ }
my ($section, $group, @groups);
my ($courselevelm,$courselevel);
@@ -6171,7 +6654,8 @@ sub packages_tab_default {
$do_default=1;
} elsif ($pack_type eq 'extension') {
push(@extension,[$package,$pack_type,$pack_part]);
- } else {
+ } elsif ($pack_part eq $part || $pack_type eq 'part') {
+ # only look at packages defaults for packages that this id is
push(@specifics,[$package,$pack_type,$pack_part]);
}
}
@@ -6374,10 +6858,11 @@ sub metadata {
# only ws inside the tag, and not in default, so use default
# as value
$metaentry{':'.$unikey}=$default;
- } else {
- # either something interesting inside the tag or default
- # uninteresting
+ } elsif ( $internaltext =~ /\S/ ) {
+ # something interesting inside the tag
$metaentry{':'.$unikey}=$internaltext;
+ } else {
+ # no interesting values, don't set a default
}
# end of not-a-package not-a-library import
}
@@ -6387,13 +6872,18 @@ sub metadata {
}
}
my ($extension) = ($uri =~ /\.(\w+)$/);
+ $extension = lc($extension);
+ if ($extension eq 'htm') { $extension='html'; }
+
foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);
}
- if (!exists($metaentry{':packages'})) {
+
+ if (!exists($metaentry{':packages'})
+ || $packagetab{"import_defaults&extension_$extension"}) {
foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then
if ($key!~/^default&/) { next; }
@@ -6512,12 +7002,15 @@ sub gettitle {
}
my ($map,$resid,$url)=&decode_symb($symb);
my $title='';
- my %bighash;
- if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
- &GDBM_READER(),0640)) {
- my $mapid=$bighash{'map_pc_'.&clutter($map)};
- $title=$bighash{'title_'.$mapid.'.'.$resid};
- untie %bighash;
+ if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
+ $title = $env{'course.'.$env{'request.course.id'}.'.description'};
+ } else {
+ if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
+ &GDBM_READER(),0640)) {
+ my $mapid=$bighash{'map_pc_'.&clutter($map)};
+ $title=$bighash{'title_'.$mapid.'.'.$resid};
+ untie(%bighash);
+ }
}
$title=~s/\&colon\;/\:/gs;
if ($title) {
@@ -6889,9 +7382,8 @@ sub getCODE {
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
-
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
- if (!$symb) {
+ if (!defined($symb)) {
unless ($symb=$wsymb) { return time; }
}
if (!$courseid) { $courseid=$wcourseid; }
@@ -7343,6 +7835,7 @@ sub filelocation {
$file=~s-^/adm/wrapper/-/-;
$file=~s-^/adm/coursedocs/showdoc/-/-;
}
+
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
@@ -7363,6 +7856,8 @@ sub filelocation {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;
}
+ } elsif ($file =~ m-^/adm/-) {
+ $location = $perlvar{'lonDocRoot'}.'/'.$file;
} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;
@@ -7394,11 +7889,18 @@ sub hreflocation {
$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;
}
+ if ($file=~ m{^/userfiles/}) {
+ $file =~ s{^/userfiles/}{/uploaded/};
+ }
return $file;
}
sub current_machine_domains {
- my $hostname=&hostname($perlvar{'lonHostID'});
+ return &machine_domains(&hostname($perlvar{'lonHostID'}));
+}
+
+sub machine_domains {
+ my ($hostname) = @_;
my @domains;
my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {
@@ -7411,16 +7913,18 @@ sub current_machine_domains {
}
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 %hostname = &all_hostnames();
- while( my($id, $name) = each(%hostname)) {
-# &logthis("-$id-$name-$hostname-");
- if ($hostname eq $name) {
- push(@ids,$id);
- }
+ my %name_to_host = &all_names();
+ if (ref($name_to_host{$hostname}) eq 'ARRAY') {
+ return @{ $name_to_host{$hostname} };
}
- return @ids;
+ return;
}
sub additional_machine_domains {
@@ -7464,7 +7968,8 @@ sub declutter {
sub clutter {
my $thisfn='/'.&declutter(shift);
- unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) {
+ if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/}
+ || $thisfn =~ m{^/adm/(includes|pages)} ) {
$thisfn='/res'.$thisfn;
}
if ($thisfn !~m|/adm|) {
@@ -7533,59 +8038,111 @@ sub correct_line_ends {
sub goodbye {
&logthis("Starting Shut down");
#not converted to using infrastruture and probably shouldn't be
- &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
+ &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
#converted
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
- &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
-# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
-# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
+ &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
+# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
+# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
#1.1 only
-# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
-# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
-# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
-# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
- &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
+# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
+# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
+# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
+# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
+ &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
&logthis(sprintf("%-20s is %s",'kicks',$kicks));
&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();
&logthis("Shutting down");
}
-BEGIN {
-# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
- unless ($readit) {
-{
- my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
- %perlvar = (%perlvar,%{$configvars});
-}
+sub get_dns {
+ my ($url,$func,$ignore_cache) = @_;
+ if (!$ignore_cache) {
+ my ($content,$cached)=
+ &Apache::lonnet::is_cached_new('dns',$url);
+ if ($cached) {
+ &$func($content);
+ return;
+ }
+ }
+ my %alldns;
+ open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ foreach my $dns (<$config>) {
+ next if ($dns !~ /^\^(\S*)/x);
+ $alldns{$1} = 1;
+ }
+ while (%alldns) {
+ my ($dns) = keys(%alldns);
+ delete($alldns{$dns});
+ 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);
+ &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
+ &$func(\@content);
+ return;
+ }
+ close($config);
+ my $which = (split('/',$url))[3];
+ &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
+ open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
+ my @content = <$config>;
+ &$func(\@content);
+ return;
+}
# ------------------------------------------------------------ Read domain file
{
- %domaindescription = ();
- %domain_auth_def = ();
- %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;
+ my $loaded;
+ my %domain;
+
+ sub parse_domain_tab {
+ 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;
+ }
+ }
+
+ sub reset_domain_info {
+ undef($loaded);
+ undef(%domain);
+ }
+
+ sub load_domain_tab {
+ my ($ignore_cache) = @_;
+ &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
+ 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);
- # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
-# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
+ my ($name,$what) = @_;
+ return if ( !exists($domain{$name}) );
+
+ if (!$what) {
+ return $domain{$name}{'description'};
}
+ return $domain{$name}{$what};
}
- close ($fh);
}
@@ -7593,31 +8150,82 @@ BEGIN {
{
my %hostname;
my %hostdom;
- open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
-
- while (my $configline=<$config>) {
- next if ($configline =~ /^(\#|\s*$)/);
- 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; }
- }
+ my %libserv;
+ my $loaded;
+ my %name_to_host;
+
+ 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;
+ push(@{$name_to_host{$name}}, $id);
+ $hostdom{$id}=$domain;
+ if ($role eq 'library') { $libserv{$id}=$name; }
+ }
+ }
+ }
+
+ sub reset_hosts_info {
+ &purge_remembered();
+ &reset_domain_info();
+ &reset_hosts_ip_info();
+ undef(%name_to_host);
+ undef(%hostname);
+ undef(%hostdom);
+ undef(%libserv);
+ undef($loaded);
+ }
+
+ sub load_hosts_tab {
+ my ($ignore_cache) = @_;
+ &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
+ open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ my @config = <$config>;
+ &parse_hosts_tab(\@config);
+ close($config);
+ $loaded=1;
}
- close($config);
- # FIXME: dev server don't want this, production servers _do_ want this
- #&get_iphost();
sub hostname {
+ &load_hosts_tab() if (!$loaded);
+
my ($lonid) = @_;
return $hostname{$lonid};
}
+
sub all_hostnames {
+ &load_hosts_tab() if (!$loaded);
+
return %hostname;
}
+
+ sub all_names {
+ &load_hosts_tab() if (!$loaded);
+
+ return %name_to_host;
+ }
+
+ 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;
@@ -7637,50 +8245,125 @@ BEGIN {
}
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;
}
}
-sub get_hosts_from_ip {
- my ($ip) = @_;
- my %iphosts = &get_iphost();
- if (ref($iphosts{$ip})) {
- return @{$iphosts{$ip}};
+{
+ my %iphost;
+ my %name_to_ip;
+ my %lonid_to_ip;
+
+ sub get_hosts_from_ip {
+ my ($ip) = @_;
+ my %iphosts = &get_iphost();
+ if (ref($iphosts{$ip})) {
+ return @{$iphosts{$ip}};
+ }
+ return;
+ }
+
+ sub reset_hosts_ip_info {
+ undef(%iphost);
+ undef(%name_to_ip);
+ undef(%lonid_to_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");
- next;
+ 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 {
+ my ($ignore_cache) = @_;
+
+ if (!$ignore_cache) {
+ if (%iphost) {
+ return %iphost;
}
- $ip=inet_ntoa($ip);
- $name_to_ip{$name} = $ip;
- } else {
- $ip = $name_to_ip{$name};
+ my ($ip_info,$cached)=
+ &Apache::lonnet::is_cached_new('iphost','iphost');
+ if ($cached) {
+ %iphost = %{$ip_info->[0]};
+ %name_to_ip = %{$ip_info->[1]};
+ %lonid_to_ip = %{$ip_info->[2]};
+ return %iphost;
+ }
+ }
+
+ # get yesterday's info for fallback
+ my %old_name_to_ip;
+ my ($ip_info,$cached)=
+ &Apache::lonnet::is_cached_new('iphost','iphost');
+ if ($cached) {
+ %old_name_to_ip = %{$ip_info->[1]};
+ }
+
+ my %name_to_host = &all_names();
+ foreach my $name (keys(%name_to_host)) {
+ my $ip;
+ if (!exists($name_to_ip{$name})) {
+ $ip = gethostbyname($name);
+ if (!$ip || length($ip) ne 4) {
+ if (defined($old_name_to_ip{$name})) {
+ $ip = $old_name_to_ip{$name};
+ &logthis("Can't find $name defaulting to old $ip");
+ } else {
+ &logthis("Name $name no IP found");
+ next;
+ }
+ } else {
+ $ip=inet_ntoa($ip);
+ }
+ $name_to_ip{$name} = $ip;
+ } else {
+ $ip = $name_to_ip{$name};
+ }
+ foreach my $id (@{ $name_to_host{$name} }) {
+ $lonid_to_ip{$id} = $ip;
+ }
+ push(@{$iphost{$ip}},@{$name_to_host{$name}});
}
- push(@{$iphost{$ip}},$id);
+ &Apache::lonnet::do_cache_new('iphost','iphost',
+ [\%iphost,\%name_to_ip,\%lonid_to_ip],
+ 48*60*60);
+
+ 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
{
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
@@ -8012,6 +8695,16 @@ X<userenvironment()>
B<userenvironment($udom,$uname,@what)>: gets the values of the keys
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
=head2 User Roles
@@ -8041,16 +8734,18 @@ 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.
+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 'userroles', 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
@@ -8194,6 +8889,14 @@ setting for a specific $type, where $typ
@what should be a list of parameters to ask about. This routine caches
answers for 5 minutes.
+=item *
+
+get_courseresdata($courseid, $domain) : dump the entire course resource
+data base, returning a hash that is keyed by the resource name and has
+values that are the resource value. I believe that the timestamps and
+versions are also returned.
+
+
=back
=head2 Course Modification
@@ -8475,12 +9178,15 @@ critical subroutine
=item *
-get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
-reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
+get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
+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 *
-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
@@ -8873,3 +9579,4 @@ symblist($mapname,%newhash) : update sym
=back
=cut
+