[BACK]Return to loncommon.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/loncommon.pm between versions 1.1323 and 1.1333

version 1.1323, 2018/11/07 19:23:45 version 1.1333, 2019/08/25 02:42:56
Line 72  use Apache::lonuserstate(); Line 72  use Apache::lonuserstate();
 use Apache::courseclassifier();  use Apache::courseclassifier();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::LWPReq;  use LONCAPA::LWPReq;
   use HTTP::Request;
 use DateTime::TimeZone;  use DateTime::TimeZone;
 use DateTime::Locale;  use DateTime::Locale;
 use Encode();  use Encode();
Line 3566  sub get_assignable_auth { Line 3567  sub get_assignable_auth {
     return ($authnum,%can_assign);      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'} .= ': !&quot;\#$%&amp;\'()*+,-./:;&lt;=&gt;?@[\]^_\`{|}~';
           $rulenames{'min'} = &mt('Minimum password length: [_1]',$min);
           $rulenames{'max'} = &mt('Maximum password length: [_1]',$max);
           $warning = &mt('Password did not satisfy the following:').'<ul>';
           foreach my $rule ('min','max','uc','ls','num','spec') {
               if (grep(/^$rule$/,@brokerule)) {
                   $warning .= '<li>'.$rulenames{$rule}.'</li>';
               }
           }
           $warning .= '</ul>';
       }
       if (wantarray) {
           return @brokerule;
       }
       return $warning;
   }
   
 ###############################################################  ###############################################################
 ##    Get Kerberos Defaults for Domain                 ##  ##    Get Kerberos Defaults for Domain                 ##
 ###############################################################  ###############################################################
Line 13937  sub load_tmp_file { Line 14011  sub load_tmp_file {
   
 sub valid_datatoken {  sub valid_datatoken {
     my ($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 $datatoken;
     }      }
     return;      return;
Line 16425  sub lon_status_items { Line 16499  sub lon_status_items {
                      E         => 100,                       E         => 100,
                      W         => 4,                       W         => 4,
                      N         => 1,                       N         => 1,
                        U         => 5,
                      threshold => 200,                       threshold => 200,
                      sysmail   => 2500,                       sysmail   => 2500,
                    );                     );
Line 16432  sub lon_status_items { Line 16507  sub lon_status_items {
                    E => 'Errors',                     E => 'Errors',
                    W => 'Warnings',                     W => 'Warnings',
                    N => 'Notices',                     N => 'Notices',
                      U => 'Unsent',
                 );                  );
     return (\%defaults,\%names);      return (\%defaults,\%names);
 }  }
Line 17482  sub needs_coursereinit { Line 17558  sub needs_coursereinit {
 }  }
   
 sub update_content_constraints {  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 %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
     my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});      my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
     my (%checkresponsetypes,%checkcrsrestypes);      my (%checkresponsetypes,%checkcrsrestypes);
Line 17530  sub update_content_constraints { Line 17606  sub update_content_constraints {
         }          }
         undef($navmap);          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 $suppmap = 'supplemental.sequence';
     my ($suppcount,$supptools,$errors) = (0,0,0);      my ($suppcount,$supptools,$errors) = (0,0,0);
     ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,      ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,
                                                             $suppcount,$supptools,$errors);                                                              $suppcount,$supptools,$errors);
       if ($keeporder) {
           @LONCAPA::map::resources = @resources;
           @LONCAPA::map::order = @order;
           @LONCAPA::map::resparms = @resparms;
           @LONCAPA::map::zombies = @zombies;
       }
     if ($supptools) {      if ($supptools) {
         my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});          my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});
         if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) {          if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) {
Line 17560  sub allmaps_incourse { Line 17650  sub allmaps_incourse {
     if ($lastchange > $env{'request.course.tied'}) {      if ($lastchange > $env{'request.course.tied'}) {
         my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");          my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");
         unless ($ferr) {          unless ($ferr) {
             &update_content_constraints($cdom,$cnum,$chome,$cid);              &update_content_constraints($cdom,$cnum,$chome,$cid,1);
         }          }
     }      }
     my $navmap = Apache::lonnavmaps::navmap->new();      my $navmap = Apache::lonnavmaps::navmap->new();
Line 17694  sub symb_to_docspath { Line 17784  sub symb_to_docspath {
 }  }
   
 sub captcha_display {  sub captcha_display {
     my ($context,$lonhost) = @_;      my ($context,$lonhost,$defdom) = @_;
     my ($output,$error);      my ($output,$error);
     my ($captcha,$pubkey,$privkey,$version) =       my ($captcha,$pubkey,$privkey,$version) = 
         &get_captcha_config($context,$lonhost);          &get_captcha_config($context,$lonhost,$defdom);
     if ($captcha eq 'original') {      if ($captcha eq 'original') {
         $output = &create_captcha();          $output = &create_captcha();
         unless ($output) {          unless ($output) {
Line 17713  sub captcha_display { Line 17803  sub captcha_display {
 }  }
   
 sub captcha_response {  sub captcha_response {
     my ($context,$lonhost) = @_;      my ($context,$lonhost,$defdom) = @_;
     my ($captcha_chk,$captcha_error);      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') {      if ($captcha eq 'original') {
         ($captcha_chk,$captcha_error) = &check_captcha();          ($captcha_chk,$captcha_error) = &check_captcha();
     } elsif ($captcha eq 'recaptcha') {      } elsif ($captcha eq 'recaptcha') {
Line 17727  sub captcha_response { Line 17817  sub captcha_response {
 }  }
   
 sub get_captcha_config {  sub get_captcha_config {
     my ($context,$lonhost) = @_;      my ($context,$lonhost,$dom_in_effect) = @_;
     my ($captcha,$pubkey,$privkey,$version,$hashtocheck);      my ($captcha,$pubkey,$privkey,$version,$hashtocheck);
     my $hostname = &Apache::lonnet::hostname($lonhost);      my $hostname = &Apache::lonnet::hostname($lonhost);
     my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);      my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
Line 17775  sub get_captcha_config { Line 17865  sub get_captcha_config {
         } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {          } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {
             $captcha = '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);      return ($captcha,$pubkey,$privkey,$version);
 }  }
   
Line 18154  sub shorten_symbs { Line 18265  sub shorten_symbs {
     return $init;      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;
   }
   
 1;  1;
 __END__;  __END__;
   
Removed from v.1.1323  
changed lines
  Added in v.1.1333

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>