--- loncom/lond 2007/10/08 21:05:49 1.386 +++ loncom/lond 2008/02/24 22:59:06 1.396 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.386 2007/10/08 21:05:49 albertel 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 $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.386 $'; #' stupid emacs +my $VERSION='$Revision: 1.396 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -996,7 +996,7 @@ sub ping_handler { my ($cmd, $tail, $client) = @_; Debug("$cmd $tail $client .. $currenthostid:"); - Reply( $client,"$currenthostid\n","$cmd:$tail"); + Reply( $client,\$currenthostid,"$cmd:$tail"); return 1; } @@ -1066,7 +1066,7 @@ sub establish_key_handler { $key=substr($key,0,32); my $cipherkey=pack("H32",$key); $cipher=new IDEA $cipherkey; - &Reply($replyfd, "$buildkey\n", "$cmd:$tail"); + &Reply($replyfd, \$buildkey, "$cmd:$tail"); return 1; @@ -1103,7 +1103,7 @@ sub load_handler { my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; - &Reply( $replyfd, "$loadpercent\n", "$cmd:$tail"); + &Reply( $replyfd, \$loadpercent, "$cmd:$tail"); return 1; } @@ -1133,7 +1133,7 @@ sub user_load_handler { my ($cmd, $tail, $replyfd) = @_; my $userloadpercent=&Apache::lonnet::userload(); - &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail"); + &Reply($replyfd, \$userloadpercent, "$cmd:$tail"); return 1; } @@ -1176,7 +1176,7 @@ sub user_authorization_type { } else { $type .= ':'; } - &Reply( $replyfd, "$type\n", $userinput); + &Reply( $replyfd, \$type, $userinput); } return 1; @@ -1212,7 +1212,7 @@ sub push_file_handler { # process making the request. my $reply = &PushFile($userinput); - &Reply($client, "$reply\n", $userinput); + &Reply($client, \$reply, $userinput); } else { &Failure( $client, "refused\n", $userinput); @@ -1264,7 +1264,7 @@ sub du_handler { chdir($ududir); find($code,$ududir); $total_size=int($total_size/1024); - &Reply($client,"$total_size\n","$cmd:$ududir"); + &Reply($client,\$total_size,"$cmd:$ududir"); } else { &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); } @@ -1333,7 +1333,7 @@ sub ls_handler { $ulsout='no_such_dir'; } if ($ulsout eq '') { $ulsout='empty'; } - &Reply($client, "$ulsout\n", $userinput); # This supports debug logging. + &Reply($client, \$ulsout, $userinput); # This supports debug logging. return 1; @@ -1402,7 +1402,7 @@ sub ls2_handler { $ulsout='no_such_dir'; } if ($ulsout eq '') { $ulsout='empty'; } - &Reply($client, "$ulsout\n", $userinput); # This supports debug logging. + &Reply($client, \$ulsout, $userinput); # This supports debug logging. return 1; } ®ister_handler("ls2", \&ls2_handler, 0, 1, 0); @@ -1430,7 +1430,7 @@ sub reinit_process_handler { if(&ValidManager($cert)) { chomp($userinput); my $reply = &ReinitProcess($userinput); - &Reply( $client, "$reply\n", $userinput); + &Reply( $client, \$reply, $userinput); } else { &Failure( $client, "refused\n", $userinput); } @@ -1514,13 +1514,15 @@ sub authenticate_handler { # udom - User's domain. # uname - Username. # upass - User's password. + # checkdefauth - Pass to validate_user() to try authentication + # with default auth type(s) if no user account. - my ($udom,$uname,$upass)=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); + my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth); if($pwdcorrect) { &Reply( $client, "authorized\n", $userinput); # @@ -1605,7 +1607,7 @@ sub change_password_handler { my $result = &change_unix_password($uname, $npass); &logthis("Result of password change for $uname: ". $result); - &Reply($client, "$result\n", $userinput); + &Reply($client, \$result, $userinput); } else { # this just means that the current password mode is not # one we know how to change (e.g the kerberos auth modes or @@ -1666,9 +1668,9 @@ sub add_user_handler { } unless ($fperror) { my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); - &Reply($client, $result, $userinput); #BUGBUG - could be fail + &Reply($client,\$result, $userinput); #BUGBUG - could be fail } else { - &Failure($client, "$fperror\n", $userinput); + &Failure($client, \$fperror, $userinput); } } umask($oldumask); @@ -1735,9 +1737,9 @@ sub change_authentication_handler { my $result = &change_unix_password($uname, $npass); &logthis("Result of password change for $uname: ".$result); if ($result eq "ok") { - &Reply($client, "$result\n") + &Reply($client, \$result); } else { - &Failure($client, "$result\n"); + &Failure($client, \$result); } } else { my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); @@ -1756,7 +1758,7 @@ sub change_authentication_handler { &manage_permissions("/$udom/_au", $udom, $uname, "$umode:"); } } - &Reply($client, $result, $userinput); + &Reply($client, \$result, $userinput); } @@ -2141,24 +2143,24 @@ sub token_auth_user_file_handler { my ($fname, $session) = split(/:/, $tail); chomp($session); - my $reply="non_auth\n"; + my $reply="non_auth"; my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id'; if (open(ENVIN,"$file")) { flock(ENVIN,LOCK_SH); tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640); if (exists($disk_env{"userfile.$fname"})) { - $reply="ok\n"; + $reply="ok"; } else { foreach my $envname (keys(%disk_env)) { if ($envname=~ m|^userfile\.\Q$fname\E|) { - $reply="ok\n"; + $reply="ok"; last; } } } untie(%disk_env); close(ENVIN); - &Reply($client, $reply, "$cmd:$tail"); + &Reply($client, \$reply, "$cmd:$tail"); } else { &Failure($client, "invalid_token\n", "$cmd:$tail"); } @@ -2582,10 +2584,11 @@ sub get_profile_entry { my ($udom,$uname,$namespace,$what) = split(/:/,$tail); chomp($what); + my $replystring = read_profile($udom, $uname, $namespace, $what); my ($first) = split(/:/,$replystring); if($first ne "error") { - &Reply($client, "$replystring\n", $userinput); + &Reply($client, \$replystring, $userinput); } else { &Failure($client, $replystring." while attempting get\n", $userinput); } @@ -2725,7 +2728,7 @@ sub get_profile_keys { } if (&untie_user_hash($hashref)) { $qresult=~s/\&$//; - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting keys\n", $userinput); @@ -2795,7 +2798,7 @@ sub dump_profile_database { } } chop($qresult); - &Reply($client , "$qresult\n", $userinput); + &Reply($client , \$qresult, $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting currentdump\n", $userinput); @@ -2878,7 +2881,7 @@ sub dump_with_regexp { } if (&untie_user_hash($hashref)) { chop($qresult); - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting dump\n", $userinput); @@ -3086,7 +3089,7 @@ sub restore_handler { } if (&untie_user_hash($hashref)) { $qresult=~s/\&$//; - &Reply( $client, "$qresult\n", $userinput); + &Reply( $client, \$qresult, $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting restore\n", $userinput); @@ -3167,7 +3170,7 @@ sub retrieve_chat_handler { $reply.=&escape($_).':'; } $reply=~s/\:$//; - &Reply($client, $reply."\n", $userinput); + &Reply($client, \$reply, $userinput); return 1; @@ -3311,7 +3314,7 @@ sub put_course_id_handler { my @new_items = split(/:/,$courseinfo,-1); my %storehash; for (my $i=0; $i<@new_items; $i++) { - $storehash{$items[$i]} = $new_items[$i]; + $storehash{$items[$i]} = &unescape($new_items[$i]); } $hashref->{$key} = &Apache::lonnet::freeze_escape(\%storehash); @@ -3515,7 +3518,7 @@ sub dump_course_id_handler { } } else { $is_hash = 0; - my @courseitems = split(/:/,&unescape($value)); + my @courseitems = split(/:/,$value); $lasttime = pop(@courseitems); next if ($lasttime<$since); ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems; @@ -3604,10 +3607,10 @@ sub dump_course_id_handler { if ($is_hash) { $qresult.=$key.'='.$value.'&'; } else { - my %rtnhash = ( 'description' => &escape($val{'descr'}), - 'inst_code' => &escape($val{'inst_code'}), - 'owner' => &escape($val{'owner'}), - 'type' => &escape($val{'type'}), + my %rtnhash = ( 'description' => &unescape($val{'descr'}), + 'inst_code' => &unescape($val{'inst_code'}), + 'owner' => &unescape($val{'owner'}), + 'type' => &unescape($val{'type'}), ); my $items = &Apache::lonnet::freeze_escape(\%rtnhash); $qresult.=$key.'='.$items.'&'; @@ -3626,7 +3629,7 @@ sub dump_course_id_handler { } if (&untie_domain_hash($hashref)) { chop($qresult); - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting courseiddump\n", $userinput); @@ -3717,7 +3720,7 @@ sub get_domain_handler { } if (&untie_domain_hash($hashref)) { $qresult=~s/\&$//; - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting getdom\n",$userinput); @@ -3815,7 +3818,7 @@ sub get_id_handler { } if (&untie_domain_hash($hashref)) { $qresult=~s/\&$//; - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting idget\n",$userinput); @@ -3939,7 +3942,7 @@ sub dump_dcmail_handler { } if (&untie_domain_hash($hashref)) { chop($qresult); - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting dcmaildump\n", $userinput); @@ -4057,7 +4060,7 @@ sub dump_domainroles_handler { } } unless (@roles < 1) { - unless (grep/^$trole$/,@roles) { + unless (grep/^\Q$trole\E$/,@roles) { $match = 0; } } @@ -4067,7 +4070,7 @@ sub dump_domainroles_handler { } if (&untie_domain_hash($hashref)) { chop($qresult); - &Reply($client, "$qresult\n", $userinput); + &Reply($client, \$qresult, $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting domrolesdump\n", $userinput); @@ -4121,7 +4124,7 @@ sub tmp_put_handler { if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { print $store $record; close $store; - &Reply($client, "$id\n", $userinput); + &Reply($client, \$id, $userinput); } else { &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". "while attempting tmpput\n", $userinput); @@ -4155,7 +4158,7 @@ sub tmp_get_handler { my $execdir=$perlvar{'lonDaemons'}; if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { my $reply=<$store>; - &Reply( $client, "$reply\n", $userinput); + &Reply( $client, \$reply, $userinput); close $store; } else { &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". @@ -4339,7 +4342,7 @@ sub enrollment_enabled_handler { my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about. my $outcome = &localenroll::run($cdom); - &Reply($client, "$outcome\n", $userinput); + &Reply($client, \$outcome, $userinput); return 1; } @@ -4366,7 +4369,7 @@ sub get_sections_handler { my @secs = &localenroll::get_sections($coursecode,$cdom); my $seclist = &escape(join(':',@secs)); - &Reply($client, "$seclist\n", $userinput); + &Reply($client, \$seclist, $userinput); return 1; @@ -4395,7 +4398,7 @@ sub validate_course_owner_handler { $owner = &unescape($owner); my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); - &Reply($client, "$outcome\n", $userinput); + &Reply($client, \$outcome, $userinput); @@ -4426,7 +4429,7 @@ sub validate_course_section_handler { my ($inst_course_id, $cdom) = split(/:/, $tail); my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom); - &Reply($client, "$outcome\n", $userinput); + &Reply($client, \$outcome, $userinput); return 1; @@ -4454,13 +4457,13 @@ sub validate_class_access_handler { my ($cmd, $tail, $client) = @_; my $userinput = "$cmd:$tail"; my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail); - my @owners = split(/,/,&unescape($ownerlist)); + my $owners = &unescape($ownerlist); my $outcome; eval { local($SIG{__DIE__})='DEFAULT'; - $outcome=&localenroll::check_section($inst_class,\@owners,$cdom); + $outcome=&localenroll::check_section($inst_class,$owners,$cdom); }; - &Reply($client,"$outcome\n", $userinput); + &Reply($client,\$outcome, $userinput); return 1; } @@ -4621,7 +4624,7 @@ sub get_institutional_defaults_handler { $result.=&escape($key).'='.&escape($value).'&'; } $result .= 'code_order='.&escape(join('&',@code_order)); - &Reply($client,$result."\n",$userinput); + &Reply($client,\$result,$userinput); } else { &Reply($client,"error\n", $userinput); } @@ -4656,7 +4659,7 @@ sub get_institutional_user_rules { } } $result =~ s/\&$//; - &Reply($client,$result."\n",$userinput); + &Reply($client,\$result,$userinput); } else { &Reply($client,"error\n", $userinput); } @@ -4666,6 +4669,74 @@ sub get_institutional_user_rules { } ®ister_handler("instuserrules",\&get_institutional_user_rules,0,1,0); +sub get_institutional_id_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::id_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); + } +} +®ister_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); + } +} +®ister_handler("instemailrules",\&get_institutional_selfenroll_rules,0,1,0); + sub institutional_username_check { my ($cmd, $tail, $client) = @_; @@ -4686,7 +4757,7 @@ sub institutional_username_check { foreach my $key (keys(%rulecheck)) { $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&'; } - &Reply($client,$result."\n",$userinput); + &Reply($client,\$result,$userinput); } else { &Reply($client,"error\n", $userinput); } @@ -4696,6 +4767,63 @@ sub institutional_username_check { } ®ister_handler("instrulecheck",\&institutional_username_check,0,1,0); +sub institutional_id_check { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my %rulecheck; + my $outcome; + my ($udom,$id,@rules) = split(/:/,$tail); + $udom = &unescape($udom); + $id = &unescape($id); + @rules = map {&unescape($_);} (@rules); + eval { + local($SIG{__DIE__})='DEFAULT'; + $outcome = &localenroll::id_check($udom,$id,\@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); + } +} +®ister_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); + } +} +®ister_handler("instselfenrollcheck",\&institutional_selfenroll_check,0,1,0); # Get domain specific conditions for import of student photographs to a course # @@ -4848,7 +4976,7 @@ sub inst_usertypes_handler { } $res=~s/\&$//; } - &Reply($client, "$res\n", $userinput); + &Reply($client, \$res, $userinput); return 1; } ®ister_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0); @@ -5347,9 +5475,14 @@ sub Debug { # sub Reply { my ($fd, $reply, $request) = @_; - print $fd $reply; - Debug("Request was $request Reply was $reply"); - + if (ref($reply)) { + print $fd $$reply; + print $fd "\n"; + if ($DEBUG) { Debug("Request was $request Reply was $$reply"); } + } else { + print $fd $reply; + if ($DEBUG) { Debug("Request was $request Reply was $reply"); } + } $Transactions++; } @@ -5902,8 +6035,7 @@ sub get_auth_type # 0 - The domain,user,password triplet is not a valid user. # sub validate_user { - my ($domain, $user, $password) = @_; - + 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. @@ -5926,8 +6058,21 @@ sub validate_user { my $null = pack("C",0); # Used by kerberos auth types. + if ($howpwd eq 'nouser') { + 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') { - if($howpwd eq "internal") { # Encrypted is in local password file. $validated = (crypt($password, $contentpwd) eq $contentpwd); } @@ -5978,11 +6123,18 @@ sub validate_user { my $credentials= &Authen::Krb5::cc_default(); $credentials->initialize(&Authen::Krb5::parse_name($user.'@' .$contentpwd)); - my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, - $krbserver, - $password, - $credentials); - $validated = ($krbreturn == 1); + my $krbreturn; + if (exists(&Authen::Krb5::get_init_creds_password)) { + $krbreturn = + &Authen::Krb5::get_init_creds_password($krbclient,$password, + $krbservice); + $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds'); + } else { + $krbreturn = + &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver, + $password,$credentials); + $validated = ($krbreturn == 1); + } if (!$validated) { &logthis('krb5: '.$user.', '.$contentpwd.', '. &Authen::Krb5::error()); @@ -6275,7 +6427,7 @@ sub change_unix_password { sub make_passwd_file { my ($uname, $umode,$npass,$passfilename)=@_; - my $result="ok\n"; + my $result="ok"; if ($umode eq 'krb4' or $umode eq 'krb5') { { my $pf = IO::File->new(">$passfilename"); @@ -6343,7 +6495,7 @@ sub make_passwd_file { if($useraddok > 0) { my $error_text = &lcuseraddstrerror($useraddok); &logthis("Failed lcuseradd: $error_text"); - $result = "lcuseradd_failed:$error_text\n"; + $result = "lcuseradd_failed:$error_text"; } else { my $pf = IO::File->new(">$passfilename"); if($pf) { @@ -6367,7 +6519,7 @@ sub make_passwd_file { } } } else { - $result="auth_mode_error\n"; + $result="auth_mode_error"; } return $result; } 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.