--- loncom/interface/loncommon.pm 2020/07/17 22:17:17 1.1075.2.127.2.11 +++ loncom/interface/loncommon.pm 2019/11/20 23:05:45 1.1075.2.140 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.127.2.11 2020/07/17 22:17:17 raeburn Exp $ +# $Id: loncommon.pm,v 1.1075.2.140 2019/11/20 23:05:45 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,6 +71,7 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); +use HTTP::Request; use DateTime::TimeZone; use DateTime::Locale; use Encode(); @@ -82,8 +83,6 @@ use Crypt::DES; use DynaLoader; # for Crypt::DES version use File::Copy(); use File::Path(); -use String::CRC32(); -use Short::URL(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -1405,7 +1404,7 @@ sub help_menu_js { &Apache::loncommon::start_page('Help Menu', undef, {'frameset' => 1, 'js_ready' => 1, - 'use_absolute' => $httphost, + 'use_absolute' => $httphost, 'add_entries' => { 'border' => '0', 'rows' => "110,*",},}); @@ -2264,7 +2263,11 @@ sub select_form { if ($onchange) { $onchange = ' onchange="'.$onchange.'"'; } - my $selectform = "\n"; my @keys; if (exists($hashref->{'select_form_order'})) { @keys=@{$hashref->{'select_form_order'}}; @@ -3168,6 +3171,79 @@ sub get_assignable_auth { return ($authnum,%can_assign); } +sub check_passwd_rules { + my ($domain,$plainpass) = @_; + my %passwdconf = &Apache::lonnet::get_passwdconf($domain); + my ($min,$max,@chars,@brokerule,$warning); + $min = $Apache::lonnet::passwdmin; + if (ref($passwdconf{'chars'}) eq 'ARRAY') { + if ($passwdconf{'min'} =~ /^\d+$/) { + if ($passwdconf{'min'} > $min) { + $min = $passwdconf{'min'}; + } + } + if ($passwdconf{'max'} =~ /^\d+$/) { + $max = $passwdconf{'max'}; + } + @chars = @{$passwdconf{'chars'}}; + } + if (($min) && (length($plainpass) < $min)) { + push(@brokerule,'min'); + } + if (($max) && (length($plainpass) > $max)) { + push(@brokerule,'max'); + } + if (@chars) { + my %rules; + map { $rules{$_} = 1; } @chars; + if ($rules{'uc'}) { + unless ($plainpass =~ /[A-Z]/) { + push(@brokerule,'uc'); + } + } + if ($rules{'lc'}) { + unless ($plainpass =~ /[a-z]/) { + push(@brokerule,'lc'); + } + } + if ($rules{'num'}) { + unless ($plainpass =~ /\d/) { + push(@brokerule,'num'); + } + } + if ($rules{'spec'}) { + unless ($plainpass =~ /[!"#$%&'()*+,\-.\/:;<=>?@[\\\]^_`{|}~]/) { + push(@brokerule,'spec'); + } + } + } + if (@brokerule) { + my %rulenames = &Apache::lonlocal::texthash( + uc => 'At least one upper case letter', + lc => 'At least one lower case letter', + num => 'At least one number', + spec => 'At least one non-alphanumeric', + ); + $rulenames{'uc'} .= ': ABCDEFGHIJKLMNOPQRSTUVWXYZ'; + $rulenames{'lc'} .= ': abcdefghijklmnopqrstuvwxyz'; + $rulenames{'num'} .= ': 0123456789'; + $rulenames{'spec'} .= ': !"\#$%&\'()*+,-./:;<=>?@[\]^_\`{|}~'; + $rulenames{'min'} = &mt('Minimum password length: [_1]',$min); + $rulenames{'max'} = &mt('Maximum password length: [_1]',$max); + $warning = &mt('Password did not satisfy the following:').''; + } + if (wantarray) { + return @brokerule; + } + return $warning; +} + ############################################################### ## Get Kerberos Defaults for Domain ## ############################################################### @@ -4616,8 +4692,7 @@ sub blockcheck { # boards, chat or groups, check for blocking in current course only. if (($activity eq 'boards' || $activity eq 'chat' || - $activity eq 'groups' || $activity eq 'printout' || - $activity eq 'reinit' || $activity eq 'alert') && + $activity eq 'groups' || $activity eq 'printout') && ($env{'request.course.id'})) { foreach my $key (keys(%live_courses)) { if ($key ne $env{'request.course.id'}) { @@ -4723,7 +4798,7 @@ sub blockcheck { ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E})); next if ($no_userblock); - # Retrieve blocking times and identity of locker for course + # Retrieve blocking times and identity of blocker for course # of specified user, unless user has 'evb' privilege. my ($start,$end,$trigger) = @@ -4928,10 +5003,6 @@ END_MYBLOCK $text = &mt('Printing Blocked'); } elsif ($activity eq 'passwd') { $text = &mt('Password Changing Blocked'); - } elsif ($activity eq 'alert') { - $text = &mt('Checking Critical Messages Blocked'); - } elsif ($activity eq 'reinit') { - $text = &mt('Checking Course Update Blocked'); } $output .= <<"END_BLOCK";
@@ -5001,87 +5072,6 @@ sub check_ip_acc { return $allowed; } -sub check_slotip_acc { - my ($acc,$clientip)=@_; - &Apache::lonxml::debug("acc is $acc"); - if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) { - return 1; - } - my $allowed; - my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'}; - - my $name; - my %access = ( - allowfrom => 1, - denyfrom => 0, - ); - my @allows; - my @denies; - foreach my $item (split(',',$acc)) { - $item =~ s/^\s*//; - $item =~ s/\s*$//; - my $pattern; - if ($item =~ /^\!(.+)$/) { - push(@denies,$1); - } else { - push(@allows,$item); - } - } - my $numdenies = scalar(@denies); - my $numallows = scalar(@allows); - my $count = 0; - foreach my $pattern (@denies,@allows) { - $count ++; - my $acctype = 'allowfrom'; - if ($count <= $numdenies) { - $acctype = 'denyfrom'; - } - if ($pattern =~ /\*$/) { - #35.8.* - $pattern=~s/\*//; - if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } - } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) { - #35.8.3.[34-56] - my $low=$2; - my $high=$3; - $pattern=$1; - if ($ip =~ /^\Q$pattern\E/) { - my $last=(split(/\./,$ip))[3]; - if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; } - } - } elsif ($pattern =~ /^\*/) { - #*.msu.edu - $pattern=~s/\*//; - if (!defined($name)) { - use Socket; - my $netaddr=inet_aton($ip); - ($name)=gethostbyaddr($netaddr,AF_INET); - } - if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; } - } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) { - #127.0.0.1 - if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } - } else { - #some.name.com - if (!defined($name)) { - use Socket; - my $netaddr=inet_aton($ip); - ($name)=gethostbyaddr($netaddr,AF_INET); - } - if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; } - } - if ($allowed =~ /^(0|1)$/) { last; } - } - if ($allowed eq '') { - if ($numdenies && !$numallows) { - $allowed = 1; - } else { - $allowed = 0; - } - } - return $allowed; -} - ############################################### =pod @@ -5478,6 +5468,10 @@ Inputs: =item * $args, optional argument valid values are no_auto_mt_title -> prevents &mt()ing the title arg + use_absolute -> for external resource or syllabus, this will + contain https:// if server uses + https (as per hosts.tab), but request is for http + hostname -> hostname, from $r->hostname(). =item * $advtoolsref, optional argument, ref to an array containing inlineremote items to be added in "Functions" menu below @@ -5503,6 +5497,7 @@ sub bodytag { } if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); } my $httphost = $args->{'use_absolute'}; + my $hostname = $args->{'hostname'}; $function = &get_users_function() if (!$function); my $img = &designparm($function.'.img',$domain); @@ -5591,7 +5586,7 @@ sub bodytag { &Apache::lonmenu::prepare_functions($env{'request.noversionuri'}, $forcereg,$args->{'group'}, $args->{'bread_crumbs'}, - $advtoolsref,'',\$forbodytag); + $advtoolsref,'','',\$forbodytag); unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') { $funclist = $forbodytag; } @@ -5637,17 +5632,19 @@ sub bodytag { $bodytag .= Apache::lonhtmlcommon::scripttag('', 'end'); if ($env{'request.state'} eq 'construct') { $bodytag .= &Apache::lonmenu::innerregister($forcereg, - $args->{'bread_crumbs'}); + $args->{'bread_crumbs'},'','',$hostname); } elsif ($forcereg) { $bodytag .= &Apache::lonmenu::innerregister($forcereg,undef, $args->{'group'}, - $args->{'hide_buttons'}); + $args->{'hide_buttons', + $hostname}); } else { my $forbodytag; &Apache::lonmenu::prepare_functions($env{'request.noversionuri'}, $forcereg,$args->{'group'}, $args->{'bread_crumbs'}, - $advtoolsref,'',\$forbodytag); + $advtoolsref,'',$hostname, + \$forbodytag); unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') { $bodytag .= $forbodytag; } @@ -6161,6 +6158,11 @@ td.LC_menubuttons_text { background: $tabbg; } +td.LC_zero_height { + line-height: 0; + cellpadding: 0; +} + table.LC_data_table { border: 1px solid #000000; border-collapse: separate; @@ -6751,7 +6753,8 @@ table.LC_prior_tries td { padding: 6px; } -.LC_answer_unknown { +.LC_answer_unknown, +.LC_answer_warning { background: orange; color: black; padding: 6px; @@ -6833,6 +6836,7 @@ table.LC_data_table tr > td.LC_docs_entr color: #990000; } +.LC_domprefs_email, .LC_docs_reinit_warn, .LC_docs_ext_edit { font-size: x-small; @@ -8173,6 +8177,10 @@ $args - additional optional args support to lonhtmlcommon::breadcrumbs group -> includes the current group, if page is for a 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). =back @@ -8478,8 +8486,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; } @@ -8518,37 +8549,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 @@ -12193,8 +12241,7 @@ sub process_decompression { if (ref($newdirlistref) eq 'ARRAY') { foreach my $dir_line (@{$newdirlistref}) { my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); - unless (($item =~ /^\.+$/) || ($item eq $file) || - ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) { + unless (($item =~ /^\.+$/) || ($item eq $file)) { push(@newitems,$item); if ($dirptr&$testdir) { $is_dir{$item} = 1; @@ -12782,7 +12829,7 @@ sub process_extracted_files { $newseqid{$i} = $newidx; unless ($errtext) { $result .= '
  • '.&mt('Folder: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')). + &HTML::Entities::encode($docstitle,'<>&"')).. '
    • '."\n"; } } @@ -12807,7 +12854,7 @@ sub process_extracted_files { $fetch =~ s/^\Q$prefix$dir\E//; $prompttofetch{$fetch} = 1; } - } + } } $LONCAPA::map::resources[$newidx]= $docstitle.':'.$url.':false:normal:res'; @@ -12907,11 +12954,11 @@ sub process_extracted_files { $result .= '
  • '.&mt('[_1] included as a dependency', &HTML::Entities::encode($showpath,'<>&"')). '
    • '."\n"; - } - unless ($ishome) { - my $fetch = "$fullpath/$title"; - $fetch =~ s/^\Q$prefix$dir\E//; - $prompttofetch{$fetch} = 1; + unless ($ishome) { + my $fetch = "$fullpath/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; + } } } } @@ -13198,9 +13245,10 @@ sub upfile_store { $env{'form.upfile'}=~s/\n+$//gs; my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. - '_enroll_'.$env{'request.course.id'}.'_'. + '_enroll_'.$env{'request.course.id'}.'_'. time.'_'.$$); return if ($datatoken eq ''); + { my $datafile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; @@ -14139,7 +14187,6 @@ $requdom domain of requester (if mailing $reqemail e-mail address of requester (if mailing type is helpdeskmail) - Returns: comma separated list of addresses to which to send e-mail. =back @@ -14281,7 +14328,6 @@ sub build_recipient_list { } elsif ($origmail ne '') { $lastresort = $origmail; } - if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) { unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) { my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; @@ -14467,6 +14513,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. @@ -14474,7 +14522,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') { @@ -14500,12 +14548,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; + } } } } @@ -14543,7 +14594,7 @@ 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++) { @@ -14570,16 +14621,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; } @@ -14611,8 +14667,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; @@ -14934,8 +14990,7 @@ sub check_clone { my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonetitle; - my @clonemsg; + my $clonemsg; my $can_clone = 0; my $lctype = lc($args->{'crstype'}); if ($lctype ne 'community') { @@ -14943,38 +14998,16 @@ sub check_clone { } if ($clonehome eq 'no_host') { if ($args->{'crstype'} eq 'Community') { - 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'}], - })); + $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'}); } else { - 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'}], - })); - } + $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'}); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); - $clonetitle = $clonedesc{'description'}; if ($args->{'crstype'} eq 'Community') { if ($clonedesc{'type'} ne 'Community') { - 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); + $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); } } if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && @@ -15063,34 +15096,20 @@ sub check_clone { } unless ($can_clone) { if ($args->{'crstype'} eq 'Community') { - 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'}], - })); + $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'}); } else { - 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'}], - })); - } + $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'}); + } } } } - return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle); + return ($can_clone, $clonemsg, $cloneid, $clonehome); } sub construct_course { my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, - $cnum,$category,$coderef,$callercontext,$user_lh) = @_; - my ($outcome,$msgref,$clonemsgref); + $cnum,$category,$coderef) = @_; + my $outcome; my $linefeed = '
    '."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15099,11 +15118,18 @@ sub construct_course { # # Are we cloning? # - my ($can_clone,$cloneid,$clonehome,$clonetitle); + my ($can_clone, $clonemsg, $cloneid, $clonehome); if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); + ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); + if ($context ne 'auto') { + if ($clonemsg ne '') { + $clonemsg = ''.$clonemsg.''; + } + } + $outcome .= $clonemsg.$linefeed; + if (!$can_clone) { - return (0,$outcome,$clonemsgref); + return (0,$outcome); } } @@ -15121,20 +15147,15 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category, - $callercontext); + $cnum,$context,$category); # 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. - if (($callercontext eq 'auto') && ($user_lh ne '')) { - $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - } else { - $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - } + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; if ($$courseid =~ /^error:/) { - return (0,$outcome,$clonemsgref); + return (0,$outcome); } # @@ -15143,37 +15164,23 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - 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('Course creation failed, unrecognized course home server.').$linefeed; + return (0,$outcome); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning # - my @clonemsg; if ($can_clone && $cloneid) { - push(@clonemsg, - { - mt => 'Created [_1] by cloning from [_2]', - args => [$crstype,$clonetitle], - }); + $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); + if ($context ne 'auto') { + $clonemsg = ''.$clonemsg.''; + } + $outcome .= $clonemsg.$linefeed; my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - my @info = - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, - $args->{'dateshift'},$args->{'crscode'}, - $args->{'ccuname'}.':'.$args->{'ccdomain'}, - $args->{'tinyurls'}); - if (@info) { - push(@clonemsg,@info); - } + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -15475,7 +15482,7 @@ sub construct_course { $outcome .= ($fatal?$errtext:'write ok').$linefeed; } - return (1,$outcome,\@clonemsg); + return (1,$outcome); } sub make_unique_code { @@ -15679,7 +15686,23 @@ sub init_user_environment { 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); @@ -15714,7 +15737,8 @@ 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) { + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + } else { undef(%userenv); } if (($userenv{'interface'}) && (!$form->{'interface'})) { @@ -16607,12 +16631,8 @@ sub needs_coursereinit { $interval = 600; } if (($now-$env{'request.course.timechecked'})>$interval) { - &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); - my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1); - if ($blocked) { - return (); - } my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); + &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); if ($lastchange > $env{'request.course.tied'}) { my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); if ($curr_reqd_hash{'internal.releaserequired'} ne '') { @@ -16815,10 +16835,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) { @@ -16834,9 +16854,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') { @@ -16848,7 +16868,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); @@ -16896,6 +16916,27 @@ 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); } @@ -17047,25 +17088,9 @@ 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,$context) = @_; + my ($interval) = @_; 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); - 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}); @@ -17131,155 +17156,155 @@ 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')); - } +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 { - 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 0; } } } - 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; + 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:'; } - delete($possibles{$key}); + $origin = $protocol.'//'.lc($hostname); + } else { + $origin = lc($absolute); + ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$}); } - } - 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 (($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 (keys(%collisions)) { - if ($init <5) { - if (!$init) { - $init = 1; - } else { - $init ++; + if ($nocache) { + if ($cached) { + my $devalidate; + if ($uselink && !$result) { + $devalidate = 1; + } elsif (!$uselink && $result) { + $devalidate = 1; } - $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions, - $newunique,$addcourse,$courseonly,$failed); - } else { - foreach my $key (keys(%collisions)) { - $failed->{$key} = 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 $init; + return $uselink; } 1;