version 1.960, 2008/06/06 04:53:51
|
version 1.973, 2008/11/28 12:09:16
|
Line 27
|
Line 27
|
# |
# |
### |
### |
|
|
|
=pod |
|
|
|
=head1 NAME |
|
|
|
Apache::lonnet.pm |
|
|
|
=head1 SYNOPSIS |
|
|
|
This file is an interface to the lonc processes of |
|
the LON-CAPA network as well as set of elaborated functions for handling information |
|
necessary for navigating through a given cluster of LON-CAPA machines within a |
|
domain. There are over 40 specialized functions in this module which handle the |
|
reading and transmission of metadata, user information (ids, names, environments, roles, |
|
logs), file information (storage, reading, directories, extensions, replication, embedded |
|
styles and descriptors), educational resources (course descriptions, section names and |
|
numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to |
|
and from more descriptive phrases or explanations. |
|
|
|
This is part of the LearningOnline Network with CAPA project |
|
described at http://www.lon-capa.org. |
|
|
|
=head1 Package Variables |
|
|
|
These are largely undocumented, so if you decipher one please note it here. |
|
|
|
=over 4 |
|
|
|
=item $processmarker |
|
|
|
Contains the time this process was started and this servers host id. |
|
|
|
=item $dumpcount |
|
|
|
Counts the number of times a message log flush has been attempted (regardless |
|
of success) by this process. Used as part of the filename when messages are |
|
delayed. |
|
|
|
=back |
|
|
|
=cut |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
use strict; |
use strict; |
Line 34 use LWP::UserAgent();
|
Line 75 use LWP::UserAgent();
|
use HTTP::Date; |
use HTTP::Date; |
# use Date::Parse; |
# use Date::Parse; |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
$_64bit %env); |
$_64bit %env %protocol); |
|
|
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
Line 61 require Exporter;
|
Line 102 require Exporter;
|
our @ISA = qw (Exporter); |
our @ISA = qw (Exporter); |
our @EXPORT = qw(%env); |
our @EXPORT = qw(%env); |
|
|
=pod |
|
|
|
=head1 Package Variables |
|
|
|
These are largely undocumented, so if you decipher one please note it here. |
|
|
|
=over 4 |
|
|
|
=item $processmarker |
|
|
|
Contains the time this process was started and this servers host id. |
|
|
|
=item $dumpcount |
|
|
|
Counts the number of times a message log flush has been attempted (regardless |
|
of success) by this process. Used as part of the filename when messages are |
|
delayed. |
|
|
|
=back |
|
|
|
=cut |
|
|
|
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
{ |
{ |
Line 643 sub spareserver {
|
Line 662 sub spareserver {
|
} |
} |
|
|
if (!$want_server_name) { |
if (!$want_server_name) { |
$spare_server="http://".&hostname($spare_server); |
my $protocol = 'http'; |
|
if ($protocol{$spare_server} eq 'https') { |
|
$protocol = $protocol{$spare_server}; |
|
} |
|
$spare_server = $protocol.'://'.&hostname($spare_server); |
} |
} |
return $spare_server; |
return $spare_server; |
} |
} |
Line 1890 sub process_coursefile {
|
Line 1913 sub process_coursefile {
|
print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
close($fh); |
close($fh); |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase); |
my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); |
unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
} |
} |
Line 2098 sub finishuserfileupload {
|
Line 2121 sub finishuserfileupload {
|
close(FH); |
close(FH); |
} |
} |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, |
$codebase); |
$codebase); |
unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
&logthis('Failed to parse '.$filepath.$file. |
&logthis('Failed to parse '.$filepath.$file. |
Line 2138 sub finishuserfileupload {
|
Line 2161 sub finishuserfileupload {
|
} |
} |
|
|
sub extract_embedded_items { |
sub extract_embedded_items { |
my ($filepath,$file,$allfiles,$codebase,$content) = @_; |
my ($fullpath,$allfiles,$codebase,$content) = @_; |
my @state = (); |
my @state = (); |
my %javafiles = ( |
my %javafiles = ( |
codebase => '', |
codebase => '', |
Line 2153 sub extract_embedded_items {
|
Line 2176 sub extract_embedded_items {
|
if ($content) { |
if ($content) { |
$p = HTML::LCParser->new($content); |
$p = HTML::LCParser->new($content); |
} else { |
} else { |
$p = HTML::LCParser->new($filepath.'/'.$file); |
$p = HTML::LCParser->new($fullpath); |
} |
} |
while (my $t=$p->get_token()) { |
while (my $t=$p->get_token()) { |
if ($t->[0] eq 'S') { |
if ($t->[0] eq 'S') { |
Line 2596 sub get_course_adv_roles {
|
Line 2619 sub get_course_adv_roles {
|
} |
} |
} else { |
} else { |
my $key=&plaintext($role); |
my $key=&plaintext($role); |
if ($section) { $key.=' (Section '.$section.')'; } |
if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } |
if ($returnhash{$key}) { |
if ($returnhash{$key}) { |
$returnhash{$key}.=','.$username.':'.$domain; |
$returnhash{$key}.=','.$username.':'.$domain; |
} else { |
} else { |
Line 2766 sub courseidput {
|
Line 2789 sub courseidput {
|
sub courseiddump { |
sub courseiddump { |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$selfenrollonly,$catfilter)=@_; |
$selfenrollonly,$catfilter,$showhidden,$caller)=@_; |
my $as_hash = 1; |
my $as_hash = 1; |
my %returnhash; |
my %returnhash; |
if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
Line 2784 sub courseiddump {
|
Line 2807 sub courseiddump {
|
&escape($instcodefilter).':'.&escape($ownerfilter). |
&escape($instcodefilter).':'.&escape($ownerfilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
&escape($selfenrollonly).':'.&escape($catfilter),$tryserver); |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
|
$showhidden.':'.$caller,$tryserver); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
Line 3560 sub privileged {
|
Line 3584 sub privileged {
|
|
|
sub rolesinit { |
sub rolesinit { |
my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
|
my %userroles; |
my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; } |
my %allroles=(); |
my %allroles=(); |
my %allgroups=(); |
my %allgroups=(); |
my $now=time; |
my $now=time; |
my %userroles = ('user.login.time' => $now); |
%userroles = ('user.login.time' => $now); |
my $group_privs; |
my $group_privs; |
|
|
if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
Line 4890 sub log_query {
|
Line 4915 sub log_query {
|
|
|
sub update_portfolio_table { |
sub update_portfolio_table { |
my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
|
if ($group ne '') { |
|
$file_name =~s /^\Q$group\E//; |
|
} |
my $homeserver = &homeserver($uname,$udom); |
my $homeserver = &homeserver($uname,$udom); |
my $queryid= |
my $queryid= |
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
Line 5557 sub modifyuser {
|
Line 5585 sub modifyuser {
|
my ($udom, $uname, $uid, |
my ($udom, $uname, $uid, |
$umode, $upass, $first, |
$umode, $upass, $first, |
$middle, $last, $gene, |
$middle, $last, $gene, |
$forceid, $desiredhome, $email)=@_; |
$forceid, $desiredhome, $email, $inststatus)=@_; |
$udom= &LONCAPA::clean_domain($udom); |
$udom= &LONCAPA::clean_domain($udom); |
$uname=&LONCAPA::clean_username($uname); |
$uname=&LONCAPA::clean_username($uname); |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
Line 5618 sub modifyuser {
|
Line 5646 sub modifyuser {
|
# -------------------------------------------------------------- Add names, etc |
# -------------------------------------------------------------- Add names, etc |
my @tmp=&get('environment', |
my @tmp=&get('environment', |
['firstname','middlename','lastname','generation','id', |
['firstname','middlename','lastname','generation','id', |
'permanentemail'], |
'permanentemail','inststatus'], |
$udom,$uname); |
$udom,$uname); |
my %names; |
my %names; |
if ($tmp[0] =~ m/^error:.*/) { |
if ($tmp[0] =~ m/^error:.*/) { |
Line 5636 sub modifyuser {
|
Line 5664 sub modifyuser {
|
if (defined($gene)) { $names{'generation'} = $gene; } |
if (defined($gene)) { $names{'generation'} = $gene; } |
if ($email) { |
if ($email) { |
$email=~s/[^\w\@\.\-\,]//gs; |
$email=~s/[^\w\@\.\-\,]//gs; |
if ($email=~/\@/) { $names{'notification'} = $email; |
if ($email=~/\@/) { $names{'permanentemail'} = $email; } |
$names{'critnotification'} = $email; |
|
$names{'permanentemail'} = $email; } |
|
} |
} |
if ($uid) { $names{'id'} = $uid; } |
if ($uid) { $names{'id'} = $uid; } |
|
if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } |
my $reply = &put('environment', \%names, $udom,$uname); |
my $reply = &put('environment', \%names, $udom,$uname); |
if ($reply ne 'ok') { return 'error: '.$reply; } |
if ($reply ne 'ok') { return 'error: '.$reply; } |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
$umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
$last.', '.$gene.' by '. |
$last.', '.$gene.', '.$email.', '.$inststatus; |
$env{'user.name'}.' at '.$env{'user.domain'}); |
if ($env{'user.name'} ne '' && $env{'user.domain'}) { |
|
$logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; |
|
} else { |
|
$logmsg .= ' during self creation'; |
|
} |
|
&logthis($logmsg); |
return 'ok'; |
return 'ok'; |
} |
} |
|
|
Line 5874 sub assigncustomrole {
|
Line 5906 sub assigncustomrole {
|
sub revokerole { |
sub revokerole { |
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
my $now=time; |
my $now=time; |
return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context); |
return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context); |
} |
} |
|
|
# ---------------------------------------------------------- Revoke Custom Role |
# ---------------------------------------------------------- Revoke Custom Role |
Line 6139 sub modify_access_controls {
|
Line 6171 sub modify_access_controls {
|
} |
} |
} |
} |
} |
} |
|
my ($group); |
|
if (&is_course($domain,$user)) { |
|
($group,my $file) = split(/\//,$file_name,2); |
|
} |
$deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
$deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
$new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
$new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
$outcome = &put('file_permissions',\%new_values,$domain,$user); |
$outcome = &put('file_permissions',\%new_values,$domain,$user); |
# remove lock |
# remove lock |
my @del_lock = ($file_name."\0".'locked_access_records'); |
my @del_lock = ($file_name."\0".'locked_access_records'); |
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
my ($file,$group); |
|
if (&is_course($domain,$user)) { |
|
($group,$file) = split(/\//,$file_name,2); |
|
} else { |
|
$file = $file_name; |
|
} |
|
my $sqlresult = |
my $sqlresult = |
&update_portfolio_table($user,$domain,$file,'portfolio_access', |
&update_portfolio_table($user,$domain,$file_name,'portfolio_access', |
$group); |
$group); |
} else { |
} else { |
$outcome = "error: could not obtain lockfile\n"; |
$outcome = "error: could not obtain lockfile\n"; |
Line 8530 sub get_dns {
|
Line 8560 sub get_dns {
|
next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^\^/); |
next if ($configline =~ /^\^/); |
chomp($configline); |
chomp($configline); |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline); |
$name=~s/\s//g; |
$name=~s/\s//g; |
if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
$hostname{$id}=$name; |
$hostname{$id}=$name; |
push(@{$name_to_host{$name}}, $id); |
push(@{$name_to_host{$name}}, $id); |
$hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
|
if (defined($protocol)) { |
|
if ($protocol eq 'https') { |
|
$protocol{$id} = $protocol; |
|
} else { |
|
$protocol{$id} = 'http'; |
|
} |
|
} else { |
|
$protocol{$id} = 'http'; |
|
} |
} |
} |
} |
} |
} |
} |
Line 8979 when the connection is brought back up
|
Line 9018 when the connection is brought back up
|
=item * B<con_failed>: unable to contact remote host and unable to save message |
=item * B<con_failed>: unable to contact remote host and unable to save message |
for later delivery |
for later delivery |
|
|
=item * B<error:>: an error a occured, a description of the error follows the : |
=item * B<error:>: an error a occurred, a description of the error follows the : |
|
|
=item * B<no_such_host>: unable to fund a host associated with the user/domain |
=item * B<no_such_host>: unable to fund a host associated with the user/domain |
that was requested |
that was requested |
Line 9146 modifyuserauth($udom,$uname,$umode,$upas
|
Line 9185 modifyuserauth($udom,$uname,$umode,$upas
|
|
|
=item * |
=item * |
|
|
modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : |
modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene, |
|
$forceid,$desiredhome,$email,$inststatus) : |
modify user |
modify user |
|
|
=item * |
=item * |
Line 9169 Inputs:
|
Line 9209 Inputs:
|
|
|
=item B<$uname> Student's loncapa login name |
=item B<$uname> Student's loncapa login name |
|
|
=item B<$uid> Student's id/student number |
=item B<$uid> Student/Employee ID |
|
|
=item B<$umode> Student's authentication mode |
=item B<$umode> Student's authentication mode |
|
|
Line 9197 Inputs:
|
Line 9237 Inputs:
|
|
|
=item B<$type> Type of enrollment (auto or manual) |
=item B<$type> Type of enrollment (auto or manual) |
|
|
=item B<$locktype> |
=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto |
|
|
|
=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC |
|
|
=item B<$cid> |
=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment |
|
|
=item B<$selfenroll> |
=item B<$context> role change context (shown in User Management Logs display in a course) |
|
|
=item B<$context> |
=item B<$inststatus> institutional status of user - : separated string of escaped status types |
|
|
=back |
=back |
|
|
Line 9556 Returns:
|
Line 9598 Returns:
|
'key_exists: <key>' -> failed to anything out of $storehash, as at |
'key_exists: <key>' -> failed to anything out of $storehash, as at |
least <key> already existed in the db (other |
least <key> already existed in the db (other |
requested keys may also already exist) |
requested keys may also already exist) |
'error: <msg>' -> unable to tie the DB or other erorr occured |
'error: <msg>' -> unable to tie the DB or other error occurred |
'con_lost' -> unable to contact request server |
'con_lost' -> unable to contact request server |
'refused' -> action was not allowed by remote machine |
'refused' -> action was not allowed by remote machine |
|
|