--- loncom/lonnet/perl/lonnet.pm 2007/03/27 19:38:39 1.850
+++ loncom/lonnet/perl/lonnet.pm 2007/04/03 18:16:57 1.859
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.850 2007/03/27 19:38:39 albertel Exp $
+# $Id: lonnet.pm,v 1.859 2007/04/03 18:16:57 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -145,12 +145,12 @@ sub logperm {
}
sub create_connection {
- my ($server) = @_;
- my $client=IO::Socket::UNIX->new(Peer =>"/home/httpd/sockets/common",
+ my ($hostname,$lonid) = @_;
+ my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'},
Type => SOCK_STREAM,
Timeout => 10);
return 0 if (!$client);
- print $client ("$server\n");
+ print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
my $result = <$client>;
chomp($result);
return 1 if ($result eq 'done');
@@ -185,7 +185,7 @@ sub subreply {
if($client) {
last; # Connected!
} else {
- &create_connection(&hostname($server));
+ &create_connection(&hostname($server),$server);
}
sleep(1); # Try again later if failed connection.
}
@@ -1516,8 +1516,12 @@ 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
+#
# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse
@@ -1635,6 +1639,7 @@ sub finishuserfileupload {
' for embedded media: '.$parse_result);
}
}
+
# Notify homeserver to grep it
#
my $docuhome=&homeserver($docuname,$docudom);
@@ -1647,7 +1652,7 @@ sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);
return '/adm/notfound.html';
- }
+ }
}
sub extract_embedded_items {
@@ -2069,11 +2074,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)) {
@@ -4349,6 +4359,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);
}
@@ -6917,7 +6933,6 @@ sub getCODE {
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
-
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {
unless ($symb=$wsymb) { return time; }
@@ -7426,7 +7441,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)) {
@@ -7439,7 +7458,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)) {
@@ -7580,6 +7604,7 @@ sub goodbye {
}
BEGIN {
+
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {
{
@@ -7587,17 +7612,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',
@@ -7605,12 +7646,24 @@ BEGIN {
$this_domain{$field} = shift(@elements);
}
$domain{$name} = \%this_domain;
-# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
+ &logthis("Domain.tab: $name ".$domain{$name}{'description'} );
}
}
- 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}) );
@@ -7627,41 +7680,65 @@ 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; }
+ }
+ &logthis("Hosts.tab: $name ".$id );
+ }
}
- 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;
@@ -7683,11 +7760,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;
@@ -7696,6 +7777,8 @@ BEGIN {
{
my %iphost;
+ my %name_to_ip;
+ my %lonid_to_ip;
sub get_hosts_from_ip {
my ($ip) = @_;
my %iphosts = &get_iphost();
@@ -7704,10 +7787,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};
@@ -7723,6 +7819,7 @@ BEGIN {
} else {
$ip = $name_to_ip{$name};
}
+ $lonid_to_ip{$id} = $ip;
push(@{$iphost{$ip}},$id);
}
return %iphost;
@@ -8060,6 +8157,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
@@ -8089,16 +8196,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