--- loncom/lonnet/perl/lonnet.pm 2008/08/27 02:29:31 1.965
+++ loncom/lonnet/perl/lonnet.pm 2009/01/05 16:29:24 1.976.2.6
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.965 2008/08/27 02:29:31 raeburn Exp $
+# $Id: lonnet.pm,v 1.976.2.6 2009/01/05 16:29:24 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -27,6 +27,47 @@
#
###
+=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;
use strict;
@@ -34,7 +75,7 @@ use LWP::UserAgent();
use HTTP::Date;
# use Date::Parse;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
- $_64bit %env);
+ $_64bit %env %protocol);
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
@@ -61,28 +102,6 @@ require Exporter;
our @ISA = qw (Exporter);
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
{
@@ -158,6 +177,20 @@ sub create_connection {
return 0;
}
+sub get_server_timezone {
+ my ($cnum,$cdom) = @_;
+ my $home=&homeserver($cnum,$cdom);
+ if ($home ne 'no_host') {
+ my $cachetime = 24*3600;
+ my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
+ if (defined($cached)) {
+ return $timezone;
+ } else {
+ my $timezone = &reply('servertimezone',$home);
+ return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
+ }
+ }
+}
# -------------------------------------------------- Non-critical communication
sub subreply {
@@ -502,7 +535,7 @@ sub delenv {
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {
- if ($key=~/^$delthis/) {
+ if ($key=~/^\Q$delthis\E/) {
delete($env{$key});
delete($disk_env{$key});
}
@@ -643,7 +676,11 @@ sub spareserver {
}
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;
}
@@ -1199,12 +1236,11 @@ sub inst_userrules {
return (\%ruleshash,\@ruleorder);
}
-# ------------------------- Get Authentication and Language Defaults for Domain
+# ------------- Get Authentication, Language and User Tools Defaults for Domain
sub get_domain_defaults {
my ($domain) = @_;
my $cachetime = 60*60*24;
- my ($defauthtype,$defautharg,$deflang);
my ($result,$cached)=&is_cached_new('domdefaults',$domain);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
@@ -1213,16 +1249,31 @@ sub get_domain_defaults {
}
my %domdefaults;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
+ &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain);
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+ $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
+ $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
}
+ if (ref($domconfig{'quotas'}) eq 'HASH') {
+ if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
+ $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
+ } else {
+ $domdefaults{'defaultquota'} = $domconfig{'quotas'};
+ }
+ my @usertools = ('aboutme','blog','portfolio');
+ foreach my $item (@usertools) {
+ if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
+ $domdefaults{$item} = $domconfig{'quotas'}{$item};
+ }
+ }
+ }
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);
return %domdefaults;
@@ -1547,9 +1598,14 @@ sub purge_remembered {
sub userenvironment {
my ($udom,$unam,@what)=@_;
+ my $items;
+ foreach my $item (@what) {
+ $items.=&escape($item).'&';
+ }
+ $items=~s/\&$//;
my %returnhash=();
my @answer=split(/\&/,
- &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
+ &reply('get:'.$udom.':'.$unam.':environment:'.$items,
&homeserver($unam,$udom)));
my $i;
for ($i=0;$i<=$#what;$i++) {
@@ -1746,7 +1802,7 @@ sub ssi_body {
}
my $output='';
my $response;
- if ($filelink=~/^http\:/) {
+ if ($filelink=~/^https?\:/) {
($output,$response)=&externalssi($filelink);
} else {
($output,$response)=&ssi($filelink,%form);
@@ -2466,7 +2522,12 @@ sub courseacclog {
# FIXME: Probably ought to escape things....
foreach my $key (keys(%env)) {
if ($key=~/^form\.(.*)/) {
- $what.=':'.$1.'='.$env{$key};
+ my $formitem = $1;
+ if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
+ $what.=':'.$formitem.'='.$env{$key};
+ } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
+ $what.=':'.$formitem.'='.$env{$key};
+ }
}
}
} elsif ($fnsymb =~ m:^/adm/searchcat:) {
@@ -2596,7 +2657,7 @@ sub get_course_adv_roles {
}
} else {
my $key=&plaintext($role);
- if ($section) { $key.=' (Section '.$section.')'; }
+ if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
} else {
@@ -3561,12 +3622,13 @@ sub privileged {
sub rolesinit {
my ($domain,$username,$authhost)=@_;
+ my %userroles;
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 %allgroups=();
my $now=time;
- my %userroles = ('user.login.time' => $now);
+ %userroles = ('user.login.time' => $now);
my $group_privs;
if ($rolesdump ne '') {
@@ -4327,6 +4389,129 @@ sub is_portfolio_file {
return;
}
+sub usertools_access {
+ my ($uname,$udom,$tool,$action) = @_;
+ my $access;
+ my %tools = (
+ aboutme => 1,
+ blog => 1,
+ portfolio => 1,
+ );
+ return if (!defined($tools{$tool}));
+
+ if ((!defined($udom)) || (!defined($uname))) {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ if ($action ne 'reload') {
+ return $env{'environment.availabletools.'.$tool};
+ }
+ }
+
+ my ($toolstatus,$inststatus);
+
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ $toolstatus = $env{'environment.tools.'.$tool};
+ $inststatus = $env{'environment.inststatus'};
+ } else {
+ my %userenv = &userenvironment($udom,$uname,'tools.'.$tool);
+ $toolstatus = $userenv{'tools.'.$tool};
+ $inststatus = $userenv{'inststatus'};
+ }
+
+ if ($toolstatus ne '') {
+ if ($toolstatus) {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
+ return $access;
+ }
+
+ my $is_adv = &is_advanced_user($udom,$uname);
+ my %domdef = &get_domain_defaults($udom);
+ if (ref($domdef{$tool}) eq 'HASH') {
+ if ($is_adv) {
+ if ($domdef{$tool}{'_LC_adv'} ne '') {
+ if ($domdef{$tool}{'_LC_adv'}) {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
+ return $access;
+ }
+ }
+ if ($inststatus ne '') {
+ my ($hasaccess,$hasnoaccess);
+ foreach my $affiliation (split(/:/,$inststatus)) {
+ if ($domdef{$tool}{$affiliation} ne '') {
+ if ($domdef{$tool}{$affiliation}) {
+ $hasaccess = 1;
+ } else {
+ $hasnoaccess = 1;
+ }
+ }
+ }
+ if ($hasaccess || $hasnoaccess) {
+ if ($hasaccess) {
+ $access = 1;
+ } elsif ($hasnoaccess) {
+ $access = 0;
+ }
+ return $access;
+ }
+ } else {
+ if ($domdef{$tool}{'default'} ne '') {
+ if ($domdef{$tool}{'default'}) {
+ $access = 1;
+ } elsif ($domdef{$tool}{'default'} == 0) {
+ $access = 0;
+ }
+ return $access;
+ }
+ }
+ } else {
+ $access = 1;
+ return $access;
+ }
+}
+
+sub is_advanced_user {
+ my ($udom,$uname) = @_;
+ my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
+ my %allroles;
+ my $is_adv;
+ foreach my $role (keys(%roleshash)) {
+ my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
+ my $area = '/'.$tdomain.'/'.$trest;
+ if ($sec ne '') {
+ $area .= '/'.$sec;
+ }
+ if (($area ne '') && ($trole ne '')) {
+ my $spec=$trole.'.'.$area;
+ if ($trole =~ /^cr\//) {
+ &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole ne 'gr') {
+ &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
+ }
+ }
+ }
+ foreach my $role (keys(%allroles)) {
+ last if ($is_adv);
+ foreach my $item (split(/:/,$allroles{$role})) {
+ if ($item ne '') {
+ my ($privilege,$restrictions)=split(/&/,$item);
+ if ($privilege eq 'adv') {
+ $is_adv = 1;
+ last;
+ }
+ }
+ }
+ }
+ return $is_adv;
+}
# ---------------------------------------------- Custom access rule evaluation
@@ -4891,6 +5076,9 @@ sub log_query {
sub update_portfolio_table {
my ($uname,$udom,$file_name,$query,$group,$action) = @_;
+ if ($group ne '') {
+ $file_name =~s /^\Q$group\E//;
+ }
my $homeserver = &homeserver($uname,$udom);
my $queryid=
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
@@ -6144,20 +6332,18 @@ 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);
$new_values{$file_name."\0".'accesscontrol'} = \%new_control;
$outcome = &put('file_permissions',\%new_values,$domain,$user);
# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');
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 =
- &update_portfolio_table($user,$domain,$file,'portfolio_access',
+ &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
$group);
} else {
$outcome = "error: could not obtain lockfile\n";
@@ -8130,7 +8316,10 @@ sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }
my $request;
$uri=~s/^\///;
- $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);
# did it work?
if ($response->is_error()) {
@@ -8145,7 +8334,7 @@ sub repcopy_userfile {
sub tokenwrapper {
my $uri=shift;
- $uri=~s|^http\://([^/]+)||;
+ $uri=~s|^https?\://([^/]+)||;
$uri=~s|^/||;
$env{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;
@@ -8153,7 +8342,10 @@ sub tokenwrapper {
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
- return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
+ my $homeserver = &homeserver($uname,$udom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ return $protocol.'://'.&hostname($homeserver).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -8168,7 +8360,10 @@ sub tokenwrapper {
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
- $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -8250,7 +8445,7 @@ sub filelocation {
sub hreflocation {
my ($dir,$file)=@_;
- unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
+ unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
$file=filelocation($dir,$file);
} elsif ($file=~m-^/adm/-) {
$file=~s-^/adm/wrapper/-/-;
@@ -8446,14 +8641,19 @@ sub get_dns {
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);
- $alldns{$1} = 1;
+ my $line = $1;
+ my ($host,$protocol) = split(/:/,$line);
+ if ($protocol ne 'https') {
+ $protocol = 'http';
+ }
+ $alldns{$host} = $protocol;
}
while (%alldns) {
my ($dns) = keys(%alldns);
- delete($alldns{$dns});
my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',"http://$dns$url");
+ my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);
+ delete($alldns{$dns});
next if ($response->is_error());
my @content = split("\n",$response->content);
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
@@ -8518,6 +8718,12 @@ sub get_dns {
}
return $domain{$name}{$what};
}
+
+ sub domain_info {
+ &load_domain_tab() if (!$loaded);
+ return %domain;
+ }
+
}
@@ -8535,13 +8741,22 @@ sub get_dns {
next if ($configline =~ /^(\#|\s*$ )/x);
next if ($configline =~ /^\^/);
chomp($configline);
- my ($id,$domain,$role,$name)=split(/:/,$configline);
+ my ($id,$domain,$role,$name,$protocol)=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; }
+ if (defined($protocol)) {
+ if ($protocol eq 'https') {
+ $protocol{$id} = $protocol;
+ } else {
+ $protocol{$id} = 'http';
+ }
+ } else {
+ $protocol{$id} = 'http';
+ }
}
}
}
@@ -8586,6 +8801,11 @@ sub get_dns {
return %name_to_host;
}
+ sub all_host_domain {
+ &load_hosts_tab() if (!$loaded);
+ return %hostdom;
+ }
+
sub is_library {
&load_hosts_tab() if (!$loaded);
@@ -8984,7 +9204,7 @@ when the connection is brought back up
=item * B<con_failed>: unable to contact remote host and unable to save message
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
that was requested
@@ -9564,7 +9784,7 @@ Returns:
'key_exists: <key>' -> failed to anything out of $storehash, as at
least <key> already existed in the db (other
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
'refused' -> action was not allowed by remote machine