--- loncom/lonnet/perl/lonnet.pm 2016/03/02 18:23:17 1.1302 +++ loncom/lonnet/perl/lonnet.pm 2016/07/25 19:50:44 1.1315 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1302 2016/03/02 18:23:17 raeburn Exp $ +# $Id: lonnet.pm,v 1.1315 2016/07/25 19:50:44 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -229,6 +229,46 @@ sub get_server_distarch { return; } +sub get_servercerts_info { + my ($lonhost,$context) = @_; + my ($rep,$uselocal); + if (grep { $_ eq $lonhost } ¤t_machine_ids()) { + $uselocal = 1; + } + if (($context ne 'cgi') || $uselocal) { + my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; + if ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { + if ($1 < 6) { + $uselocal = 0; + } + } + } + if ($uselocal) { + $rep = LONCAPA::Lond::server_certs(\%perlvar); + } else { + $rep=&reply('servercerts',$lonhost); + } + my ($result,%returnhash); + if (defined($lonhost)) { + if (!defined(&hostname($lonhost))) { + return; + } + } + if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || + ($rep eq 'unknown_cmd')) { + $result = $rep; + } else { + $result = 'ok'; + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + my $what = &unescape($key); + $returnhash{$what}=&thaw_unescape($value); + } + } + return ($result,\%returnhash); +} + sub get_server_loncaparev { my ($dom,$lonhost,$ignore_cache,$caller) = @_; if (defined($lonhost)) { @@ -1288,7 +1328,7 @@ sub check_loadbalancing { my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); my $intdom = &Apache::lonnet::internet_dom($lonhost); my $serverhomedom = &host_domain($lonhost); - + my $domneedscache; my $cachetime = 60*60*24; if (($uintdom ne '') && ($uintdom eq $intdom)) { @@ -1303,6 +1343,8 @@ sub check_loadbalancing { &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); + } else { + $domneedscache = $dom_in_use; } } if (ref($result) eq 'HASH') { @@ -1361,7 +1403,9 @@ sub check_loadbalancing { my %domconfig = &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { - $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); + $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); + } else { + $domneedscache = $serverhomedom; } } if (ref($result) eq 'HASH') { @@ -1381,12 +1425,21 @@ sub check_loadbalancing { $is_balancer = 1; $offloadto = &this_host_spares($dom_in_use); } + unless (defined($cached)) { + $domneedscache = $serverhomedom; + } } } else { if ($perlvar{'lonBalancer'} eq 'yes') { $is_balancer = 1; $offloadto = &this_host_spares($dom_in_use); } + unless (defined($cached)) { + $domneedscache = $serverhomedom; + } + } + if ($domneedscache) { + &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); } if ($is_balancer) { my $lowest_load = 30000; @@ -1895,7 +1948,7 @@ sub retrieve_inst_usertypes { sub is_domainimage { my ($url) = @_; - if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { + if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) { if (&domain($1) ne '') { return '1'; } @@ -2189,8 +2242,8 @@ sub get_domain_defaults { 'requestcourses','inststatus', 'coursedefaults','usersessions', 'requestauthor','selfenrollment', - 'coursecategories'],$domain); - my @coursetypes = ('official','unofficial','community','textbook'); + 'coursecategories','ssl','autoenroll'],$domain); + my @coursetypes = ('official','unofficial','community','textbook','placement'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -2220,7 +2273,7 @@ sub get_domain_defaults { } } if (ref($domconfig{'requestcourses'}) eq 'HASH') { - foreach my $item ('official','unofficial','community','textbook') { + foreach my $item ('official','unofficial','community','textbook','placement') { $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; } } @@ -2315,10 +2368,37 @@ sub get_domain_defaults { $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; } } + if (ref($domconfig{'ssl'}) eq 'HASH') { + if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { + $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; + } + if (ref($domconfig{'ssl'}{'connect'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connect'}; + } + } + if (ref($domconfig{'autoenroll'}) eq 'HASH') { + $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; + } &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; } +sub course_portal_url { + my ($cnum,$cdom) = @_; + my $chome = &homeserver($cnum,$cdom); + my $hostname = &hostname($chome); + my $protocol = $protocol{$chome}; + $protocol = 'http' if ($protocol ne 'https'); + my %domdefaults = &get_domain_defaults($cdom); + my $firsturl; + if ($domdefaults{'portal_def'}) { + $firsturl = $domdefaults{'portal_def'}; + } else { + $firsturl = $protocol.'://'.$hostname; + } + return $firsturl; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -4633,9 +4713,10 @@ my %cachedtimes=(); my $cachedtime=''; sub load_all_first_access { - my ($uname,$udom)=@_; + my ($uname,$udom,$ignorecache)=@_; if (($cachedkey eq $uname.':'.$udom) && - (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) { + (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && + (!$ignorecache)) { return; } $cachedtime=time; @@ -4644,7 +4725,7 @@ sub load_all_first_access { } sub get_first_access { - my ($type,$argsymb,$argmap)=@_; + my ($type,$argsymb,$argmap,$ignorecache)=@_; my ($symb,$courseid,$udom,$uname)=&whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); @@ -4656,7 +4737,7 @@ sub get_first_access { } else { $res=$symb; } - &load_all_first_access($uname,$udom); + &load_all_first_access($uname,$udom,$ignorecache); return $cachedtimes{"$courseid\0$res"}; } @@ -6530,6 +6611,7 @@ sub usertools_access { unofficial => 1, community => 1, textbook => 1, + placement => 1, ); } elsif ($context eq 'requestauthor') { %tools = ( @@ -7263,7 +7345,7 @@ sub allowed { my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $env{'request.course.id'}); @@ -7273,7 +7355,7 @@ sub allowed { if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $env{'request.course.id'}); @@ -7352,6 +7434,15 @@ sub constructaccess { $ownerhome = &homeserver($ownername,$ownerdomain); return ($ownername,$ownerdomain,$ownerhome); } + if ($env{'request.course.id'}) { + if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) && + ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) { + if (&allowed('mdc',$env{'request.course.id'})) { + $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'}; + return ($ownername,$ownerdomain,$ownerhome); + } + } + } } # We don't have any access right now. If we are not possibly going to do anything about this, @@ -7504,8 +7595,8 @@ sub get_commblock_resources { } } } - if ($interval[0] =~ /^\d+/) { - my ($timelimit) = split(/_/,$interval[0]); + if ($interval[0] =~ /^(\d+)/) { + my $timelimit = $1; my $first_access; if ($type eq 'resource') { $first_access=&get_first_access($interval[1],$item); @@ -8277,6 +8368,33 @@ sub auto_crsreq_update { return \%crsreqresponse; } +sub auto_export_grades { + my ($cdom,$cnum,$inforef,$gradesref) = @_; + my ($homeserver,%exportresponse); + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + unless (($homeserver eq 'no_host') || ($homeserver eq '')) { + my $info; + if (ref($inforef) eq 'HASH') { + $info = &freeze_escape($inforef); + } + if (ref($gradesref) eq 'HASH') { + my $grades = &freeze_escape($gradesref); + my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'. + $info.':'.$grades,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) { + my @items = split(/&/,$response); + foreach my $item (@items) { + my ($key,$value) = split('=',$item); + $exportresponse{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + return \%exportresponse; +} + sub check_instcode_cloning { my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { @@ -8498,6 +8616,7 @@ sub plaintext { my %rolenames = ( Course => 'std', Community => 'alt1', + Placement => 'std', ); if ($cid ne '') { if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') { @@ -9020,7 +9139,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, - $selfenroll,$context,$inststatus,$credits)=@_; + $selfenroll,$context,$inststatus,$credits,$instsec)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -9036,13 +9155,13 @@ sub modifystudent { $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, $gene,$usec,$end,$start,$type,$locktype, - $cid,$selfenroll,$context,$credits); + $cid,$selfenroll,$context,$credits,$instsec); return $reply; } sub modify_student_enrollment { my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, - $locktype,$cid,$selfenroll,$context,$credits) = @_; + $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -9089,7 +9208,7 @@ sub modify_student_enrollment { my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); my $reply=cput('classlist', {$user => - join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) }, + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, $cdom,$cnum); if (($reply eq 'ok') || ($reply eq 'delayed')) { &devalidate_getsection_cache($udom,$uname,$cid); @@ -10148,6 +10267,115 @@ sub stat_file { return (); } +# --------------------------------------------------------- recursedirs +# Recursive function to traverse either a specific user's Authoring Space +# or corresponding Published Resource Space, and populate the hash ref: +# $dirhashref with URLs of all directories, and if $filehashref hash +# ref arg is provided, the URLs of any files, excluding versioned, .meta, +# or .rights files in resource space, and .meta, .save, .log, and .bak +# files in Authoring Space. +# +# Inputs: +# +# $is_home - true if current server is home server for user's space +# $context - either: priv, or res respectively for Authoring or Resource Space. +# $docroot - Document root (i.e., /home/httpd/html +# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname +# $relpath - Current path (relative to top level). +# $dirhashref - reference to hash to populate with URLs of directories (Required) +# $filehashref - reference to hash to populate with URLs of files (Optional) +# +# Returns: nothing +# +# Side Effects: populates $dirhashref, and $filehashref (if provided). +# +# Currently used by interface/londocs.pm to create linked select boxes for +# directory and filename to import a Course "Author" resource into a course, and +# also to create linked select boxes for Authoring Space and Directory to choose +# save location for creation of a new "standard" problem from the Course Editor. +# + +sub recursedirs { + my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_; + return unless (ref($dirhashref) eq 'HASH'); + my $currpath = $docroot.$toppath; + if ($relpath) { + $currpath .= "/$relpath"; + } + my $savefile; + if (ref($filehashref)) { + $savefile = 1; + } + if ($is_home) { + if (opendir(my $dirh,$currpath)) { + foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) { + next if ($item eq ''); + if (-d "$currpath/$item") { + my $newpath; + if ($relpath) { + $newpath = "$relpath/$item"; + } else { + $newpath = $item; + } + $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; + &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); + } elsif ($savefile) { + if ($context eq 'priv') { + unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { + $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; + } + } else { + unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) { + $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; + } + } + } + } + closedir($dirh); + } + } else { + my ($dirlistref,$listerror) = + &dirlist($toppath.$relpath); + my @dir_lines; + my $dirptr=16384; + if (ref($dirlistref) eq 'ARRAY') { + foreach my $dir_line (sort + { + my ($afile)=split('&',$a,2); + my ($bfile)=split('&',$b,2); + return (lc($afile) cmp lc($bfile)); + } (@{$dirlistref})) { + my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) = + split(/\&/,$dir_line,16); + $item =~ s/\s+$//; + next if (($item =~ /^\.\.?$/) || ($obs)); + if ($dirptr&$testdir) { + my $newpath; + if ($relpath) { + $newpath = "$relpath/$item"; + } else { + $relpath = '/'; + $newpath = $item; + } + $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; + &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); + } elsif ($savefile) { + if ($context eq 'priv') { + unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { + $filehashref->{$relpath}{$item} = 1; + } + } else { + unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) { + $filehashref->{$relpath}{$item} = 1; + } + } + } + } + } + } + return; +} + # -------------------------------------------------------- Value of a Condition # gets the value of a specific preevaluated condition @@ -10311,7 +10539,7 @@ sub get_userresdata { # Parameters: # $name - Course/user name. # $domain - Name of the domain the user/course is registered on. -# $type - Type of thing $name is (must be 'course' or 'user' +# $type - Type of thing $name is (must be 'course' or 'user') # $mapp - decluttered URL of enclosing map # $recursed - Ref to scalar -- set to 1, if nested maps have been recursed. # $recurseup - Ref to array of map URLs, starting with map containing @@ -13084,10 +13312,17 @@ BEGIN { my $name = $token->[2]{'name'}; my $value = $token->[2]{'value'}; my $valuematch = $token->[2]{'valuematch'}; - if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) { + my $namematch = $token->[2]{'namematch'}; + if ($item eq 'parameter') { + if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) { + my $release = $parser->get_text(); + $release =~ s/(^\s*|\s*$ )//gx; + $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release; + } + } elsif ($item ne '' && $name ne '') { my $release = $parser->get_text(); $release =~ s/(^\s*|\s*$ )//gx; - $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release; + $needsrelease{$item.':'.$name.':'.$value} = $release; } } } @@ -13679,6 +13914,8 @@ Inputs: =item $credits, number of credits student will earn from this class +=item $instsec, institutional course section code for student + =back @@ -14147,7 +14384,7 @@ requestcourses: ability to request cours =over =item -official, unofficial, community, textbook +official, unofficial, community, textbook, placement =back @@ -14169,7 +14406,7 @@ for course's uploaded content. =item canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, -communityquota, textbookquota +communityquota, textbookquota, placementquota =back