[LON-CAPA-cvs] cvs: loncom / lond /enrollment localenroll.pm /interface loncommon.pm /lonnet/perl lonnet.pm

raeburn lon-capa-cvs-allow@mail.lon-capa.org
Sun, 24 Feb 2008 22:59:21 -0000


This is a MIME encoded message

--raeburn1203893961
Content-Type: text/plain

raeburn		Sun Feb 24 17:59:21 2008 EDT

  Modified files:              
    /loncom	lond 
    /loncom/interface	loncommon.pm 
    /loncom/lonnet/perl	lonnet.pm 
    /loncom/enrollment	localenroll.pm 
  Log:
  lond::validate_user() - optional fourth and fifth arguments added in lond 1.395, replaced with a single optional argument ($checkdefauth). If true, default auth type and args retrieved using lonnet::get_domain_defaults().
  - Default authentication type and argument, and language in a domain can be retrieved from lonnet::get_domain_defaults().
  - lonnet::inst_rulecheck() can check format rules for e-mail addresses proposed as usernames for self-enrollment
  - lonnet::inst_userrules() can retrieve rule definitions for e-mail addresses used as usernames
  - loncommon::get_auth_defaults() eliminated. lonnet::get_domain_defaults() used instead
  - loncommon::preferred_languages() streamlined.
  - localenroll::selfenroll_rules() and localenroll::selfenroll_check() added to define rules for e-mail addresses which may not be used as usernames, and to check a proposed self-enrollment username (i.e., e-mail address) against the rules in force.
  
  
--raeburn1203893961
Content-Type: text/plain
Content-Disposition: attachment; filename="raeburn-20080224175921.txt"

Index: loncom/lond
diff -u loncom/lond:1.395 loncom/lond:1.396
--- loncom/lond:1.395	Thu Feb 21 11:04:19 2008
+++ loncom/lond	Sun Feb 24 17:59:06 2008
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # lond "LON Daemon" Server (port "LOND" 5663)
 #
-# $Id: lond,v 1.395 2008/02/21 16:04:19 raeburn Exp $
+# $Id: lond,v 1.396 2008/02/24 22:59:06 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -59,7 +59,7 @@
 my $status='';
 my $lastlog='';
 
-my $VERSION='$Revision: 1.395 $'; #' stupid emacs
+my $VERSION='$Revision: 1.396 $'; #' stupid emacs
 my $remoteVERSION;
 my $currenthostid="default";
 my $currentdomainid;
@@ -1514,16 +1514,15 @@
     #  udom    - User's domain.
     #  uname   - Username.
     #  upass   - User's password.
-    #  defauthtype - Default authentication types for the domain
-    #  defautharg - Default authentication arg for the domain
+    #  checkdefauth - Pass to validate_user() to try authentication
+    #                 with default auth type(s) if no user account.
     
-    my ($udom,$uname,$upass,$defauthtype,$defautharg)=split(/:/,$tail);
+    my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
     &Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
     chomp($upass);
     $upass=&unescape($upass);
 
-    my $pwdcorrect = &validate_user($udom,$uname,$upass,$defauthtype,
-                                    $defautharg);
+    my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
     if($pwdcorrect) {
 	&Reply( $client, "authorized\n", $userinput);
 	#
@@ -4704,6 +4703,40 @@
 }
 &register_handler("instidrules",\&get_institutional_id_rules,0,1,0);
 
+sub get_institutional_selfenroll_rules {
+    my ($cmd, $tail, $client)   = @_;
+    my $userinput               = "$cmd:$tail";
+    my $dom = &unescape($tail);
+    my (%rules_hash,@rules_order);
+    my $outcome;
+    eval {
+        local($SIG{__DIE__})='DEFAULT';
+        $outcome = &localenroll::selfenroll_rules($dom,\%rules_hash,\@rules_order);
+    };
+    if (!$@) {
+        if ($outcome eq 'ok') {
+            my $result;
+            foreach my $key (keys(%rules_hash)) {
+                $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
+            }
+            $result =~ s/\&$//;
+            $result .= ':';
+            if (@rules_order > 0) {
+                foreach my $item (@rules_order) {
+                    $result .= &escape($item).'&';
+                }
+            }
+            $result =~ s/\&$//;
+            &Reply($client,\$result,$userinput);
+        } else {
+            &Reply($client,"error\n", $userinput);
+        }
+    } else {
+        &Failure($client,"unknown_cmd\n",$userinput);
+    }
+}
+&register_handler("instemailrules",\&get_institutional_selfenroll_rules,0,1,0);
+
 
 sub institutional_username_check {
     my ($cmd, $tail, $client)   = @_;
@@ -4763,6 +4796,35 @@
 }
 &register_handler("instidrulecheck",\&institutional_id_check,0,1,0);
 
+sub institutional_selfenroll_check {
+    my ($cmd, $tail, $client)   = @_;
+    my $userinput               = "$cmd:$tail";
+    my %rulecheck;
+    my $outcome;
+    my ($udom,$email,@rules) = split(/:/,$tail);
+    $udom = &unescape($udom);
+    $email = &unescape($email);
+    @rules = map {&unescape($_);} (@rules);
+    eval {
+        local($SIG{__DIE__})='DEFAULT';
+        $outcome = &localenroll::selfenroll_check($udom,$email,\@rules,\%rulecheck);
+    };
+    if (!$@) {
+        if ($outcome eq 'ok') {
+            my $result='';
+            foreach my $key (keys(%rulecheck)) {
+                $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
+            }
+            &Reply($client,\$result,$userinput);
+        } else {
+            &Reply($client,"error\n", $userinput);
+        }
+    } else {
+        &Failure($client,"unknown_cmd\n",$userinput);
+    }
+}
+&register_handler("instselfenrollcheck",\&institutional_selfenroll_check,0,1,0);
+
 # Get domain specific conditions for import of student photographs to a course
 #
 # Retrieves information from photo_permission subroutine in localenroll.
@@ -5973,7 +6035,7 @@
 #     0        - The domain,user,password triplet is not a valid user.
 #
 sub validate_user {
-    my ($domain, $user, $password, $defauthtype, $defautharg) = @_;
+    my ($domain, $user, $password, $checkdefauth) = @_;
 
     # Why negative ~pi you may well ask?  Well this function is about
     # authentication, and therefore very important to get right.
@@ -5997,13 +6059,17 @@
     my $null = pack("C",0);	# Used by kerberos auth types.
 
     if ($howpwd eq 'nouser') {
-        if ($defauthtype eq 'localauth') {
-            $howpwd = $defauthtype;
-            $contentpwd = $defautharg;
-        } elsif ((($defauthtype eq 'krb4') || ($defauthtype eq 'krb5')) &&
-             ($defautharg ne '')) {
-            $howpwd = $defauthtype;
-            $contentpwd = $defautharg; 
+        if ($checkdefauth) {
+            my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
+            if ($domdefaults{'auth_def'} eq 'localauth') {
+                $howpwd = $domdefaults{'auth_def'};
+                $contentpwd = $domdefaults{'auth_arg_def'};
+            } elsif ((($domdefaults{'auth_def'} eq 'krb4') || 
+                      ($domdefaults{'auth_def'} eq 'krb5')) &&
+                     ($domdefaults{'auth_arg_def'} ne '')) {
+                $howpwd = $domdefaults{'auth_def'};
+                $contentpwd = $domdefaults{'auth_arg_def'}; 
+            }
         }
     } 
     if ($howpwd ne 'nouser') {
Index: loncom/interface/loncommon.pm
diff -u loncom/interface/loncommon.pm:1.640 loncom/interface/loncommon.pm:1.641
--- loncom/interface/loncommon.pm:1.640	Wed Feb 13 07:41:11 2008
+++ loncom/interface/loncommon.pm	Sun Feb 24 17:59:13 2008
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # a pile of common routines
 #
-# $Id: loncommon.pm,v 1.640 2008/02/13 12:41:11 bisitz Exp $
+# $Id: loncommon.pm,v 1.641 2008/02/24 22:59:13 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -2242,42 +2242,6 @@
 }
 
 ###############################################################
-##    Get Authentication Defaults for Domain                 ##
-###############################################################
-
-=pod
-
-=head1 Domains and Authentication
-
-Returns default authentication type and an associated argument as
-listed in file 'domain.tab'.
-
-=over 4
-
-=item * get_auth_defaults
-
-get_auth_defaults($target_domain) returns the default authentication
-type and an associated argument (initial password or a kerberos domain).
-These values are stored in lonTabs/domain.tab
-
-($def_auth, $def_arg) = &get_auth_defaults($target_domain);
-
-If target_domain is not found in domain.tab, returns nothing ('').
-
-=cut
-
-#-------------------------------------------
-sub get_auth_defaults {
-    my $domain=shift;
-    return (&Apache::lonnet::domain($domain,'auth_def'),
-	    &Apache::lonnet::domain($domain,'auth_arg_def'));
-	    
-}
-###############################################################
-##   End Get Authentication Defaults for Domain              ##
-###############################################################
-
-###############################################################
 ##    Get Kerberos Defaults for Domain                 ##
 ###############################################################
 ##
@@ -2292,8 +2256,8 @@
 =item * get_kerberos_defaults
 
 get_kerberos_defaults($target_domain) returns the default kerberos
-version and domain. If not found in domain.tabs, it defaults to
-version 4 and the domain of the server.
+version and domain. If not found, it defaults to version 4 and the 
+domain of the server.
 
 ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
 
@@ -2302,9 +2266,12 @@
 #-------------------------------------------
 sub get_kerberos_defaults {
     my $domain=shift;
-    my ($krbdef,$krbdefdom) =
-        &Apache::loncommon::get_auth_defaults($domain);
-    unless ($krbdef =~/^krb/ && $krbdefdom) {
+    my ($krbdef,$krbdefdom);
+    my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
+    if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
+        $krbdef = $domdefaults{'auth_def'};
+        $krbdefdom = $domdefaults{'auth_arg_def'};
+    } else {
         $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
         my $krbdefdom=$1;
         $krbdefdom=~tr/a-z/A-Z/;
@@ -2883,21 +2850,15 @@
 	    map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));
 	push(@languages,@browser);
     }
-    if (&Apache::lonnet::domain($env{'user.domain'},'lang_def')) {
-	@languages=(@languages,
-		    &Apache::lonnet::domain($env{'user.domain'},
-					    'lang_def'));
-    }
-    if (&Apache::lonnet::domain($env{'request.role.domain'},'lang_def')) {
-	@languages=(@languages,
-		    &Apache::lonnet::domain($env{'request.role.domain'},
-					    'lang_def'));
-    }
-    if (&Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'},
-				'lang_def')) {
-	@languages=(@languages,
-		    &Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'},
-					    'lang_def'));
+
+    foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},
+                         $Apache::lonnet::perlvar{'lonDefDomain'}) {
+        if ($domtype ne '') {
+            my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);
+            if ($domdefs{'lang_def'} ne '') {
+                push(@languages,$domdefs{'lang_def'});
+            }
+        }
     }
 # turn "en-ca" into "en-ca,en"
     my @genlanguages;
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.942 loncom/lonnet/perl/lonnet.pm:1.943
--- loncom/lonnet/perl/lonnet.pm:1.942	Thu Feb 21 05:04:35 2008
+++ loncom/lonnet/perl/lonnet.pm	Sun Feb 24 17:59:17 2008
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.942 2008/02/21 10:04:35 foxr Exp $
+# $Id: lonnet.pm,v 1.943 2008/02/24 22:59:17 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -1064,6 +1064,10 @@
                     $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                               ':'.&escape($id).':'.$rulestr,
                                               $homeserver));
+                } elsif ($item eq 'selfenroll') {
+                    $response=&unescape(&reply('instselfenrollcheck:'.
+                                               &escape($udom).':'.&escape($uname).
+                                              ':'.$rulestr,$homeserver));
                 }
                 if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);
@@ -1090,6 +1094,9 @@
             if ($check eq 'id') {
                 $response=&reply('instidrules:'.&escape($udom),
                                  $homeserver);
+            } elsif ($check eq 'email') {
+                $response=&reply('instemailrules:'.&escape($udom),
+                                 $homeserver);
             } else {
                 $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);
@@ -1115,6 +1122,35 @@
     return (\%ruleshash,\@ruleorder);
 }
 
+# ------------------------- Get Authentication and Language Defaults for Domain
+
+sub get_domain_defaults {
+    my ($domain) = @_;
+    my $cachetime = 60*60*24;
+    my ($defauthtype,$defautharg,$deflang);
+    my ($result,$cached)=&is_cached_new('domdefaults',$domain);
+    if (defined($cached)) {
+        if (ref($result) eq 'HASH') {
+            return %{$result};
+        }
+    }
+    my %domdefaults;
+    my %domconfig =
+         &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
+    if (ref($domconfig{'defaults'}) eq 'HASH') {
+        $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
+        $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
+        $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+    } else {
+        $domdefaults{'lang_def'} = &domain($domain,'lang_def');
+        $domdefaults{'auth_def'} = &domain($domain,'auth_def');
+        $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
+    }
+    &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
+                                  $cachetime);
+    return %domdefaults;
+}
+
 # --------------------------------------------------- Assign a key to a student
 
 sub assign_access_key {
@@ -9362,6 +9398,18 @@
 domain level either on specified domain server ($uhome) or primary domain 
 server ($udom and $uhome are optional)
 
+=item * 
+
+get_domain_defaults($target_domain) : returns hash with defaults for
+authentication and language in the domain. Keys are: auth_def, auth_arg_def,
+lang_def; corresponsing values are authentication type (internal, krb4, krb5,
+or localauth), initial password or a kerberos realm, language (e.g., en-us).
+Values are retrieved from cache (if current), or from domain's configuration.db
+(if available), or lastly from values in lonTabs/dns_domain,tab, 
+or lonTabs/domain.tab. 
+
+%domdefaults = &get_auth_defaults($target_domain);
+
 =back
 
 =head2 Network Status Functions
Index: loncom/enrollment/localenroll.pm
diff -u loncom/enrollment/localenroll.pm:1.29 loncom/enrollment/localenroll.pm:1.30
--- loncom/enrollment/localenroll.pm:1.29	Thu Jan  3 18:28:33 2008
+++ loncom/enrollment/localenroll.pm	Sun Feb 24 17:59:20 2008
@@ -1,6 +1,6 @@
 # functions to glue school database system into Lon-CAPA for 
 # automated enrollment
-# $Id: localenroll.pm,v 1.29 2008/01/03 23:28:33 raeburn Exp $
+# $Id: localenroll.pm,v 1.30 2008/02/24 22:59:20 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -648,7 +648,6 @@
 #
 # (c) $rulesorder - reference to array containing rule names
 #                   in order to be displayed
-
 #
 #  returns 'ok' if no processing error.
 #
@@ -661,6 +660,33 @@
 }
 
 ###############################
+# sub selfenroll_rules
+#
+# Incoming data: three arguments
+# (a) $dom - domain
+# (b) $ruleshash - reference to hash containing rules
+#                  (a hash of a hash)
+#                  keys of top level hash are short names
+#                   (e.g., netid)
+#                  for each key, value is a hash
+#                      desc => long name for rule
+#                      rule => description of rule
+#
+# (c) $rulesorder - reference to array containing rule names
+#                   in order to be displayed
+#
+#  returns 'ok' if no processing error.
+#
+###############################
+
+
+sub selfenroll_rules {
+    my ($dom,$ruleshash,$rulesorder) = @_;
+    my $outcome;
+    return $outcome;
+}
+
+###############################
 # sub username_check 
 #
 # Incoming data: four arguments
@@ -705,6 +731,28 @@
 }
 
 ###############################
+# sub selfenroll_check
+#
+# Incoming data: four arguments
+# (a) $dom - domain (scalar)
+# (b) $selfenrollname - e-mail proposed as username (compare against rules - scalar)
+# (c) $to_check (reference to array of rule names to check)
+# (d) $resultshash (reference to hash of results)
+#                   hash of results for rule checked
+#                   - keys are rule names
+#                   - values are: 1 or 0 (for matched or unmatched)
+#
+# returns 'ok' if no processing error.
+#
+###############################
+
+sub selfenroll_check {
+    my ($dom,$selfenrollname,$to_check,$resultshash) = @_;
+    my $outcome;
+    return $outcome;
+}
+
+###############################
 # sub AUTOLOAD
 #
 # Incoming data: none

--raeburn1203893961--