--- loncom/interface/loncommon.pm 2016/10/12 14:54:08 1.1257 +++ loncom/interface/loncommon.pm 2022/05/24 16:23:03 1.1378 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1257 2016/10/12 14:54:08 raeburn Exp $ +# $Id: loncommon.pm,v 1.1378 2022/05/24 16:23:03 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,6 +71,8 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); +use LONCAPA::LWPReq; +use HTTP::Request; use DateTime::TimeZone; use DateTime::Locale; use Encode(); @@ -78,11 +80,14 @@ use Text::Aspell; use Authen::Captcha; use Captcha::reCAPTCHA; use JSON::DWIW; -use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version use MIME::Lite; use MIME::Types; +use File::Copy(); +use File::Path(); +use String::CRC32(); +use Short::URL(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -198,7 +203,7 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,"<$langtabfile") ) { + if ( open(my $fh,'<',$langtabfile) ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -220,7 +225,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,"<$copyrightfile") ) { + if ( open (my $fh,'<',$copyrightfile) ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -234,7 +239,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,"<$sourcecopyrightfile") ) { + if ( open (my $fh,'<',$sourcecopyrightfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -248,7 +253,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,"<$designfile") ) { + if ( open (my $fh,'<',$designfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -262,12 +267,12 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,"<$categoryfile") ) { + if ( open (my $fh,'<',$categoryfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); my ($extension,$category)=(split(/\s+/,$line,2)); - push @{$category_extensions{lc($category)}},$extension; + push(@{$category_extensions{lc($category)}},$extension); } close($fh); } @@ -277,7 +282,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,"<$typesfile") ) { + if ( open (my $fh,'<',$typesfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -430,7 +435,7 @@ sub studentbrowser_javascript { OFFLOAD - } } } } @@ -8301,6 +9044,7 @@ OFFLOAD '; } + $result .= ''."\n"; return $result.''; } @@ -8369,7 +9113,8 @@ sub print_suppression { } my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - my $blocked = &blocking_status('printout',$cnum,$cdom,undef,1); + my $clientip = &Apache::lonnet::get_requestor_ip(); + my $blocked = &blocking_status('printout',$clientip,$cnum,$cdom,undef,1); if ($blocked) { my $checkrole = "cm./$cdom/$cnum"; if ($env{'request.course.sec'} ne '') { @@ -8480,8 +9225,17 @@ $args - additional optional args support no_auto_mt_title -> prevent &mt()ing the title arg bread_crumbs -> Array containing breadcrumbs bread_crumbs_component -> if exists show it as headline else show only the breadcrumbs + bread_crumbs_nomenu -> if true will pass false as the value of $menulink + to lonhtmlcommon::breadcrumbs group -> includes the current group, if page is for a - specific group + specific group + use_absolute -> for request for external resource or syllabus, this + will contain https:// if server uses + https (as per hosts.tab), but request is for http + hostname -> hostname, originally from $r->hostname(), (optional). + links_disabled -> Links in primary and secondary menus are disabled + (Can enable them once page has loaded - see lonroles.pm + for an example). =back @@ -8494,12 +9248,82 @@ sub start_page { #&Apache::lonnet::logthis("start_page ".join(':',caller(0))); $env{'internal.start_page'}++; - my ($result,@advtools); + my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu,$menucoll,%menu); if (! exists($args->{'skip_phases'}{'head'}) ) { $result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args); } - + + if (($env{'request.course.id'}) && ($env{'request.lti.login'})) { + if ($env{'course.'.$env{'request.course.id'}.'.lti.override'}) { + unless ($env{'course.'.$env{'request.course.id'}.'.lti.topmenu'}) { + $args->{'no_primary_menu'} = 1; + } + unless ($env{'course.'.$env{'request.course.id'}.'.lti.inlinemenu'}) { + $args->{'no_inline_menu'} = 1; + } + if ($env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}) { + map { $ltimenu{$_} = 1; } split(/,/,$env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}); + } + } else { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my %lti = &Apache::lonnet::get_domain_lti($cdom,'provider'); + if (ref($lti{$env{'request.lti.login'}}) eq 'HASH') { + unless ($lti{$env{'request.lti.login'}}{'topmenu'}) { + $args->{'no_primary_menu'} = 1; + } + unless ($lti{$env{'request.lti.login'}}{'inlinemenu'}) { + $args->{'no_inline_menu'} = 1; + } + if (ref($lti{$env{'request.lti.login'}}{'lcmenu'}) eq 'ARRAY') { + map { $ltimenu{$_} = 1; } @{$lti{$env{'request.lti.login'}}{'lcmenu'}}; + } + } + } + ($ltiscope,$ltiuri) = &LONCAPA::ltiutils::lti_provider_scope($env{'request.lti.uri'}, + $env{'course.'.$env{'request.course.id'}.'.domain'}, + $env{'course.'.$env{'request.course.id'}.'.num'}); + } elsif ($env{'request.course.id'}) { + my $expiretime=600; + if ((time-$env{'course.'.$env{'request.course.id'}.'.last_cache'}) > $expiretime) { + &Apache::lonnet::coursedescription($env{'request.course.id'},{'freshen_cache' => 1}); + } + my ($deeplinkmenu,$menuref); + ($menucoll,$deeplinkmenu,$menuref) = &menucoll_in_effect(); + if ($menucoll) { + if (ref($menuref) eq 'HASH') { + %menu = %{$menuref}; + } + if ($menu{'top'} eq 'n') { + $args->{'no_primary_menu'} = 1; + } + if ($menu{'inline'} eq 'n') { + unless (&Apache::lonnet::allowed('opa')) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $crstype = &course_type(); + my $now = time; + my $ccrole; + if ($crstype eq 'Community') { + $ccrole = 'co'; + } else { + $ccrole = 'cc'; + } + if ($env{'user.role.'.$ccrole.'./'.$cdom.'/'.$cnum}) { + my ($start,$end) = split(/\./,$env{'user.role.'.$ccrole.'./'.$cdom.'/'.$cnum}); + if ((($start) && ($start<0)) || + (($end) && ($end<$now)) || + (($start) && ($now<$start))) { + $args->{'no_inline_menu'} = 1; + } + } else { + $args->{'no_inline_menu'} = 1; + } + } + } + } + } + if (! exists($args->{'skip_phases'}{'body'}) ) { if ($args->{'frameset'}) { my $attr_string = &make_attr_string($args->{'force_register'}, @@ -8512,7 +9336,7 @@ sub start_page { $args->{'only_body'}, $args->{'domain'}, $args->{'force_register'}, $args->{'no_nav_bar'}, $args->{'bgcolor'}, $args, - \@advtools); + \@advtools,$ltiscope,$ltiuri,\%ltimenu,$menucoll,\%menu); } } @@ -8545,15 +9369,22 @@ sub start_page { if (@advtools > 0) { &Apache::lonmenu::advtools_crumbs(@advtools); } - + my $menulink; + # if arg: bread_crumbs_nomenu is true pass 0 as $menulink item. + if ((exists($args->{'bread_crumbs_nomenu'})) || + ($ltiscope eq 'map') || ($ltiscope eq 'resource') || + ((($args->{'crstype'} eq 'Placement') || (($env{'request.course.id'}) && + ($env{'course.'.$env{'request.course.id'}.'.type'} eq 'Placement'))) && + (!$env{'request.role.adv'}))) { + $menulink = 0; + } else { + undef($menulink); + } #if bread_crumbs_component exists show it as headline else show only the breadcrumbs if(exists($args->{'bread_crumbs_component'})){ - $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'}); - } elsif ($args->{'crstype'} eq 'Placement') { - $result .= &Apache::lonhtmlcommon::breadcrumbs('','','','','','','','','', - $args->{'crstype'}); + $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'},'',$menulink); } else { - $result .= &Apache::lonhtmlcommon::breadcrumbs(); + $result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink); } } return $result; @@ -8591,6 +9422,103 @@ sub end_page { return $result; } +sub menucoll_in_effect { + my ($menucoll,$deeplinkmenu,%menu); + if ($env{'request.course.id'}) { + $menucoll = $env{'course.'.$env{'request.course.id'}.'.menudefault'}; + if ($env{'request.deeplink.login'}) { + my ($deeplink_symb,$deeplink,$check_login_symb); + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + if ($env{'request.noversionuri'} =~ m{^/(res|uploaded)/}) { + if ($env{'request.noversionuri'} =~ /\.(page|sequence)$/) { + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $deeplink = $navmap->get_mapparam(undef, + &Apache::lonnet::declutter($env{'request.noversionuri'}), + '0.deeplink'); + } else { + $check_login_symb = 1; + } + } else { + my $symb = &Apache::lonnet::symbread(); + if ($symb) { + $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$symb); + } else { + $check_login_symb = 1; + } + } + } else { + $check_login_symb = 1; + } + if ($check_login_symb) { + $deeplink_symb = &deeplink_login_symb($cnum,$cdom); + if ($deeplink_symb =~ /\.(page|sequence)$/) { + my $mapname = &Apache::lonnet::deversion((&Apache::lonnet::decode_symb($deeplink_symb))[2]); + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $deeplink = $navmap->get_mapparam(undef,$mapname,'0.deeplink'); + } + } else { + $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$deeplink_symb); + } + } + if ($deeplink ne '') { + my ($state,$others,$listed,$scope,$protect,$display,$target) = split(/,/,$deeplink); + if ($display =~ /^\d+$/) { + $deeplinkmenu = 1; + $menucoll = $display; + } + } + } + if ($menucoll) { + %menu = &page_menu($env{'course.'.$env{'request.course.id'}.'.menucollections'},$menucoll); + } + } + return ($menucoll,$deeplinkmenu,\%menu); +} + +sub deeplink_login_symb { + my ($cnum,$cdom) = @_; + my $login_symb; + if ($env{'request.deeplink.login'}) { + $login_symb = &symb_from_tinyurl($env{'request.deeplink.login'},$cnum,$cdom); + } + return $login_symb; +} + +sub symb_from_tinyurl { + my ($url,$cnum,$cdom) = @_; + if ($url =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { + my $key = $1; + my ($tinyurl,$login); + my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key); + if (defined($cached)) { + $tinyurl = $result; + } else { + my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); + my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname); + if ($currtiny{$key} ne '') { + $tinyurl = $currtiny{$key}; + &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600); + } + } + if ($tinyurl ne '') { + my ($cnumreq,$symb) = split(/\&/,$tinyurl); + if (wantarray) { + return ($cnumreq,$symb); + } elsif ($cnumreq eq $cnum) { + return $symb; + } + } + } + if (wantarray) { + return (); + } else { + return; + } +} + sub wishlist_window { return(<<'ENDWISHLIST'); @@ -8699,7 +9635,7 @@ ENDADHOC } sub modal_adhoc_inner { - my ($funcname,$width,$height,$content)=@_; + my ($funcname,$width,$height,$content,$possmathjax)=@_; my $innerwidth=$width-20; $content=&js_ready( &start_page('Dialog',undef,{'only_body'=>1,'bgcolor'=>'#FFFFFF'}). @@ -8708,12 +9644,12 @@ sub modal_adhoc_inner { &end_scrollbox(). &end_page() ); - return &modal_adhoc_script($funcname,$width,$height,$content); + return &modal_adhoc_script($funcname,$width,$height,$content,$possmathjax); } sub modal_adhoc_window { - my ($funcname,$width,$height,$content,$linktext)=@_; - return &modal_adhoc_inner($funcname,$width,$height,$content). + my ($funcname,$width,$height,$content,$linktext,$possmathjax)=@_; + return &modal_adhoc_inner($funcname,$width,$height,$content,$possmathjax). "".$linktext.""; } @@ -8779,8 +9715,9 @@ sub end_togglebox { } sub LCprogressbar_script { - my ($id)=@_; - return(< // ENDPROGRESS + } else { + return(< +// + +ENDPROGRESS + } } sub LCprogressbarUpdate_script { return(< .ui-progressbar { position:relative; } +.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; } .pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; } @@ -8819,37 +9778,54 @@ my $LCidcnt; my $LCcurrentid; sub LCprogressbar { - my ($r)=(@_); + my ($r,$number_to_do,$preamble)=@_; $LClastpercent=0; $LCidcnt++; $LCcurrentid=$$.'_'.$LCidcnt; - my $starting=&mt('Starting'); - my $content=(< $starting ENDPROGBAR - &r_print($r,$content.&LCprogressbar_script($LCcurrentid)); + } else { + $starting=&mt('Loading...'); + $LClastpercent='false'; + $content=(< +
$starting
+ +ENDPROGBAR + } + &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do)); } sub LCprogressbarUpdate { - my ($r,$val,$text)=@_; - unless ($val) { - if ($LClastpercent) { - $val=$LClastpercent; - } else { - $val=0; - } + my ($r,$val,$text,$number_to_do)=@_; + if ($number_to_do) { + unless ($val) { + if ($LClastpercent) { + $val=$LClastpercent; + } else { + $val=0; + } + } + if ($val<0) { $val=0; } + if ($val>100) { $val=0; } + $LClastpercent=$val; + unless ($text) { $text=$val.'%'; } + } else { + $val = 'false'; } - if ($val<0) { $val=0; } - if ($val>100) { $val=0; } - $LClastpercent=$val; - unless ($text) { $text=$val.'%'; } $text=&js_ready($text); &r_print($r,< // ENDUPDATE @@ -9034,14 +10010,21 @@ function expand_div(caller) { sub simple_error_page { my ($r,$title,$msg,$args) = @_; + my %displayargs; if (ref($args) eq 'HASH') { if (!$args->{'no_auto_mt_msg'}) { $msg = &mt($msg); } + if ($args->{'only_body'}) { + $displayargs{'only_body'} = 1; + } + if ($args->{'no_nav_bar'}) { + $displayargs{'no_nav_bar'} = 1; + } } else { $msg = &mt($msg); } my $page = - &Apache::loncommon::start_page($title). + &Apache::loncommon::start_page($title,'',\%displayargs). '

'.$msg.'

'. &Apache::loncommon::end_page(); if (ref($r)) { @@ -9969,7 +10952,7 @@ sub get_secgrprole_info { } sub user_picker { - my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom) = @_; + my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom,$noinstd) = @_; my $currdom = $dom; my @alldoms = &Apache::lonnet::all_domains(); if (@alldoms == 1) { @@ -10034,10 +11017,21 @@ sub user_picker { &html_escape(\%html_lt); &js_escape(\%js_lt); my $domform; + my $allow_blank = 1; if ($fixeddom) { - $domform = &select_dom_form($currdom,'srchdomain',1,1,undef,[$currdom]); + $allow_blank = 0; + $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,[$currdom]); } else { - $domform = &select_dom_form($currdom,'srchdomain',1,1); + my $defdom = $env{'request.role.domain'}; + my ($trusted,$untrusted); + if (($context eq 'requestcrs') || ($context eq 'course')) { + ($trusted,$untrusted) = &Apache::lonnet::trusted_domains('enroll',$defdom); + } elsif ($context eq 'author') { + ($trusted,$untrusted) = &Apache::lonnet::trusted_domains('othcoau',$defdom); + } elsif ($context eq 'domain') { + ($trusted,$untrusted) = &Apache::lonnet::trusted_domains('domroles',$defdom); + } + $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,$trusted,$untrusted); } my $srchinsel = ' '.$parent_title.''. + $item.'"'.$checked.$disabled.' />'.$parent_title.''. ''; my $depth = 1; push(@path,$parent); - $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories); + $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled); pop(@path); $table .= ''; $itemcount ++; @@ -14904,12 +16177,15 @@ path - Array containing all categories b currcategories - reference to array of current categories assigned to the course +disabled - scalar (optional) contains disabled="disabled" if input elements are + to be readonly (e.g., Domain Helpdesk role viewing course settings). + Returns: $output (markup to be displayed). =cut sub assign_category_rows { - my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_; + my ($itemcount,$cats,$depth,$parent,$path,$currcategories,$disabled) = @_; my ($text,$name,$item,$chgstr); if (ref($cats) eq 'ARRAY') { my $maxdepth = scalar(@{$cats}); @@ -14932,12 +16208,12 @@ sub assign_category_rows { } $text .= ''. + $item.'"'.$checked.$disabled.' />'.$name.''. ''. ''; if (ref($path) eq 'ARRAY') { push(@{$path},$name); - $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories); + $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled); pop(@{$path}); } $text .= ''; @@ -15148,7 +16424,8 @@ sub check_clone { my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonemsg; + my $clonetitle; + my @clonemsg; my $can_clone = 0; my $lctype = lc($args->{'crstype'}); if ($lctype ne 'community') { @@ -15156,19 +16433,41 @@ sub check_clone { } if ($clonehome eq 'no_host') { if ($args->{'crstype'} eq 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.', + args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}], + })); } else { - $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); - } + push(@clonemsg,({ + mt => 'No new course created.', + args => [], + }, + { + mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.', + args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], + })); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); + $clonetitle = $clonedesc{'description'}; if ($args->{'crstype'} eq 'Community') { if ($clonedesc{'type'} ne 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); - return ($can_clone, $clonemsg, $cloneid, $clonehome); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.', + args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], + })); + return ($can_clone,\@clonemsg,$cloneid,$clonehome); } } - if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && + if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && (&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) { $can_clone = 1; } else { @@ -15254,19 +16553,34 @@ sub check_clone { } unless ($can_clone) { if ($args->{'crstype'} eq 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).', + args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], + })); } else { - $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + push(@clonemsg,({ + mt => 'No new course created.', + args => [], + }, + { + mt => 'The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).', + args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], + })); } } } } - return ($can_clone, $clonemsg, $cloneid, $clonehome); + return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle); } sub construct_course { - my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category,$coderef) = @_; - my $outcome; + my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, + $cnum,$category,$coderef,$callercontext,$user_lh) = @_; + my ($outcome,$msgref,$clonemsgref); my $linefeed = '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15275,18 +16589,11 @@ sub construct_course { # # Are we cloning? # - my ($can_clone, $clonemsg, $cloneid, $clonehome); + my ($can_clone,$cloneid,$clonehome,$clonetitle); if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); - if ($context ne 'auto') { - if ($clonemsg ne '') { - $clonemsg = ''.$clonemsg.''; - } - } - $outcome .= $clonemsg.$linefeed; - + ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); if (!$can_clone) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } } @@ -15309,15 +16616,20 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category); + $cnum,$context,$category, + $callercontext); # Note: The testing routines depend on this being output; see # Utils::Course. This needs to at least be output as a comment # if anyone ever decides to not show this, and Utils::Course::new # will need to be suitably modified. - $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + } else { + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + } if ($$courseid =~ /^error:/) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } # @@ -15326,23 +16638,37 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed; - return (0,$outcome); + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh, + 'Course creation failed, unrecognized course home server.'); + } else { + $outcome .= &mt('Course creation failed, unrecognized course home server.'); + } + $outcome .= $linefeed; + return (0,$outcome,$clonemsgref); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning # + my @clonemsg; if ($can_clone && $cloneid) { - $clonemsg = &mt('Cloning [_1] from [_2]',$showncrstype,$clonehome); - if ($context ne 'auto') { - $clonemsg = ''.$clonemsg.''; - } - $outcome .= $clonemsg.$linefeed; + push(@clonemsg, + { + mt => 'Created [_1] by cloning from [_2]', + args => [$showncrstype,$clonetitle], + }); my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); + my @info = + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, + $args->{'dateshift'},$args->{'crscode'}, + $args->{'ccuname'}.':'.$args->{'ccdomain'}, + $args->{'tinyurls'}); + if (@info) { + push(@clonemsg,@info); + } # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -15367,8 +16693,7 @@ sub construct_course { 'plc.users.denied', 'hidefromcat', 'checkforpriv', - 'categories', - 'internal.uniquecode'], + 'categories'], $$crsudom,$$crsunum); if ($args->{'textbook'}) { $cenv{'internal.textbook'} = $args->{'textbook'}; @@ -15383,6 +16708,9 @@ sub construct_course { if ($args->{'crstype'}) { $cenv{'type'}=$args->{'crstype'}; } + if ($args->{'lti'}) { + $cenv{'internal.lti'}=$args->{'lti'}; + } if ($args->{'crsid'}) { $cenv{'courseid'}=$args->{'crsid'}; } @@ -15418,7 +16746,7 @@ sub construct_course { my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'}); $cenv{'internal.sectionnums'} .= $item.','; unless ($addcheck eq 'ok') { - push @badclasses, $class; + push(@badclasses,$class); } } $cenv{'internal.sectionnums'} =~ s/,$//; @@ -15446,7 +16774,7 @@ sub construct_course { my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'}); $cenv{'internal.crosslistings'} .= $item.','; unless ($addcheck eq 'ok') { - push @badclasses, $xl; + push(@badclasses,$xl); } } $cenv{'internal.crosslistings'} =~ s/,$//; @@ -15481,27 +16809,28 @@ sub construct_course { } if (@badclasses > 0) { my %lt=&Apache::lonlocal::texthash( - 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course', - 'dnhr' => 'does not have rights to access enrollment in these classes', - 'adby' => 'as determined by the policies of your institution on access to official classlists' + 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course.', + 'howi' => 'However, if automated course roster updates are enabled for this class, these particular sections/crosslistings are not guaranteed to contribute towards enrollment.', + 'itis' => 'It is possible that rights to access enrollment for these classes will be available through assignment of co-owners.', ); - my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}. - ' ('.$lt{'adby'}.')'; + my $badclass_msg = $lt{'tclb'}.$linefeed.$lt{'howi'}.$linefeed. + &mt('That is because the user identified as the course owner ([_1]) does not have rights to access enrollment in these classes, as determined by the policies of your institution on access to official classlists',$cenv{'internal.courseowner'}).$linefeed.$lt{'itis'}; if ($context eq 'auto') { $outcome .= $badclass_msg.$linefeed; + } else { $outcome .= '
'.$badclass_msg.$linefeed.'
    '."\n"; - foreach my $item (@badclasses) { - if ($context eq 'auto') { - $outcome .= " - $item\n"; - } else { - $outcome .= "
  • $item
    • \n"; - } - } + } + foreach my $item (@badclasses) { if ($context eq 'auto') { - $outcome .= $linefeed; + $outcome .= " - $item\n"; } else { - $outcome .= "


\n"; + $outcome .= "
  • $item
    • \n"; } + } + if ($context eq 'auto') { + $outcome .= $linefeed; + } else { + $outcome .= "

    \n"; } } if ($args->{'no_end_date'}) { @@ -15608,12 +16937,17 @@ sub construct_course { # Open all assignments # if ($args->{'openall'}) { + my $opendate = time; + if ($args->{'openallfrom'} =~ /^\d+$/) { + $opendate = $args->{'openallfrom'}; + } my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate'; - my %storecontent = ($storeunder => time, + my %storecontent = ($storeunder => $opendate, $storeunder.'.type' => 'date_start'); - - $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput - ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; + $outcome .= &mt('All assignments open starting [_1]', + &Apache::lonlocal::locallocaltime($opendate)).': '. + &Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; } # # Set first page @@ -15667,7 +17001,7 @@ sub construct_course { ('resourcedata',\%storecontent,$$crsudom,$$crsunum); } - return (1,$outcome); + return (1,$outcome,\@clonemsg); } sub make_unique_code { @@ -15751,13 +17085,14 @@ sub group_term { } sub course_types { - my @types = ('official','unofficial','community','textbook','placement'); + my @types = ('official','unofficial','community','textbook','placement','lti'); my %typename = ( official => 'Official course', unofficial => 'Unofficial course', community => 'Community', textbook => 'Textbook course', placement => 'Placement test', + lti => 'LTI provider', ); return (\@types,\%typename); } @@ -15837,6 +17172,24 @@ sub compare_arrays { return @difference; } +sub lon_status_items { + my %defaults = ( + E => 100, + W => 4, + N => 1, + U => 5, + threshold => 200, + sysmail => 2500, + ); + my %names = ( + E => 'Errors', + W => 'Warnings', + N => 'Notices', + U => 'Unsent', + ); + return (\%defaults,\%names); +} + # -------------------------------------------------------- Initialize user login sub init_user_environment { my ($r, $username, $domain, $authhost, $form, $args) = @_; @@ -15844,8 +17197,6 @@ sub init_user_environment { my $public=($username eq 'public' && $domain eq 'public'); -# See if old ID present, if so, remove - my ($filename,$cookie,$userroles,$firstaccenv,$timerintenv); my $now=time; @@ -15867,12 +17218,29 @@ sub init_user_environment { } if (!$cookie) { $cookie="publicuser_$oldest"; } } else { - # if this isn't a robot, kill any existing non-robot sessions + # See if old ID present, if so, remove if this isn't a robot, + # killing any existing non-robot sessions if (!$args->{'robot'}) { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - unlink($lonids.'/'.$filename); + if (tie(my %oldenv,'GDBM_File',"$lonids/$filename", + &GDBM_READER(),0640)) { + my $linkedfile; + if (exists($oldenv{'user.linkedenv'})) { + $linkedfile = $oldenv{'user.linkedenv'}; + } + untie(%oldenv); + if (unlink("$lonids/$filename")) { + if ($linkedfile =~ /^[a-f0-9]+_linked$/) { + if (-l "$lonids/$linkedfile.id") { + unlink("$lonids/$linkedfile.id"); + } + } + } + } else { + unlink($lonids.'/'.$filename); + } } } closedir(DIR); @@ -15907,8 +17275,7 @@ sub init_user_environment { my %userenv = &Apache::lonnet::dump('environment',$domain,$username); my ($tmp) = keys(%userenv); - if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - } else { + if ($tmp =~ /^(con_lost|error|no_such_host)/i) { undef(%userenv); } if (($userenv{'interface'}) && (!$form->{'interface'})) { @@ -15923,6 +17290,7 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { + my $ip = &Apache::lonnet::get_requestor_ip($r); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -15941,7 +17309,7 @@ sub init_user_environment { "request.course.sec" => '', "request.role" => 'cm', "request.role.adv" => $env{'user.adv'}, - "request.host" => $ENV{'REMOTE_ADDR'},); + "request.host" => $ip,); if ($form->{'localpath'}) { $initial_env{"browser.localpath"} = $form->{'localpath'}; @@ -15960,39 +17328,75 @@ sub init_user_environment { $env{'user.noloadbalance'} = $lonhost; } - my %is_adv = ( is_adv => $env{'user.adv'} ); - my %domdef; - unless ($domain eq 'public') { - %domdef = &Apache::lonnet::get_domain_defaults($domain); + if ($form->{'noloadbalance'}) { + my @hosts = &Apache::lonnet::current_machine_ids(); + my $hosthere = $form->{'noloadbalance'}; + if (grep(/^\Q$hosthere\E$/,@hosts)) { + $initial_env{"user.noloadbalance"} = $hosthere; + $env{'user.noloadbalance'} = $hosthere; + } } - foreach my $tool ('aboutme','blog','webdav','portfolio') { - $userenv{'availabletools.'.$tool} = - &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', - undef,\%userenv,\%domdef,\%is_adv); - } + unless ($domain eq 'public') { + my %is_adv = ( is_adv => $env{'user.adv'} ); + my %domdef = &Apache::lonnet::get_domain_defaults($domain); - foreach my $crstype ('official','unofficial','community','textbook','placement') { - $userenv{'canrequest.'.$crstype} = - &Apache::lonnet::usertools_access($username,$domain,$crstype, - 'reload','requestcourses', - \%userenv,\%domdef,\%is_adv); - } + foreach my $tool ('aboutme','blog','webdav','portfolio') { + $userenv{'availabletools.'.$tool} = + &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', + undef,\%userenv,\%domdef,\%is_adv); + } - $userenv{'canrequest.author'} = - &Apache::lonnet::usertools_access($username,$domain,'requestauthor', - 'reload','requestauthor', - \%userenv,\%domdef,\%is_adv); - my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'], - $domain,$username); - my $reqstatus = $reqauthor{'author_status'}; - if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { - if (ref($reqauthor{'author'}) eq 'HASH') { - $userenv{'requestauthorqueued'} = $reqstatus.':'. - $reqauthor{'author'}{'timestamp'}; + foreach my $crstype ('official','unofficial','community','textbook','placement','lti') { + $userenv{'canrequest.'.$crstype} = + &Apache::lonnet::usertools_access($username,$domain,$crstype, + 'reload','requestcourses', + \%userenv,\%domdef,\%is_adv); } - } + $userenv{'canrequest.author'} = + &Apache::lonnet::usertools_access($username,$domain,'requestauthor', + 'reload','requestauthor', + \%userenv,\%domdef,\%is_adv); + my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'], + $domain,$username); + my $reqstatus = $reqauthor{'author_status'}; + if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { + if (ref($reqauthor{'author'}) eq 'HASH') { + $userenv{'requestauthorqueued'} = $reqstatus.':'. + $reqauthor{'author'}{'timestamp'}; + } + } + my ($types,$typename) = &course_types(); + if (ref($types) eq 'ARRAY') { + my @options = ('approval','validate','autolimit'); + my $optregex = join('|',@options); + my (%willtrust,%trustchecked); + foreach my $type (@{$types}) { + my $dom_str = $env{'environment.reqcrsotherdom.'.$type}; + if ($dom_str ne '') { + my $updatedstr = ''; + my @possdomains = split(',',$dom_str); + foreach my $entry (@possdomains) { + my ($extdom,$extopt) = split(':',$entry); + unless ($trustchecked{$extdom}) { + $willtrust{$extdom} = &Apache::lonnet::will_trust('reqcrs',$domain,$extdom); + $trustchecked{$extdom} = 1; + } + if ($willtrust{$extdom}) { + $updatedstr .= $entry.','; + } + } + $updatedstr =~ s/,$//; + if ($updatedstr) { + $userenv{'reqcrsotherdom.'.$type} = $updatedstr; + } else { + delete($userenv{'reqcrsotherdom.'.$type}); + } + } + } + } + } $env{'user.environment'} = "$lonids/$cookie.id"; if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id", @@ -16609,7 +18013,7 @@ sub search_courses { if (ref($courses{$cid}) eq 'HASH') { if (ref($courses{$cid}{roles}) eq 'ARRAY') { if (!grep(/^\Q$courserole\E$/,@{$courses{$cid}{roles}})) { - push (@{$courses{$cid}{roles}},$courserole); + push(@{$courses{$cid}{roles}},$courserole); } } else { $courses{$cid}{roles} = [$courserole]; @@ -16805,8 +18209,12 @@ sub needs_coursereinit { $interval = 600; } if (($now-$env{'request.course.timechecked'})>$interval) { - my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); + my $blocked = &blocking_status('reinit',undef,$cnum,$cdom,undef,1); + if ($blocked) { + return (); + } + my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); if ($lastchange > $env{'request.course.tied'}) { my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); if ($curr_reqd_hash{'internal.releaserequired'} ne '') { @@ -16829,22 +18237,34 @@ sub needs_coursereinit { } sub update_content_constraints { - my ($cdom,$cnum,$chome,$cid) = @_; + my ($cdom,$cnum,$chome,$cid,$keeporder) = @_; my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); - my %checkresponsetypes; + my (%checkresponsetypes,%checkcrsrestypes); foreach my $key (keys(%Apache::lonnet::needsrelease)) { my ($item,$name,$value) = split(/:/,$key); if ($item eq 'resourcetag') { if ($name eq 'responsetype') { $checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key} } + } elsif ($item eq 'course') { + if ($name eq 'courserestype') { + $checkcrsrestypes{$value} = $Apache::lonnet::needsrelease{$key}; + } } } my $navmap = Apache::lonnavmaps::navmap->new(); if (defined($navmap)) { - my %allresponses; - foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) { + my (%allresponses,%allcrsrestypes); + foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() || $_[0]->is_tool() },1,0)) { + if ($res->is_tool()) { + if ($allcrsrestypes{'exttool'}) { + $allcrsrestypes{'exttool'} ++; + } else { + $allcrsrestypes{'exttool'} = 1; + } + next; + } my %responses = $res->responseTypes(); foreach my $key (keys(%responses)) { next unless(exists($checkresponsetypes{$key})); @@ -16857,8 +18277,38 @@ sub update_content_constraints { ($reqdmajor,$reqdminor) = ($major,$minor); } } + foreach my $key (keys(%allcrsrestypes)) { + my ($major,$minor) = split(/\./,$checkcrsrestypes{$key}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } undef($navmap); } + my (@resources,@order,@resparms,@zombies); + if ($keeporder) { + use LONCAPA::map; + @resources = @LONCAPA::map::resources; + @order = @LONCAPA::map::order; + @resparms = @LONCAPA::map::resparms; + @zombies = @LONCAPA::map::zombies; + } + my $suppmap = 'supplemental.sequence'; + my ($suppcount,$supptools,$errors) = (0,0,0); + ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap, + $suppcount,$supptools,$errors); + if ($keeporder) { + @LONCAPA::map::resources = @resources; + @LONCAPA::map::order = @order; + @LONCAPA::map::resparms = @resparms; + @LONCAPA::map::zombies = @zombies; + } + if ($supptools) { + my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } unless (($reqdmajor eq '') && ($reqdminor eq '')) { &Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid); } @@ -16879,7 +18329,7 @@ sub allmaps_incourse { if ($lastchange > $env{'request.course.tied'}) { my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum"); unless ($ferr) { - &update_content_constraints($cdom,$cnum,$chome,$cid); + &update_content_constraints($cdom,$cnum,$chome,$cid,1); } } my $navmap = Apache::lonnavmaps::navmap->new(); @@ -16915,7 +18365,7 @@ sub parse_supplemental_title { } sub recurse_supplemental { - my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_; + my ($cnum,$cdom,$suppmap,$numfiles,$numexttools,$errors) = @_; if ($suppmap) { my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap); if ($fatal) { @@ -16926,8 +18376,12 @@ sub recurse_supplemental { my ($title,$src,$ext,$type,$status)=split(/\:/,$res); if (($src ne '') && ($status eq 'res')) { if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) { - ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors); + ($numfiles,$numexttools,$errors) = &recurse_supplemental($cnum,$cdom,$1, + $numfiles,$numexttools,$errors); } else { + if ($src =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { + $numexttools ++; + } $numfiles ++; } } @@ -16935,12 +18389,12 @@ sub recurse_supplemental { } } } - return ($numfiles,$errors); + return ($numfiles,$numexttools,$errors); } sub symb_to_docspath { - my ($symb) = @_; - return unless ($symb); + my ($symb,$navmapref) = @_; + return unless ($symb && ref($navmapref)); my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb); if ($resurl=~/\.(sequence|page)$/) { $mapurl=$resurl; @@ -16948,9 +18402,11 @@ sub symb_to_docspath { $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; } my $mapresobj; - my $navmap = Apache::lonnavmaps::navmap->new(); - if (ref($navmap)) { - $mapresobj = $navmap->getResourceByUrl($mapurl); + unless (ref($$navmapref)) { + $$navmapref = Apache::lonnavmaps::navmap->new(); + } + if (ref($$navmapref)) { + $mapresobj = $$navmapref->getResourceByUrl($mapurl); } $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; my $type=$2; @@ -16960,7 +18416,7 @@ sub symb_to_docspath { if ($pcslist ne '') { foreach my $pc (split(/,/,$pcslist)) { next if ($pc <= 1); - my $res = $navmap->getByMapPc($pc); + my $res = $$navmapref->getByMapPc($pc); if (ref($res)) { my $thisurl = $res->src(); $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; @@ -17007,10 +18463,10 @@ sub symb_to_docspath { } sub captcha_display { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($output,$error); my ($captcha,$pubkey,$privkey,$version) = - &get_captcha_config($context,$lonhost); + &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { @@ -17026,9 +18482,9 @@ sub captcha_display { } sub captcha_response { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost); + my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { @@ -17040,7 +18496,7 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$dom_in_effect) = @_; my ($captcha,$pubkey,$privkey,$version,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); @@ -17088,7 +18544,28 @@ sub get_captcha_config { } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') { $captcha = 'original'; } - } + } elsif ($context eq 'passwords') { + if ($dom_in_effect) { + my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect); + if ($passwdconf{'captcha'} eq 'recaptcha') { + if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') { + $pubkey = $passwdconf{'recaptchakeys'}{'public'}; + $privkey = $passwdconf{'recaptchakeys'}{'private'}; + } + if ($privkey && $pubkey) { + $captcha = 'recaptcha'; + $version = $passwdconf{'recaptchaversion'}; + if ($version ne '2') { + $version = 1; + } + } else { + $captcha = 'original'; + } + } elsif ($passwdconf{'captcha'} ne 'notused') { + $captcha = 'original'; + } + } + } return ($captcha,$pubkey,$privkey,$version); } @@ -17105,13 +18582,17 @@ sub create_captcha { if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') { $output = ''."\n". + ''. &mt('Type in the letters/numbers shown below').' '. ''. - '
    '. + '
    '. 'captcha'; last; } } + if ($output eq '') { + &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts."); + } return $output; } @@ -17150,7 +18631,8 @@ sub check_captcha { sub create_recaptcha { my ($pubkey,$version) = @_; if ($version >= 2) { - return '
    '; + return '
    '. + '
    '; } else { my $use_ssl; if ($ENV{'SERVER_PORT'} == 443) { @@ -17168,15 +18650,21 @@ sub create_recaptcha { sub check_recaptcha { my ($privkey,$version) = @_; my $captcha_chk; + my $ip = &Apache::lonnet::get_requestor_ip(); if ($version >= 2) { - my $ua = LWP::UserAgent->new; - $ua->timeout(10); my %info = ( secret => $privkey, response => $env{'form.g-recaptcha-response'}, - remoteip => $ENV{'REMOTE_ADDR'}, + remoteip => $ip, ); - my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info); + my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify'); + $request->content(join('&',map { + my $name = escape($_); + "$name=" . ( ref($info{$_}) eq 'ARRAY' + ? join("&$name=", map {escape($_) } @{$info{$_}}) + : &escape($info{$_}) ); + } keys(%info))); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10,1); if ($response->is_success) { my $data = JSON::DWIW->from_json($response->decoded_content); if (ref($data) eq 'HASH') { @@ -17190,7 +18678,7 @@ sub check_recaptcha { my $captcha_result = $captcha->check_answer( $privkey, - $ENV{'REMOTE_ADDR'}, + $ip, $env{'form.recaptcha_challenge_field'}, $env{'form.recaptcha_response_field'}, ); @@ -17239,15 +18727,34 @@ sub cleanup_html { # Checks for critical messages and returns a redirect url if one exists. # $interval indicates how often to check for messages. +# $context is the calling context -- roles, grades, contents, menu or flip. sub critical_redirect { - my ($interval) = @_; + my ($interval,$context) = @_; + unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { + return (); + } if ((time-$env{'user.criticalcheck.time'})>$interval) { + if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $blocked = &blocking_status('alert',undef,$cnum,$cdom,undef,1); + if ($blocked) { + my $checkrole = "cm./$cdom/$cnum"; + if ($env{'request.course.sec'} ne '') { + $checkrole .= "/$env{'request.course.sec'}"; + } + unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) && + ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) { + return; + } + } + } my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, $env{'user.name'}); &Apache::lonnet::appenv({'user.criticalcheck.time'=>time}); my $redirecturl; if ($what[0]) { - if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { + if (($what[0] ne 'con_lost') && ($what[0] ne 'no_such_host') && ($what[0]!~/^error\:/)) { $redirecturl='/adm/email?critical=display'; my $url=&Apache::lonnet::absolute_url().$redirecturl; return (1, $url); @@ -17307,6 +18814,339 @@ sub des_decrypt { return $plaintext; } +sub get_requested_shorturls { + my ($cdom,$cnum,$navmap) = @_; + return unless (ref($navmap)); + my ($numnew,$errors); + my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny'); + if (@toshorten) { + my (%maps,%resources,%titles); + &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles, + 'shorturls',$cdom,$cnum); + if (keys(%resources)) { + my %tocreate; + foreach my $item (sort {$a <=> $b} (@toshorten)) { + my $symb = $resources{$item}; + if ($symb) { + $tocreate{$cnum.'&'.$symb} = 1; + } + } + if (keys(%tocreate)) { + ($numnew,$errors) = &make_short_symbs($cdom,$cnum, + \%tocreate); + } + } + } + return ($numnew,$errors); +} + +sub make_short_symbs { + my ($cdom,$cnum,$tocreateref,$lockuser) = @_; + my ($numnew,@errors); + if (ref($tocreateref) eq 'HASH') { + my %tocreate = %{$tocreateref}; + if (keys(%tocreate)) { + my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum); + my $su = Short::URL->new(no_vowels => 1); + my $init = ''; + my (%newunique,%addcourse,%courseonly,%failed); + # get lock on tiny db + my $now = time; + if ($lockuser eq '') { + $lockuser = $env{'user.name'}.':'.$env{'user.domain'}; + } + my $lockhash = { + "lock\0$now" => $lockuser, + }; + my $tries = 0; + my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); + my ($code,$error); + while (($gotlock ne 'ok') && ($tries<3)) { + $tries ++; + sleep 1; + $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); + } + if ($gotlock eq 'ok') { + $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique, + \%addcourse,\%courseonly,\%failed); + if (keys(%failed)) { + my $numfailed = scalar(keys(%failed)); + push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed)); + } + if (keys(%newunique)) { + my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom); + if ($putres eq 'ok') { + $numnew = scalar(keys(%newunique)); + my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum); + unless ($newputres eq 'ok') { + push(@errors,&mt('error: could not store course look-up of short URLs')); + } + } else { + push(@errors,&mt('error: could not store unique six character URLs')); + } + } + my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom); + unless ($dellockres eq 'ok') { + push(@errors,&mt('error: could not release lockfile')); + } + } else { + push(@errors,&mt('error: could not obtain lockfile')); + } + if (keys(%courseonly)) { + my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum); + if ($result ne 'ok') { + push(@errors,&mt('error: could not update course look-up of short URLs')); + } + } + } + } + return ($numnew,\@errors); +} + +sub shorten_symbs { + my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_; + return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') && + (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') && + (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH')); + my (%possibles,%collisions); + foreach my $key (keys(%{$tocreate})) { + my $num = String::CRC32::crc32($key); + my $tiny = $su->encode($num,$init); + if ($tiny) { + $possibles{$tiny} = $key; + } + } + if (!$init) { + $init = 1; + } else { + $init ++; + } + if (keys(%possibles)) { + my @posstiny = keys(%possibles); + my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); + my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname); + if (keys(%currtiny)) { + foreach my $key (keys(%currtiny)) { + next if ($currtiny{$key} eq ''); + if ($currtiny{$key} eq $possibles{$key}) { + my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key}); + unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { + $courseonly->{$tsymb} = $key; + } + } else { + $collisions{$possibles{$key}} = 1; + } + delete($possibles{$key}); + } + } + foreach my $key (keys(%possibles)) { + $newunique->{$key} = $possibles{$key}; + my ($tcnum,$tsymb) = split(/\&/,$possibles{$key}); + unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { + $addcourse->{$tsymb} = $key; + } + } + } + if (keys(%collisions)) { + if ($init <5) { + if (!$init) { + $init = 1; + } else { + $init ++; + } + $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions, + $newunique,$addcourse,$courseonly,$failed); + } else { + foreach my $key (keys(%collisions)) { + $failed->{$key} = 1; + } + } + } + return $init; +} + +sub is_nonframeable { + my ($url,$absolute,$hostname,$ip,$nocache) = @_; + my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i); + return if (($remprotocol eq '') || ($remhost eq '')); + + $remprotocol = lc($remprotocol); + $remhost = lc($remhost); + my $remport = 80; + if ($remprotocol eq 'https') { + $remport = 443; + } + my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport); + if ($cached) { + unless ($nocache) { + if ($result) { + return 1; + } else { + return 0; + } + } + } + my $uselink; + my $request = new HTTP::Request('HEAD',$url); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5); + if ($response->is_success()) { + my $secpolicy = lc($response->header('content-security-policy')); + my $xframeop = lc($response->header('x-frame-options')); + $secpolicy =~ s/^\s+|\s+$//g; + $xframeop =~ s/^\s+|\s+$//g; + if (($secpolicy ne '') || ($xframeop ne '')) { + my $remotehost = $remprotocol.'://'.$remhost; + my ($origin,$protocol,$port); + if ($ENV{'SERVER_PORT'} =~/^\d+$/) { + $port = $ENV{'SERVER_PORT'}; + } else { + $port = 80; + } + if ($absolute eq '') { + $protocol = 'http:'; + if ($port == 443) { + $protocol = 'https:'; + } + $origin = $protocol.'//'.lc($hostname); + } else { + $origin = lc($absolute); + ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$}); + } + if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) { + my $framepolicy = $1; + $framepolicy =~ s/^\s+|\s+$//g; + my @policies = split(/\s+/,$framepolicy); + if (@policies) { + if (grep(/^\Q'none'\E$/,@policies)) { + $uselink = 1; + } else { + $uselink = 1; + if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) || + (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) || + (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) { + undef($uselink); + } + if ($uselink) { + if (grep(/^\Q'self'\E$/,@policies)) { + if (($origin ne '') && ($remotehost eq $origin)) { + undef($uselink); + } + } + } + if ($uselink) { + my @possok; + if ($ip ne '') { + push(@possok,$ip); + } + my $hoststr = ''; + foreach my $part (reverse(split(/\./,$hostname))) { + if ($hoststr eq '') { + $hoststr = $part; + } else { + $hoststr = "$part.$hoststr"; + } + if ($hoststr eq $hostname) { + push(@possok,$hostname); + } else { + push(@possok,"*.$hoststr"); + } + } + if (@possok) { + foreach my $poss (@possok) { + last if (!$uselink); + foreach my $policy (@policies) { + if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) { + undef($uselink); + last; + } + } + } + } + } + } + } + } elsif ($xframeop ne '') { + $uselink = 1; + my @policies = split(/\s*,\s*/,$xframeop); + if (@policies) { + unless (grep(/^deny$/,@policies)) { + if ($origin ne '') { + if (grep(/^sameorigin$/,@policies)) { + if ($remotehost eq $origin) { + undef($uselink); + } + } + if ($uselink) { + foreach my $policy (@policies) { + if ($policy =~ /^allow-from\s*(.+)$/) { + my $allowfrom = $1; + if (($allowfrom ne '') && ($allowfrom eq $origin)) { + undef($uselink); + last; + } + } + } + } + } + } + } + } + } + } + if ($nocache) { + if ($cached) { + my $devalidate; + if ($uselink && !$result) { + $devalidate = 1; + } elsif (!$uselink && $result) { + $devalidate = 1; + } + if ($devalidate) { + &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport); + } + } + } else { + if ($uselink) { + $result = 1; + } else { + $result = 0; + } + &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600); + } + return $uselink; +} + +sub page_menu { + my ($menucolls,$menunum) = @_; + my %menu; + foreach my $item (split(/;/,$menucolls)) { + my ($num,$value) = split(/\%/,$item); + if ($num eq $menunum) { + my @entries = split(/\&/,$value); + foreach my $entry (@entries) { + my ($name,$fields) = split(/=/,$entry); + if (($name eq 'top') || ($name eq 'inline') || ($name eq 'foot') || ($name eq 'main')) { + $menu{$name} = $fields; + } else { + my @shown; + if ($fields =~ /,/) { + @shown = split(/,/,$fields); + } else { + @shown = ($fields); + } + if (@shown) { + foreach my $field (@shown) { + next if ($field eq ''); + $menu{$field} = 1; + } + } + } + } + } + } + return %menu; +} + 1; __END__;