--- loncom/lonnet/perl/lonnet.pm 2007/03/14 23:36:10 1.848
+++ loncom/lonnet/perl/lonnet.pm 2007/04/04 00:05:31 1.861
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.848 2007/03/14 23:36:10 albertel Exp $
+# $Id: lonnet.pm,v 1.861 2007/04/04 00:05:31 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -144,6 +144,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($lonid))."\n");
+ my $result = <$client>;
+ chomp($result);
+ return 1 if ($result eq 'done');
+ return 0;
+}
+
+
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
@@ -170,8 +184,10 @@ sub subreply {
Timeout => 10);
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) {
@@ -655,6 +671,61 @@ sub homeserver {
return 'no_host';
}
+# ---------------------- Get domain configuration for a domain
+sub get_domainconf {
+ my ($udom) = @_;
+ my $cachetime=1800;
+ my ($result,$cached)=&is_cached_new('domainconfig',$udom);
+ if (defined($cached)) { return %{$result}; }
+
+ if ($udom eq '') {
+ $udom = &Apache::loncommon::determinedomain();
+ }
+ my %domconfig = &get_dom('configuration',['login','rolecolors'],$udom);
+ my %designhash;
+ if (keys(%domconfig) > 0) {
+ if (ref($domconfig{'login'}) eq 'HASH') {
+ foreach my $key (keys(%{$domconfig{'login'}})) {
+ $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
+ }
+ }
+ if (ref($domconfig{'rolecolors'}) eq 'HASH') {
+ foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
+ if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
+ foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
+ $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
+ }
+ }
+ }
+ }
+ } else {
+ my $designdir=$perlvar{'lonTabDir'}.'/lonDomColors';
+ my $designfile = $designdir.'/'.$udom.'.tab';
+ if (-e $designfile) {
+ if ( open (my $fh,"<$designfile") ) {
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($key,$val)=(split(/\=/,$line));
+ if ($val) { $designhash{$udom.'.'.$key}=$val; }
+ }
+ close($fh);
+ }
+ }
+ if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
+ $designhash{$udom.'.login.domlogo'} =
+ &lonhttpdurl("/adm/lonDomLogos/$udom.gif");
+ }
+ }
+ &do_cache_new('domainconfig',$udom,\%designhash,$cachetime);
+ return %designhash;
+}
+
+sub devalidate_domconfig_cache {
+ my ($udom)=@_;
+ &devalidate_cache_new('domainconfig',$udom);
+}
+
# ------------------------------------- Find the usernames behind a list of IDs
sub idget {
@@ -718,15 +789,27 @@ 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 (defined(&domain($udom,'primary'))) {
- my $uhome=&domain($udom,'primary');
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ 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 @pairs=split(/\&/,$rep);
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
@@ -740,17 +823,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");
}
}
# -------------------------------------------- put items in domain db files
sub put_dom {
- my ($namespace,$storehash,$udom)=@_;
- if (!$udom) { $udom=$env{'user.domain'}; }
- if (defined(&domain($udom,'primary'))) {
- my $uhome=&domain($udom,'primary');
+ my ($namespace,$storehash,$udom,$uhome)=@_;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ 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='';
foreach my $item (keys(%$storehash)) {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
@@ -758,7 +853,7 @@ 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");
}
}
@@ -1010,10 +1105,16 @@ my %remembered;
my %accessed;
my $kicks=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 {
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});
@@ -1021,7 +1122,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()];
@@ -1044,7 +1145,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__';
@@ -1494,14 +1595,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);
@@ -1548,7 +1656,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,
@@ -1558,8 +1666,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'};
@@ -1568,16 +1677,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|^(.*)/([^/]+)$|);
@@ -1613,11 +1724,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;
@@ -1625,7 +1753,7 @@ sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);
return '/adm/notfound.html';
- }
+ }
}
sub extract_embedded_items {
@@ -2047,11 +2175,16 @@ 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)) {
@@ -4327,6 +4460,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);
}
@@ -6895,7 +7034,6 @@ sub getCODE {
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
-
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {
unless ($symb=$wsymb) { return time; }
@@ -7404,7 +7542,11 @@ sub hreflocation {
}
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)) {
@@ -7417,7 +7559,12 @@ 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)) {
@@ -7558,6 +7705,7 @@ sub goodbye {
}
BEGIN {
+
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {
{
@@ -7565,17 +7713,33 @@ BEGIN {
%perlvar = (%perlvar,%{$configvars});
}
+sub get_dns {
+ my ($url,$func) = @_;
+ open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ foreach my $dns (<$config>) {
+ next if ($dns !~ /^\^(\S*)/x);
+ $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
{
+ my $loaded;
my %domain;
- my $fh;
- if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
- while (my $line = <$fh>) {
- next if ($line =~ /^(\#|\s*$ )/);
+ sub parse_domain_tab {
+ my ($lines) = @_;
+ foreach my $line (@$lines) {
+ next if ($line =~ /^(\#|\s*$ )/x);
chomp($line);
- my ($name,@elements) = split(/:/,$line,9);
+ my ($name,@elements) = split(/:/,$line,9);
my %this_domain;
foreach my $field ('description', 'auth_def', 'auth_arg_def',
'lang_def', 'city', 'longi', 'lati',
@@ -7583,12 +7747,23 @@ BEGIN {
$this_domain{$field} = shift(@elements);
}
$domain{$name} = \%this_domain;
-# &logthis("Domain.tab: $domain ".$domaindescription{$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}) );
@@ -7605,41 +7780,64 @@ BEGIN {
my %hostname;
my %hostdom;
my %libserv;
- open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ my $loaded;
- 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; }
- }
+ 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; }
+ }
+ }
}
- close($config);
+
+ sub load_hosts_tab {
+ &get_dns('/adm/dns/hosts',\&parse_hosts_tab);
+ open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ my @config = <$config>;
+ &parse_hosts_tab(\@config);
+ close($config);
+ $loaded=1;
+ }
+
# 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 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;
@@ -7661,11 +7859,15 @@ BEGIN {
}
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;
@@ -7674,6 +7876,8 @@ BEGIN {
{
my %iphost;
+ my %name_to_ip;
+ my %lonid_to_ip;
sub get_hosts_from_ip {
my ($ip) = @_;
my %iphosts = &get_iphost();
@@ -7682,10 +7886,23 @@ BEGIN {
}
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 %name_to_ip;
my %hostname = &all_hostnames();
foreach my $id (keys(%hostname)) {
my $name=$hostname{$id};
@@ -7701,6 +7918,7 @@ BEGIN {
} else {
$ip = $name_to_ip{$name};
}
+ $lonid_to_ip{$id} = $ip;
push(@{$iphost{$ip}},$id);
}
return %iphost;
@@ -8038,6 +8256,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
@@ -8067,16 +8295,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 '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
@@ -8501,12 +8731,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