version 1.850, 2007/03/27 19:38:39
|
version 1.858, 2007/04/03 17:51:50
|
Line 145 sub logperm {
|
Line 145 sub logperm {
|
} |
} |
|
|
sub create_connection { |
sub create_connection { |
my ($server) = @_; |
my ($hostname,$lonid) = @_; |
my $client=IO::Socket::UNIX->new(Peer =>"/home/httpd/sockets/common", |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
Timeout => 10); |
Timeout => 10); |
return 0 if (!$client); |
return 0 if (!$client); |
print $client ("$server\n"); |
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); |
my $result = <$client>; |
my $result = <$client>; |
chomp($result); |
chomp($result); |
return 1 if ($result eq 'done'); |
return 1 if ($result eq 'done'); |
Line 185 sub subreply {
|
Line 185 sub subreply {
|
if($client) { |
if($client) { |
last; # Connected! |
last; # Connected! |
} else { |
} else { |
&create_connection(&hostname($server)); |
&create_connection(&hostname($server),$server); |
} |
} |
sleep(1); # Try again later if failed connection. |
sleep(1); # Try again later if failed connection. |
} |
} |
Line 1516 sub clean_filename {
|
Line 1516 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 |
|
# |
# 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 |
|
|
Line 1635 sub finishuserfileupload {
|
Line 1639 sub finishuserfileupload {
|
' for embedded media: '.$parse_result); |
' for embedded media: '.$parse_result); |
} |
} |
} |
} |
|
|
# Notify homeserver to grep it |
# Notify homeserver to grep it |
# |
# |
my $docuhome=&homeserver($docuname,$docudom); |
my $docuhome=&homeserver($docuname,$docudom); |
Line 1647 sub finishuserfileupload {
|
Line 1652 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 2069 sub get_course_adv_roles {
|
Line 2074 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 4349 sub courselog_query {
|
Line 4359 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 6917 sub getCODE {
|
Line 6933 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 7426 sub hreflocation {
|
Line 7441 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(); |
my %hostname = &all_hostnames(); |
while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
Line 7439 sub current_machine_domains {
|
Line 7458 sub current_machine_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(); |
my %hostname = &all_hostnames(); |
while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
Line 7580 sub goodbye {
|
Line 7604 sub goodbye {
|
} |
} |
|
|
BEGIN { |
BEGIN { |
|
|
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
unless ($readit) { |
unless ($readit) { |
{ |
{ |
Line 7587 BEGIN {
|
Line 7612 BEGIN {
|
%perlvar = (%perlvar,%{$configvars}); |
%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 |
# ------------------------------------------------------------ Read domain file |
{ |
{ |
|
my $loaded; |
my %domain; |
my %domain; |
|
|
my $fh; |
sub parse_domain_tab { |
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { |
my ($lines) = @_; |
while (my $line = <$fh>) { |
foreach my $line (@$lines) { |
next if ($line =~ /^(\#|\s*$ )/); |
next if ($line =~ /^(\#|\s*$ )/x); |
|
|
chomp($line); |
chomp($line); |
my ($name,@elements) = split(/:/,$line,9); |
my ($name,@elements) = split(/:/,$line,9); |
my %this_domain; |
my %this_domain; |
foreach my $field ('description', 'auth_def', 'auth_arg_def', |
foreach my $field ('description', 'auth_def', 'auth_arg_def', |
'lang_def', 'city', 'longi', 'lati', |
'lang_def', 'city', 'longi', 'lati', |
Line 7605 BEGIN {
|
Line 7646 BEGIN {
|
$this_domain{$field} = shift(@elements); |
$this_domain{$field} = shift(@elements); |
} |
} |
$domain{$name} = \%this_domain; |
$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 { |
sub domain { |
|
&load_domain_tab() if (!$loaded); |
|
|
my ($name,$what) = @_; |
my ($name,$what) = @_; |
return if ( !exists($domain{$name}) ); |
return if ( !exists($domain{$name}) ); |
|
|
Line 7627 BEGIN {
|
Line 7680 BEGIN {
|
my %hostname; |
my %hostname; |
my %hostdom; |
my %hostdom; |
my %libserv; |
my %libserv; |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my $loaded; |
|
|
while (my $configline=<$config>) { |
sub parse_hosts_tab { |
next if ($configline =~ /^(\#|\s*$)/); |
my ($file) = @_; |
chomp($configline); |
foreach my $configline (@$file) { |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
next if ($configline =~ /^(\#|\s*$ )/x); |
$name=~s/\s//g; |
next if ($configline =~ /^\^/); |
if ($id && $domain && $role && $name) { |
chomp($configline); |
$hostname{$id}=$name; |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
$hostdom{$id}=$domain; |
$name=~s/\s//g; |
if ($role eq 'library') { $libserv{$id}=$name; } |
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 |
# FIXME: dev server don't want this, production servers _do_ want this |
#&get_iphost(); |
#&get_iphost(); |
|
|
sub hostname { |
sub hostname { |
|
&load_hosts_tab() if (!$loaded); |
|
|
my ($lonid) = @_; |
my ($lonid) = @_; |
return $hostname{$lonid}; |
return $hostname{$lonid}; |
} |
} |
|
|
sub all_hostnames { |
sub all_hostnames { |
|
&load_hosts_tab() if (!$loaded); |
|
|
return %hostname; |
return %hostname; |
} |
} |
|
|
sub is_library { |
sub is_library { |
|
&load_hosts_tab() if (!$loaded); |
|
|
return exists($libserv{$_[0]}); |
return exists($libserv{$_[0]}); |
} |
} |
|
|
sub all_library { |
sub all_library { |
|
&load_hosts_tab() if (!$loaded); |
|
|
return %libserv; |
return %libserv; |
} |
} |
|
|
sub get_servers { |
sub get_servers { |
|
&load_hosts_tab() if (!$loaded); |
|
|
my ($domain,$type) = @_; |
my ($domain,$type) = @_; |
my %possible_hosts = ($type eq 'library') ? %libserv |
my %possible_hosts = ($type eq 'library') ? %libserv |
: %hostname; |
: %hostname; |
Line 7683 BEGIN {
|
Line 7760 BEGIN {
|
} |
} |
|
|
sub host_domain { |
sub host_domain { |
|
&load_hosts_tab() if (!$loaded); |
|
|
my ($lonid) = @_; |
my ($lonid) = @_; |
return $hostdom{$lonid}; |
return $hostdom{$lonid}; |
} |
} |
|
|
sub all_domains { |
sub all_domains { |
|
&load_hosts_tab() if (!$loaded); |
|
|
my %seen; |
my %seen; |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
return @uniq; |
return @uniq; |
Line 7696 BEGIN {
|
Line 7777 BEGIN {
|
|
|
{ |
{ |
my %iphost; |
my %iphost; |
|
my %name_to_ip; |
|
my %lonid_to_ip; |
sub get_hosts_from_ip { |
sub get_hosts_from_ip { |
my ($ip) = @_; |
my ($ip) = @_; |
my %iphosts = &get_iphost(); |
my %iphosts = &get_iphost(); |
Line 7704 BEGIN {
|
Line 7787 BEGIN {
|
} |
} |
return; |
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 { |
sub get_iphost { |
if (%iphost) { return %iphost; } |
if (%iphost) { return %iphost; } |
my %name_to_ip; |
|
my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
foreach my $id (keys(%hostname)) { |
foreach my $id (keys(%hostname)) { |
my $name=$hostname{$id}; |
my $name=$hostname{$id}; |
Line 7723 BEGIN {
|
Line 7819 BEGIN {
|
} else { |
} else { |
$ip = $name_to_ip{$name}; |
$ip = $name_to_ip{$name}; |
} |
} |
|
$lonid_to_ip{$id} = $ip; |
push(@{$iphost{$ip}},$id); |
push(@{$iphost{$ip}},$id); |
} |
} |
return %iphost; |
return %iphost; |
Line 8060 X<userenvironment()>
|
Line 8157 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 8089 explanation of a user role term
|
Line 8190 explanation of a user role term
|
|
|
=item * |
=item * |
|
|
get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : |
optional. Returns a hash of a user's roles, with keys set to |
All arguments are optional. Returns a hash of a roles, either for |
colon-sparated $uname,$udom,and $role, and value set to |
co-author/assistant author roles for a user's Construction Space |
colon-separated start and end times for the role. If no username and |
(default), or if $context is 'user', roles for the user himself, |
domain are specified, will default to current user/domain. Types, |
In the hash, keys are set to colon-sparated $uname,$udom,and $role, |
roles, and roledoms are references to arrays, of role statuses |
and value is set to colon-separated start and end times for the role. |
(active, future or previous), roles (e.g., cc,in, st etc.) and domains |
If no username and domain are specified, will default to current |
of the roles which can be used to restrict the list if roles |
user/domain. Types, roles, and roledoms are references to arrays, |
reported. If no array ref is provided for types, will default to |
of role statuses (active, future or previous), roles |
return only active 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 |
|
|