--- loncom/interface/loncommon.pm	2019/07/30 11:10:55	1.1075.2.134
+++ loncom/interface/loncommon.pm	2019/08/28 02:38:42	1.1075.2.139
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # a pile of common routines
 #
-# $Id: loncommon.pm,v 1.1075.2.134 2019/07/30 11:10:55 raeburn Exp $
+# $Id: loncommon.pm,v 1.1075.2.139 2019/08/28 02:38:42 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();
@@ -1403,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,*",},});
@@ -3170,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'} .= ': !&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                 ##
 ###############################################################
@@ -14106,6 +14180,12 @@ defdom (domain for which to retrieve con
 origmail (scalar - email address of recipient from loncapa.conf,
 i.e., predates configuration by DC via domainprefs.pm
 
+$requname username of requester (if mailing type is helpdeskmail)
+
+$requdom domain of requester (if mailing type is helpdeskmail)
+
+$reqemail e-mail address of requester (if mailing type is helpdeskmail)
+
 Returns: comma separated list of addresses to which to send e-mail.
 
 =back
@@ -14115,7 +14195,7 @@ Returns: comma separated list of address
 ############################################################
 ############################################################
 sub build_recipient_list {
-    my ($defmail,$mailing,$defdom,$origmail) = @_;
+    my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
     my @recipients;
     my ($otheremails,$lastresort,$allbcc,$addtext);
     my %domconfig =
@@ -14156,10 +14236,97 @@ sub build_recipient_list {
         } elsif ($origmail ne '') {
             $lastresort = $origmail;
         }
+        if ($mailing eq 'helpdeskmail') {
+            if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&
+                (keys(%{$domconfig{'contacts'}{'overrides'}}))) {
+                my ($inststatus,$inststatus_checked);
+                if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
+                    ($env{'user.domain'} ne 'public')) {
+                    $inststatus_checked = 1;
+                    $inststatus = $env{'environment.inststatus'};
+                }
+                unless ($inststatus_checked) {
+                    if (($requname ne '') && ($requdom ne '')) {
+                        if (($requname =~ /^$match_username$/) &&
+                            ($requdom =~ /^$match_domain$/) &&
+                            (&Apache::lonnet::domain($requdom))) {
+                            my $requhome = &Apache::lonnet::homeserver($requname,
+                                                                      $requdom);
+                            unless ($requhome eq 'no_host') {
+                                my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');
+                                $inststatus = $userenv{'inststatus'};
+                                $inststatus_checked = 1;
+                            }
+                        }
+                    }
+                }
+                unless ($inststatus_checked) {
+                    if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {
+                        my %srch = (srchby     => 'email',
+                                    srchdomain => $defdom,
+                                    srchterm   => $reqemail,
+                                    srchtype   => 'exact');
+                        my %srch_results = &Apache::lonnet::usersearch(\%srch);
+                        foreach my $uname (keys(%srch_results)) {
+                            if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+                                $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+                                $inststatus_checked = 1;
+                                last;
+                            }
+                        }
+                        unless ($inststatus_checked) {
+                            my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);
+                            if ($dirsrchres eq 'ok') {
+                                foreach my $uname (keys(%srch_results)) {
+                                    if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+                                        $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+                                        $inststatus_checked = 1;
+                                        last;
+                                    }
+                                }
+                            }
+                        }
+                    }
+                }
+                if ($inststatus ne '') {
+                    foreach my $status (split(/\:/,$inststatus)) {
+                        if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {
+                            my @contacts = ('adminemail','supportemail');
+                            foreach my $item (@contacts) {
+                                if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {
+                                    my $addr = $domconfig{'contacts'}{'overrides'}{$status};
+                                    if (!grep(/^\Q$addr\E$/,@recipients)) {
+                                        push(@recipients,$addr);
+                                    }
+                                }
+                            }
+                            $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};
+                            if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {
+                                my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});
+                                my @ok_bccs;
+                                foreach my $bcc (@bccs) {
+                                    $bcc =~ s/^\s+//g;
+                                    $bcc =~ s/\s+$//g;
+                                    if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+                                        if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+                                            push(@ok_bccs,$bcc);
+                                        }
+                                    }
+                                }
+                                if (@ok_bccs > 0) {
+                                    $allbcc = join(', ',@ok_bccs);
+                                }
+                            }
+                            $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};
+                            last;
+                        }
+                    }
+                }
+            }
+        }
     } 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'};
@@ -15518,7 +15685,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);
@@ -16651,10 +16834,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) {
@@ -16670,9 +16853,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') {
@@ -16684,7 +16867,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);
@@ -16732,6 +16915,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);
 }
@@ -16951,6 +17155,157 @@ sub des_decrypt {
     return $plaintext;
 }
 
+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;
 __END__;