--- loncom/lonnet/perl/lonnet.pm 2009/03/09 05:25:44 1.990 +++ loncom/lonnet/perl/lonnet.pm 2009/09/13 03:13:38 1.1027 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.990 2009/03/09 05:25:44 raeburn Exp $ +# $Id: lonnet.pm,v 1.1027 2009/09/13 03:13:38 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -74,9 +74,7 @@ use strict; use LWP::UserAgent(); use HTTP::Date; use Image::Magick; -use IO::Socket; -# use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol); @@ -94,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; @@ -198,6 +197,33 @@ sub get_server_timezone { } } +sub get_server_loncaparev { + my ($dom,$lonhost) = @_; + if (defined($lonhost)) { + if (!defined(&hostname($lonhost))) { + undef($lonhost); + } + } + if (!defined($lonhost)) { + if (defined(&domain($dom,'primary'))) { + $lonhost=&domain($dom,'primary'); + if ($lonhost eq 'no_host') { + undef($lonhost); + } + } + } + if (defined($lonhost)) { + my $cachetime = 24*3600; + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); + if (defined($cached)) { + return $loncaparev; + } else { + my $loncaparev = &reply('serverloncaparev',$lonhost); + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); + } + } +} + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; @@ -693,7 +719,12 @@ sub spareserver { if ($protocol{$spare_server} eq 'https') { $protocol = $protocol{$spare_server}; } - $spare_server = $protocol.'://'.&hostname($spare_server); + if (defined($spare_server)) { + my $hostname = &hostname($spare_server); + if (defined($hostname)) { + $spare_server = $protocol.'://'.$hostname; + } + } } return $spare_server; } @@ -928,7 +959,21 @@ sub idput { } } -# ------------------------------------------- get items from domain db files +# ------------------------------dump from db file owned by domainconfig user +sub dump_dom { + my ($namespace,$udom,$regexp,$range)=@_; + if (!$udom) { + $udom=$env{'user.domain'}; + } + my %returnhash; + if ($udom) { + my $uname = &get_domainconfiguser($udom); + %returnhash = &dump($namespace,$udom,$uname,$regexp,$range); + } + return %returnhash; +} + +# ------------------------------------------ get items from domain db files sub get_dom { my ($namespace,$storearr,$udom,$uhome)=@_; @@ -1002,6 +1047,40 @@ sub put_dom { } } +# --------------------- newput for items in db file owned by domainconfig user +sub newput_dom { + my ($namespace,$storehash,$udom) = @_; + my $result; + if (!$udom) { + $udom=$env{'user.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)=@_; + if (ref($storearr) eq 'ARRAY') { + if (!$udom) { + $udom=$env{'user.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); @@ -1296,7 +1375,7 @@ sub get_domain_defaults { } } if (ref($domconfig{'requestcourses'}) eq 'HASH') { - foreach my $item ('official','unofficial') { + foreach my $item ('official','unofficial','community') { $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; } } @@ -1635,12 +1714,14 @@ sub userenvironment { } $items=~s/\&$//; my %returnhash=(); - my @answer=split(/\&/, - &reply('get:'.$udom.':'.$unam.':environment:'.$items, - &homeserver($unam,$udom))); - my $i; - for ($i=0;$i<=$#what;$i++) { - $returnhash{$what[$i]}=&unescape($answer[$i]); + my $uhome = &homeserver($unam,$udom); + unless ($uhome eq 'no_host') { + my @answer=split(/\&/, + &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); + my $i; + for ($i=0;$i<=$#what;$i++) { + $returnhash{$what[$i]}=&unescape($answer[$i]); + } } return %returnhash; } @@ -1836,6 +1917,8 @@ sub ssi_body { if ($filelink=~/^https?\:/) { ($output,$response)=&externalssi($filelink); } else { + $filelink .= $filelink=~/\?/ ? '&' : '?'; + $filelink .= 'inhibitmenu=yes'; ($output,$response)=&ssi($filelink,%form); } $output=~s|//(\s*)?\s||gs; @@ -1879,7 +1962,7 @@ sub ssi { &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); - $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); + $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form))); } else { $request=new HTTP::Request('GET',&absolute_url().$fn); } @@ -1977,9 +2060,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, @@ -2141,9 +2228,12 @@ sub userfileupload { close($fh); return $fullpath.'/'.$fname; } - + if ($subdir eq 'scantron') { + $fname = 'scantron_orig_'.$fname; + } else { # Create the directory if not present - $fname="$subdir/$fname"; + $fname="$subdir/$fname"; + } if ($coursedoc) { my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; @@ -2218,11 +2308,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+$/)) { @@ -2526,7 +2620,7 @@ sub flushcourselogs { # Reverse lookup of domain roles (dc, ad, li, sc, au) # my %domrolebuffer = (); - foreach my $entry (keys %domainrolehash) { + foreach my $entry (keys(%domainrolehash)) { my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); if ($domrolebuffer{$rudom}) { $domrolebuffer{$rudom}.='&'.&escape($entry). @@ -2681,6 +2775,9 @@ sub courserolelog { $storehash{'section'} = $sec; } &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); + if (($trole ne 'st') || ($sec ne '')) { + &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + } } } return; @@ -2703,15 +2800,29 @@ sub get_course_adv_roles { my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); my $now=time; - foreach my $entry (keys %dumphash) { + my %privileged; + foreach my $entry (keys(%dumphash)) { my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { next; } + unless (ref($privileged{$domain}) eq 'HASH') { + my %dompersonnel = + &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); + $privileged{$domain} = {}; + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $user (keys(%{$dompersonnel{$server}})) { + my ($trole,$uname,$udom) = split(/:/,$user); + $privileged{$udom}{$uname} = 1; + } + } + } + } + if ((exists($privileged{$domain}{$username})) && + (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } if ($codes) { if ($section) { $role .= ':'.$section; } @@ -2756,6 +2867,7 @@ sub get_my_roles { } my %returnhash=(); my $now=time; + my %privileged; foreach my $entry (keys(%dumphash)) { my ($role,$tend,$tstart); if ($context eq 'userroles') { @@ -2804,9 +2916,32 @@ sub get_my_roles { } } if ($hidepriv) { - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { - next; + if ($context eq 'userroles') { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { + next; + } + } else { + unless (ref($privileged{$domain}) eq 'HASH') { + my %dompersonnel = + &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); + $privileged{$domain} = {}; + if (keys(%dompersonnel)) { + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $user (keys(%{$dompersonnel{$server}})) { + my ($trole,$uname,$udom) = split(/:/,$user); + $privileged{$udom}{$uname} = $trole; + } + } + } + } + } + if (exists($privileged{$domain}{$username})) { + if (!$nothide{$username.':'.$domain}) { + next; + } + } } } if ($withsec) { @@ -2892,7 +3027,7 @@ sub courseidput { sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, - $selfenrollonly,$catfilter,$showhidden,$caller)=@_; + $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,$cloneonly)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -2911,7 +3046,8 @@ sub courseiddump { ':'.&escape($coursefilter).':'.&escape($typefilter). ':'.&escape($regexp_ok).':'.$as_hash.':'. &escape($selfenrollonly).':'.&escape($catfilter).':'. - $showhidden.':'.$caller,$tryserver); + $showhidden.':'.$caller.':'.&escape($cloner).':'. + &escape($cc_clone).':'.$cloneonly,$tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -2926,7 +3062,7 @@ sub courseiddump { for (my $i=0; $i<@responses; $i++) { $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); } - } + } } } } @@ -2966,10 +3102,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; @@ -3376,7 +3512,7 @@ sub tmpreset { if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_WRCREAT(),0640)) { - foreach my $key (keys %hash) { + foreach my $key (keys(%hash)) { if ($key=~ /:$symb/) { delete($hash{$key}); } @@ -3812,7 +3948,7 @@ sub set_userprivs { my $adv=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { - foreach my $role (keys %{$allroles}) { + foreach my $role (keys(%{$allroles})) { my ($trole,$area,$sec,$extendedarea); if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { $trole = $1; @@ -3855,6 +3991,101 @@ sub set_userprivs { return ($author,$adv); } +sub role_status { + my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; + my @pwhere = (); + if (exists($env{$rolekey}) && $env{$rolekey} ne '') { + (undef,undef,$$role,@pwhere)=split(/\./,$rolekey); + unless (!defined($$role) || $$role eq '') { + $$where=join('.',@pwhere); + $$trolecode=$$role.'.'.$$where; + ($$tstart,$$tend)=split(/\./,$env{$rolekey}); + $$tstatus='is'; + if ($$tstart && $$tstart>$then) { + $$tstatus='future'; + if ($$tstart && $$tstart>$refresh) { + if ($$tstart<$now) { + if (($$where ne '') && ($$role ne '')) { + my (%allroles,%allgroups,$group_privs); + my %userroles = ( + 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend + ); + my $spec=$$role.'.'.$$where; + my ($tdummy,$tdomain,$trest)=split(/\//,$$where); + if ($$role eq 'gr') { + my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, + $env{'user.name'})=@_; + my ($trole) = split('_',$role,1); + (undef,my $group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); + } + if ($$role =~ /^cr\//) { + &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); + } elsif ($$role eq 'gr') { + my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, + $env{'user.name'}); + my $trole = split('_',$rolehash{$$where.'_'.$$role},1); + (undef,my $group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); + &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); + } else { + &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); + } + my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups); + &appenv(\%userroles,[$$role,'cm']); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + $$tstatus = 'is'; + } + } + } + } + if ($$tend) { + if ($$tend<$then) { + $$tstatus='expired'; + } elsif ($$tend<$now) { + $$tstatus='will_not'; + } + } + } + } +} + +sub check_adhoc_privs { + my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_; + my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; + if ($env{$cckey}) { + my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); + &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); + unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } + } else { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } +} + +sub set_adhoc_privileges { +# role can be cc or ca + my ($dcdom,$pickedcourse,$role) = @_; + my $area = '/'.$dcdom.'/'.$pickedcourse; + my $spec = $role.'.'.$area; + my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, + $env{'user.name'}); + my %ccrole = (); + &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); + my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); + &appenv(\%userroles,[$role,'cm']); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &appenv( {'request.role' => $spec, + 'request.role.domain' => $dcdom, + 'request.course.sec' => '' + } + ); + my $tadv=0; + if (&allowed('adv') eq 'F') { $tadv=1; } + &appenv({'request.role.adv' => $tadv}); +} + # --------------------------------------------------------------- get interface sub get { @@ -4464,6 +4695,7 @@ sub usertools_access { %tools = ( official => 1, unofficial => 1, + community => 1, ); } else { %tools = ( @@ -4496,7 +4728,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'}; } @@ -4911,7 +5143,7 @@ sub allowed { my $envkey; if ($thisallowed=~/L/) { - foreach $envkey (keys %env) { + foreach $envkey (keys(%env)) { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; @@ -5202,7 +5434,7 @@ sub fetch_enrollment_query { } my $host=&hostname($homeserver); my $cmd = ''; - foreach my $affiliate (keys %{$affiliatesref}) { + foreach my $affiliate (keys(%{$affiliatesref})) { $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; @@ -5335,11 +5567,21 @@ sub auto_run { sub auto_get_sections { my ($cnum,$cdom,$inst_coursecode) = @_; - my $homeserver = &homeserver($cnum,$cdom); - my @secs = (); - my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); - unless ($response eq 'refused') { - @secs = split(/:/,$response); + my $homeserver; + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + if (!defined($homeserver)) { + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + } + my @secs; + if (defined($homeserver)) { + my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); + unless ($response eq 'refused') { + @secs = split(/:/,$response); + } } return @secs; } @@ -5358,6 +5600,23 @@ sub auto_validate_courseID { return $response; } +sub auto_validate_instcode { + my ($cnum,$cdom,$instcode,$owner) = @_; + my ($homeserver,$response); + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + if (!defined($homeserver)) { + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + } + my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. + &escape($instcode).':'.&escape($owner),$homeserver)); + my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); + return ($outcome,$description); +} + sub auto_create_password { my ($cnum,$cdom,$authparam,$udom) = @_; my ($homeserver,$response); @@ -5472,6 +5731,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)); } @@ -5529,7 +5795,81 @@ sub auto_instcode_defaults { } return $response; -} +} + +sub auto_possible_instcodes { + my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_; + unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && + (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { + return; + } + my (@homeservers,$uhome); + if (defined(&domain($domain,'primary'))) { + $uhome=&domain($domain,'primary'); + push(@homeservers,&domain($domain,'primary')); + } else { + my %servers = &get_servers($domain,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } + } + } + my $response; + foreach my $server (@homeservers) { + $response=&reply('autopossibleinstcodes:'.$domain,$server); + next if ($response =~ /(con_lost|error|no_such_host|refused)/); + my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = + split(':',$response); + @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); + @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr)); + foreach my $item (split('&',$cat_title)) { + my ($name,$value)=split('=',$item); + $cat_titles->{&unescape($name)}=&thaw_unescape($value); + } + foreach my $item (split('&',$cat_order)) { + my ($name,$value)=split('=',$item); + $cat_orders->{&unescape($name)}=&thaw_unescape($value); + } + return 'ok'; + } + return $response; +} + +sub auto_courserequest_checks { + my ($dom) = @_; + 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,$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 { my ($cdom,$cnum,$owners,$inst_class) = @_; @@ -5697,8 +6037,8 @@ sub plaintext { } } my %rolenames = ( - Course => 'std', - Group => 'alt1', + Course => 'std', + Community => 'alt1', ); if (defined($type) && defined($rolenames{$type}) && @@ -5719,10 +6059,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\//) { @@ -5750,7 +6107,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'}); @@ -6074,28 +6442,32 @@ sub writecoursepref { sub createcourse { my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, - $course_owner,$crstype)=@_; + $course_owner,$crstype,$cnum,$context,$category)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { - return 'refused'; + if ($context eq 'requestcourses') { + unless (&usertools_access($course_owner,$udom,$category,undef,$context)) { + return 'refused'; + } + } else { + return 'refused'; + } } -# ------------------------------------------------------------------- Create ID - my $uname=int(1+rand(9)). - ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. - substr($$.time,0,5).unpack("H8",pack("I32",time)). - unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; -# ----------------------------------------------- Make sure that does not exist - my $uhome=&homeserver($uname,$udom,'true'); - unless (($uhome eq '') || ($uhome eq 'no_host')) { - $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). - unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; - $uhome=&homeserver($uname,$udom,'true'); - unless (($uhome eq '') || ($uhome eq 'no_host')) { - return 'error: unable to generate unique course-ID'; - } - } -# ------------------------------------------------ Check supplied server name +# --------------------------------------------------------------- Get Unique ID + my $uname; + if ($cnum =~ /^$match_courseid$/) { + my $chome=&homeserver($cnum,$udom,'true'); + if (($chome eq '') || ($chome eq 'no_host')) { + $uname = $cnum; + } else { + $uname = &generate_coursenum($udom); + } + } else { + $uname = &generate_coursenum($udom); + } + return $uname if ($uname =~ /^error/); +# -------------------------------------------------- Check supplied server name $course_server = $env{'user.homeserver'} if (! defined($course_server)); if (! &is_library($course_server)) { return 'error:bad server name '.$course_server; @@ -6104,7 +6476,7 @@ sub createcourse { my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom,'true'); + my $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } @@ -6145,6 +6517,30 @@ ENDINITMAP return '/'.$udom.'/'.$uname; } +# ------------------------------------------------------------------- Create ID +sub generate_coursenum { + my ($udom) = @_; + my $domdesc = &domain($udom); + return 'error: invalid domain' if ($domdesc eq ''); + my $uname=int(1+rand(9)). + ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. + substr($$.time,0,5).unpack("H8",pack("I32",time)). + unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; +# ----------------------------------------------- Make sure that does not exist + my $uhome=&homeserver($uname,$udom,'true'); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + $uname=int(1+rand(9)). + ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. + substr($$.time,0,5).unpack("H8",pack("I32",time)). + unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; + $uhome=&homeserver($uname,$udom,'true'); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: unable to generate unique course-ID'; + } + } + return $uname; +} + sub is_course { my ($cdom,$cnum) = @_; my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, @@ -6155,6 +6551,39 @@ sub is_course { return 0; } +sub store_userdata { + my ($storehash,$datakey,$namespace,$udom,$uname) = @_; + my $result; + if ($datakey ne '') { + if (ref($storehash) eq 'HASH') { + 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 { + $storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; + $storehash->{'host'} = $perlvar{'lonHostID'}; + + my $namevalue=''; + foreach my $key (keys(%{$storehash})) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; + } + $namevalue=~s/\&$//; + $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:". + "$namespace:$datakey:$namevalue",$uhome); + } + } else { + $result = 'error: data to store was not a hash reference'; + } + } else { + $result= 'error: invalid requestkey'; + } + return $result; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { @@ -7644,6 +8073,11 @@ sub devalidate_title_cache { &devalidate_cache_new('title',$key); } +# ------------------------------------------------- Get the title of a course + +sub current_course_title { + return $env{ 'course.' . $env{'request.course.id'} . '.description' }; +} # ------------------------------------------------- Get the title of a resource sub gettitle { @@ -7710,7 +8144,7 @@ sub symblist { if (($env{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { - foreach my $url (keys %newhash) { + foreach my $url (keys(%newhash)) { next if ($url eq 'last_known' && $env{'form.no_update_last_known'}); $hash{declutter($url)}=&encode_symb($mapname, @@ -9048,23 +9482,31 @@ sub get_dns { return %iphost; } -} -# -# Given a DNS returns the loncapa host name for that DNS -# -sub host_from_dns { - my ($dns) = @_; - my @hosts; - my $ip; - - $ip = gethostbyname($dns); # Initial translation to IP is in net order. - if (length($ip) == 4) { - $ip = &IO::Socket::inet_ntoa($ip); - @hosts = get_hosts_from_ip($ip); - return $hosts[0]; + # + # Given a DNS returns the loncapa host name for that DNS + # + sub host_from_dns { + my ($dns) = @_; + my @hosts; + my $ip; + + if (exists($name_to_ip{$dns})) { + $ip = $name_to_ip{$dns}; + } + if (!$ip) { + $ip = gethostbyname($dns); # Initial translation to IP is in net order. + if (length($ip) == 4) { + $ip = &IO::Socket::inet_ntoa($ip); + } + } + if ($ip) { + @hosts = get_hosts_from_ip($ip); + return $hosts[0]; + } + return undef; } - return undef; + } BEGIN { @@ -9449,7 +9891,7 @@ and course level plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash (rolesplain.tab); plain text explanation of a user role term. -$type is Course (default) or Group. +$type is Course (default) or Community. If $forcedefault evaluates to true, text returned will be default text for $type. Otherwise, if this is a course, the text returned will be a custom name for the role (if defined in the course's @@ -9659,7 +10101,11 @@ database) for a course =item * -createcourse($udom,$description,$url) : make/modify course +createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course + +=item * + +generate_coursenum($udom) : get a unique (unused) course number in domain $udom =back