--- loncom/interface/loncommon.pm 2018/07/04 13:44:16 1.1319 +++ loncom/interface/loncommon.pm 2022/01/15 20:21:06 1.1374 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1319 2018/07/04 13:44:16 raeburn Exp $ +# $Id: loncommon.pm,v 1.1374 2022/01/15 20:21:06 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -72,6 +72,7 @@ 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(); @@ -79,7 +80,6 @@ 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; @@ -435,7 +435,7 @@ sub studentbrowser_javascript { OFFLOAD - } } } } @@ -8586,7 +8943,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 '') { @@ -8705,6 +9063,9 @@ $args - additional optional args support 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 @@ -8717,7 +9078,7 @@ sub start_page { #&Apache::lonnet::logthis("start_page ".join(':',caller(0))); $env{'internal.start_page'}++; - my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu); + my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu,$menucoll,%menu); if (! exists($args->{'skip_phases'}{'head'}) ) { $result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args); @@ -8752,8 +9113,47 @@ sub start_page { ($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'}, @@ -8766,7 +9166,7 @@ sub start_page { $args->{'only_body'}, $args->{'domain'}, $args->{'force_register'}, $args->{'no_nav_bar'}, $args->{'bgcolor'}, $args, - \@advtools,$ltiscope,$ltiuri,\%ltimenu); + \@advtools,$ltiscope,$ltiuri,\%ltimenu,$menucoll,\%menu); } } @@ -8852,6 +9252,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) = 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'); @@ -8960,7 +9465,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'}). @@ -8969,12 +9474,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.""; } @@ -10849,11 +11354,15 @@ sub sorted_inst_types { } sub get_institutional_codes { - my ($settings,$allcourses,$LC_code) = @_; + my ($cdom,$crs,$settings,$allcourses,$LC_code) = @_; # Get complete list of course sections to update my @currsections = (); my @currxlists = (); + my (%unclutteredsec,%unclutteredlcsec); my $coursecode = $$settings{'internal.coursecode'}; + my $crskey = $crs.':'.$coursecode; + @{$unclutteredsec{$crskey}} = (); + @{$unclutteredlcsec{$crskey}} = (); if ($$settings{'internal.sectionnums'} ne '') { @currsections = split(/,/,$$settings{'internal.sectionnums'}); @@ -10864,8 +11373,8 @@ sub get_institutional_codes { } if (@currxlists > 0) { - foreach (@currxlists) { - if (m/^([^:]+):(\w*)$/) { + foreach my $xl (@currxlists) { + if ($xl =~ /^([^:]+):(\w*)$/) { unless (grep/^$1$/,@{$allcourses}) { push(@{$allcourses},$1); $$LC_code{$1} = $2; @@ -10873,15 +11382,28 @@ sub get_institutional_codes { } } } - + if (@currsections > 0) { - foreach (@currsections) { - if (m/^(\w+):(\w*)$/) { - my $sec = $coursecode.$1; + foreach my $sec (@currsections) { + if ($sec =~ m/^(\w+):(\w*)$/ ) { + my $instsec = $1; my $lc_sec = $2; - unless (grep/^$sec$/,@{$allcourses}) { + unless (grep/^\Q$instsec\E$/,@{$unclutteredsec{$crskey}}) { + push(@{$unclutteredsec{$crskey}},$instsec); + push(@{$unclutteredlcsec{$crskey}},$lc_sec); + } + } + } + } + + if (@{$unclutteredsec{$crskey}} > 0) { + my %formattedsec = &Apache::lonnet::auto_instsec_reformat($cdom,'clutter',\%unclutteredsec); + if ((ref($formattedsec{$crskey}) eq 'ARRAY') && (ref($unclutteredlcsec{$crskey}) eq 'ARRAY')) { + for (my $i=0; $i<@{$formattedsec{$crskey}}; $i++) { + my $sec = $coursecode.$formattedsec{$crskey}[$i]; + unless (grep/^\Q$sec\E$/,@{$allcourses}) { push(@{$allcourses},$sec); - $$LC_code{$sec} = $lc_sec; + $$LC_code{$sec} = $unclutteredlcsec{$crskey}[$i]; } } } @@ -13937,7 +14459,7 @@ sub load_tmp_file { sub valid_datatoken { my ($datatoken) = @_; - if ($datatoken =~ /^$match_username\_$match_domain\_enroll_$match_domain\_$match_courseid\_\d+_\d+$/) { + if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) { return $datatoken; } return; @@ -15093,6 +15615,8 @@ Inputs: from - Sender's email address +replyto - Reply-To email address + to - Email address of recipient subject - Subject of email @@ -15103,8 +15627,6 @@ cc_string - Carbon copy email ad bcc - Blind carbon copy email address -type - File type of attachment - attachment_path - Path of file to be attached file_name - Name of file to be attached @@ -15121,8 +15643,9 @@ attachment_text - The body of an attac ############################################################ sub mime_email { - my ($from, $to, $subject, $body, $cc_string, $bcc, $attachment_path, - $file_name, $attachment_text) = @_; + my ($from,$replyto,$to,$subject,$body,$cc_string,$bcc,$attachment_path, + $file_name,$attachment_text) = @_; + my $msg = MIME::Lite->new( From => $from, To => $to, @@ -15130,6 +15653,9 @@ sub mime_email { Type =>'TEXT', Data => $body, ); + if ($replyto ne '') { + $msg->add("Reply-To" => $replyto); + } if ($cc_string ne '') { $msg->add("Cc" => $cc_string); } @@ -15245,6 +15771,8 @@ jsarray (reference to array of categorie subcats (reference to hash of arrays containing all subcategories within each category, -recursive) +maxd (reference to hash used to hold max depth for all top-level categories). + Returns: nothing Side effects: populates trails and allitems hash references. @@ -15252,7 +15780,7 @@ Side effects: populates trails and allit =cut sub extract_categories { - my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_; + my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_; if (ref($categories) eq 'HASH') { &gather_categories($categories,$cats,$idx,$jsarray); if (ref($cats->[0]) eq 'ARRAY') { @@ -15280,12 +15808,15 @@ sub extract_categories { if (ref($subcats) eq 'HASH') { push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1'); } - &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats); + &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd); } } else { if (ref($subcats) eq 'HASH') { $subcats->{$item} = []; } + if (ref($maxd) eq 'HASH') { + $maxd->{$name} = 1; + } } } } @@ -15323,13 +15854,13 @@ Side effects: populates trails and allit =cut sub recurse_categories { - my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_; + my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_; my $shallower = $depth - 1; if (ref($cats->[$depth]{$category}) eq 'ARRAY') { for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) { my $name = $cats->[$depth]{$category}[$k]; my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower; - my $trailstr = join(' -> ',(@{$parents},$category)); + my $trailstr = join(' » ',(@{$parents},$category)); if ($allitems->{$item} eq '') { push(@{$trails},$trailstr); $allitems->{$item} = scalar(@{$trails})-1; @@ -15350,16 +15881,21 @@ sub recurse_categories { } } &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents, - $subcats); + $subcats,$maxd); pop(@{$parents}); } } else { my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower; - my $trailstr = join(' -> ',(@{$parents},$category)); + my $trailstr = join(' » ',(@{$parents},$category)); if ($allitems->{$item} eq '') { push(@{$trails},$trailstr); $allitems->{$item} = scalar(@{$trails})-1; } + if (ref($maxd) eq 'HASH') { + if ($depth > $maxd->{$parents->[0]}) { + $maxd->{$parents->[0]} = $depth; + } + } } return; } @@ -15391,8 +15927,8 @@ sub assign_categories_table { my ($cathash,$currcat,$type,$disabled) = @_; my $output; if (ref($cathash) eq 'HASH') { - my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth); - &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray); + my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth); + &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd); $maxdepth = scalar(@cats); if (@cats > 0) { my $itemcount = 0; @@ -15718,7 +16254,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') { @@ -15726,16 +16263,38 @@ 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'}) && @@ -15824,20 +16383,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; + $cnum,$category,$coderef,$callercontext,$user_lh) = @_; + my ($outcome,$msgref,$clonemsgref); my $linefeed = '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15846,18 +16419,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); } } @@ -15880,15 +16446,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); } # @@ -15897,23 +16468,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 @@ -15938,8 +16523,7 @@ sub construct_course { 'plc.users.denied', 'hidefromcat', 'checkforpriv', - 'categories', - 'internal.uniquecode'], + 'categories'], $$crsudom,$$crsunum); if ($args->{'textbook'}) { $cenv{'internal.textbook'} = $args->{'textbook'}; @@ -15954,6 +16538,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'}; } @@ -16180,12 +16767,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 @@ -16239,7 +16831,7 @@ sub construct_course { ('resourcedata',\%storecontent,$$crsudom,$$crsunum); } - return (1,$outcome); + return (1,$outcome,\@clonemsg); } sub make_unique_code { @@ -16410,6 +17002,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) = @_; @@ -16444,18 +17054,18 @@ sub init_user_environment { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - if ($ENV{'SERVER_PORT'} == 443) { + if (tie(my %oldenv,'GDBM_File',"$lonids/$filename", + &GDBM_READER(),0640)) { my $linkedfile; - if (tie(my %oldenv,'GDBM_File',"$lonids/$cookie.id", - &GDBM_READER(),0640)) { - if (exists($oldenv{'user.linkedenv'})) { - $linkedfile = $oldenv{'user.linkedenv'}; - } - untie(%oldenv); + if (exists($oldenv{'user.linkedenv'})) { + $linkedfile = $oldenv{'user.linkedenv'}; } - if (unlink($lonids.'/'.$filename)) { - if ($linkedfile =~ /^[a-f0-9]+_linked\.id$/) { - unlink($lonids.'/'.$linkedfile); + untie(%oldenv); + if (unlink("$lonids/$filename")) { + if ($linkedfile =~ /^[a-f0-9]+_linked$/) { + if (-l "$lonids/$linkedfile.id") { + unlink("$lonids/$linkedfile.id"); + } } } } else { @@ -16510,6 +17120,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, @@ -16528,7 +17139,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'}; @@ -17429,7 +18040,7 @@ sub needs_coursereinit { } if (($now-$env{'request.course.timechecked'})>$interval) { &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); - my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1); + my $blocked = &blocking_status('reinit',undef,$cnum,$cdom,undef,1); if ($blocked) { return (); } @@ -17456,7 +18067,7 @@ 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,%checkcrsrestypes); @@ -17504,10 +18115,24 @@ sub update_content_constraints { } 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)) { @@ -17534,7 +18159,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(); @@ -17668,10 +18293,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) { @@ -17687,9 +18312,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') { @@ -17701,7 +18326,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); @@ -17749,7 +18374,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); } @@ -17766,13 +18412,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; } @@ -17811,7 +18461,8 @@ sub check_captcha { sub create_recaptcha { my ($pubkey,$version) = @_; if ($version >= 2) { - return '
'; + return '
'. + '
'; } else { my $use_ssl; if ($ENV{'SERVER_PORT'} == 443) { @@ -17829,11 +18480,12 @@ sub create_recaptcha { sub check_recaptcha { my ($privkey,$version) = @_; my $captcha_chk; + my $ip = &Apache::lonnet::get_requestor_ip(); if ($version >= 2) { my %info = ( secret => $privkey, response => $env{'form.g-recaptcha-response'}, - remoteip => $ENV{'REMOTE_ADDR'}, + remoteip => $ip, ); my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify'); $request->content(join('&',map { @@ -17856,7 +18508,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'}, ); @@ -17908,11 +18560,14 @@ sub cleanup_html { # $context is the calling context -- roles, grades, contents, menu or flip. sub critical_redirect { 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',$cnum,$cdom,undef,1); + my $blocked = &blocking_status('alert',undef,$cnum,$cdom,undef,1); if ($blocked) { my $checkrole = "cm./$cdom/$cnum"; if ($env{'request.course.sec'} ne '') { @@ -17929,7 +18584,7 @@ sub critical_redirect { &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); @@ -17989,24 +18644,37 @@ sub des_decrypt { return $plaintext; } -sub make_short_symbs { +sub get_requested_shorturls { my ($cdom,$cnum,$navmap) = @_; return unless (ref($navmap)); - my ($numnew,@errors); + 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); - my %tocreate; 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); @@ -18014,9 +18682,11 @@ sub make_short_symbs { 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" => $env{'user.name'}. - ':'.$env{'user.domain'}, + "lock\0$now" => $lockuser, }; my $tries = 0; my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); @@ -18125,6 +18795,188 @@ sub shorten_symbs { 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__;