--- loncom/lonnet/perl/lonnet.pm 2009/08/11 11:33:52 1.1014
+++ loncom/lonnet/perl/lonnet.pm 2009/10/08 19:54:31 1.1030
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1014 2009/08/11 11:33:52 droeschl Exp $
+# $Id: lonnet.pm,v 1.1030 2009/10/08 19:54:31 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -92,6 +92,7 @@ use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
+use File::MMagic;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
@@ -784,7 +785,8 @@ sub changepass {
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);
$newpass = &escape($newpass);
- my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
+ my $lonhost = $perlvar{'lonHostID'};
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
$server);
if (! $answer) {
&logthis("No reply on password change request to $server ".
@@ -809,6 +811,9 @@ sub changepass {
} elsif ($answer =~ "^refused") {
&logthis("$server refused to change $uname in $udom password because ".
"it was sent an unencrypted request to change the password.");
+ } elsif ($answer =~ "invalid_client") {
+ &logthis("$server refused to change $uname in $udom password because ".
+ "it was a reset by e-mail originating from an invalid server.");
}
return $answer;
}
@@ -958,44 +963,21 @@ sub idput {
}
}
-# ------------------------------------------------ dump from domain db files
-
+# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {
- my ($namespace,$udom,$uhome,$regexp,$range)=@_;
+ my ($namespace,$udom,$regexp,$range)=@_;
if (!$udom) {
$udom=$env{'user.domain'};
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- } else {
- undef($uhome);
- }
- } else {
- if (!$uhome) {
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- }
- }
}
my %returnhash;
- if ($udom && $uhome && ($uhome ne 'no_host')) {
- if ($regexp) {
- $regexp=&escape($regexp);
- } else {
- $regexp='.';
- }
- my $rep=&reply("dumpdom:$udom:$namespace:$regexp:$range",$uhome);
- my @pairs=split(/\&/,$rep);
- foreach my $item (@pairs) {
- my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key);
- next if ($key =~ /^error: 2 /);
- $returnhash{$key}=&thaw_unescape($value);
- }
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
}
return %returnhash;
}
-# ------------------------------------------- get items from domain db files
+# ------------------------------------------ get items from domain db files
sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;
@@ -1069,70 +1051,40 @@ sub put_dom {
}
}
-# -------------------------------------- newput for items in domain db files
-
+# --------------------- newput for items in db file owned by domainconfig user
sub newput_dom {
- my ($namespace,$storehash,$udom,$uhome) = @_;
+ my ($namespace,$storehash,$udom) = @_;
my $result;
if (!$udom) {
$udom=$env{'user.domain'};
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- } else {
- undef($uhome);
- }
- } else {
- if (!$uhome) {
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- }
- }
}
- if ($udom && $uhome && ($uhome ne 'no_host')) {
- my $items='';
- if (ref($storehash) eq 'HASH') {
- foreach my $key (keys(%$storehash)) {
- $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
- }
- $items=~s/\&$//;
- $result = &reply("newputdom:$udom:$namespace:$items",$uhome);
- }
- } else {
- &logthis("put_dom failed - no homeserver and/or domain");
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ $result = &newput($namespace,$storehash,$udom,$uname);
}
return $result;
}
+# --------------------- delete for items in db file owned by domainconfig user
sub del_dom {
- my ($namespace,$storearr,$udom,$uhome)=@_;
+ my ($namespace,$storearr,$udom)=@_;
if (ref($storearr) eq 'ARRAY') {
- my $items='';
- foreach my $item (@$storearr) {
- $items.=&escape($item).'&';
- }
- $items=~s/\&$//;
if (!$udom) {
$udom=$env{'user.domain'};
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- } else {
- undef($uhome);
- }
- } else {
- if (!$uhome) {
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- }
- }
}
- if ($udom && $uhome && ($uhome ne 'no_host')) {
- return &reply("deldom:$udom:$namespace:$items",$uhome);
- } else {
- &logthis("del_dom failed - no homeserver and/or domain");
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ return &del($namespace,$storearr,$udom,$uname);
}
}
}
+# ----------------------------------construct domainconfig user for a domain
+sub get_domainconfiguser {
+ my ($udom) = @_;
+ return $udom.'-domainconfig';
+}
+
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
@@ -2112,9 +2064,13 @@ sub process_coursefile {
print $fh $env{'form.'.$source};
close($fh);
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
- unless ($parse_result eq 'ok') {
- &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
+ my $mm = new File::MMagic;
+ my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
+ if ($mime_type eq 'text/html') {
+ my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
+ unless ($parse_result eq 'ok') {
+ &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
+ }
}
}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
@@ -2356,11 +2312,15 @@ sub finishuserfileupload {
}
}
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
- $codebase);
- unless ($parse_result eq 'ok') {
- &logthis('Failed to parse '.$filepath.$file.
- ' for embedded media: '.$parse_result);
+ my $mm = new File::MMagic;
+ my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
+ if ($mime_type eq 'text/html') {
+ my $parse_result = &extract_embedded_items($filepath.'/'.$file,
+ $allfiles,$codebase);
+ unless ($parse_result eq 'ok') {
+ &logthis('Failed to parse '.$filepath.$file.
+ ' for embedded media: '.$parse_result);
+ }
}
}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
@@ -3071,7 +3031,8 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
- $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,$cloneonly)=@_;
+ $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
+ $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -3091,7 +3052,9 @@ sub courseiddump {
':'.&escape($regexp_ok).':'.$as_hash.':'.
&escape($selfenrollonly).':'.&escape($catfilter).':'.
$showhidden.':'.$caller.':'.&escape($cloner).':'.
- &escape($cc_clone).':'.$cloneonly,$tryserver);
+ &escape($cc_clone).':'.$cloneonly.':'.
+ &escape($createdbefore).':'.&escape($createdafter).':'.
+ &escape($creationcontext),$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3146,10 +3109,10 @@ sub dcmaildump {
sub get_domain_roles {
my ($dom,$roles,$startdate,$enddate)=@_;
- if (undef($startdate) || $startdate eq '') {
+ if ((!defined($startdate)) || ($startdate eq '')) {
$startdate = '.';
}
- if (undef($enddate) || $enddate eq '') {
+ if ((!defined($enddate)) || ($enddate eq '')) {
$enddate = '.';
}
my $rolelist;
@@ -4772,7 +4735,7 @@ sub usertools_access {
$toolstatus = $env{'environment.'.$context.'.'.$tool};
$inststatus = $env{'environment.inststatus'};
} else {
- my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);
+ my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
$toolstatus = $userenv{$context.'.'.$tool};
$inststatus = $userenv{'inststatus'};
}
@@ -5657,7 +5620,8 @@ sub auto_validate_instcode {
}
my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
&escape($instcode).':'.&escape($owner),$homeserver));
- return $response;
+ my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
+ return ($outcome,$description);
}
sub auto_create_password {
@@ -5774,6 +5738,13 @@ sub auto_instcode_format {
push(@homeservers,$tryserver);
}
}
+ } elsif ($caller eq 'requests') {
+ if ($codedom =~ /^$match_domain$/) {
+ my $chome = &domain($codedom,'primary');
+ unless ($chome eq 'no_host') {
+ push(@homeservers,$chome);
+ }
+ }
} else {
push(@homeservers,&homeserver($caller,$codedom));
}
@@ -5874,13 +5845,37 @@ sub auto_possible_instcodes {
sub auto_courserequest_checks {
my ($dom) = @_;
- my %validations;
+ my ($homeserver,%validations);
+ if ($dom =~ /^$match_domain$/) {
+ $homeserver = &domain($dom,'primary');
+ }
+ unless ($homeserver eq 'no_host') {
+ my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my @items = split(/&/,$response);
+ foreach my $item (@items) {
+ my ($key,$value) = split('=',$item);
+ $validations{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
return %validations;
}
sub auto_courserequest_validation {
- my ($dom,$details,$inststatuses,$message) = @_;
- return 'pending';
+ my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
+ my ($homeserver,$response);
+ if ($dom =~ /^$match_domain$/) {
+ $homeserver = &domain($dom,'primary');
+ }
+ unless ($homeserver eq 'no_host') {
+
+ $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
+ ':'.&escape($crstype).':'.&escape($inststatuslist).
+ ':'.&escape($instcode).':'.&escape($instseclist),
+ $homeserver));
+ }
+ return $response;
}
sub auto_validate_class_sec {
@@ -6071,10 +6066,27 @@ sub assignrole {
my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {
- &logthis('Refused custom assignrole: '.
- $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
- return 'refused';
+ my $refused = 1;
+ if ($context eq 'requestcourses') {
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
+ if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
+ if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ }
+ }
+ if ($refused) {
+ &logthis('Refused custom assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
+ ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
}
$mrole='cr';
} elsif ($role =~ /^gr\//) {
@@ -6102,7 +6114,18 @@ sub assignrole {
if ($refused) {
if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';
- } else {
+ } elsif ($context eq 'requestcourses') {
+ my @possroles = ('st','ta','ep','in','cc');
+ if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
' '.$role.' '.$end.' '.$start.' by '.
$env{'user.name'}.' at '.$env{'user.domain'});
@@ -6426,10 +6449,41 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype,$cnum)=@_;
+ $course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);
my $cid='';
- unless (&allowed('ccc',$udom)) {
+ if ($context eq 'requestcourses') {
+ my $can_create = 0;
+ my ($ownername,$ownerdom) = split(':',$course_owner);
+ if ($udom eq $ownerdom) {
+ if (&usertools_access($ownername,$ownerdom,$category,undef,
+ $context)) {
+ $can_create = 1;
+ }
+ } else {
+ my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
+ $category);
+ if ($userenv{'reqcrsotherdom.'.$category} ne '') {
+ my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
+ if (@curr > 0) {
+ my @options = qw(approval validate autolimit);
+ my $optregex = join('|',@options);
+ if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
+ $can_create = 1;
+ }
+ }
+ }
+ }
+ if ($can_create) {
+ unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
+ unless (&allowed('ccc',$udom)) {
+ return 'refused';
+ }
+ }
+ } else {
+ return 'refused';
+ }
+ } elsif (!&allowed('ccc',$udom)) {
return 'refused';
}
# --------------------------------------------------------------- Get Unique ID
@@ -6460,12 +6514,17 @@ sub createcourse {
}
# ----------------------------------------------------------------- Course made
# log existence
+ my $now = time;
my $newcourse = {
$udom.'_'.$uname => {
description => $description,
inst_code => $inst_code,
owner => $course_owner,
type => $crstype,
+ creator => $env{'user.name'}.':'.
+ $env{'user.domain'},
+ created => $now,
+ context => $context,
},
};
&courseidput($udom,$newcourse,$uhome,'notime');
@@ -6529,13 +6588,16 @@ sub is_course {
return 0;
}
-sub store_coursereq {
- my ($requestkey,$storehash) = @_;
+sub store_userdata {
+ my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
my $result;
- if ($requestkey =~ /^($match_domain)_($match_courseid)$/) {
+ if ($datakey ne '') {
if (ref($storehash) eq 'HASH') {
- my $namespace = 'courserequests';
- my $uhome=&homeserver();
+ if ($udom eq '' || $uname eq '') {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+ my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
$result = 'error: no_host';
} else {
@@ -6548,7 +6610,7 @@ sub store_coursereq {
}
$namevalue=~s/\&$//;
$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
- "$namespace:$requestkey:$namevalue",$uhome);
+ "$namespace:$datakey:$namevalue",$uhome);
}
} else {
$result = 'error: data to store was not a hash reference';