|
version 1.332, 2006/05/31 14:47:56
|
version 1.363, 2007/03/28 00:05:38
|
|
Line 40 use IO::File;
|
Line 40 use IO::File;
|
| use POSIX; |
use POSIX; |
| use Crypt::IDEA; |
use Crypt::IDEA; |
| use LWP::UserAgent(); |
use LWP::UserAgent(); |
| |
use Digest::MD5 qw(md5_hex); |
| use GDBM_File; |
use GDBM_File; |
| use Authen::Krb4; |
use Authen::Krb4; |
| use Authen::Krb5; |
use Authen::Krb5; |
| use lib '/home/httpd/lib/perl/'; |
|
| use localauth; |
use localauth; |
| use localenroll; |
use localenroll; |
| use localstudentphoto; |
use localstudentphoto; |
|
Line 503 sub AdjustHostContents {
|
Line 503 sub AdjustHostContents {
|
| my $adjusted; |
my $adjusted; |
| my $me = $perlvar{'lonHostID'}; |
my $me = $perlvar{'lonHostID'}; |
| |
|
| foreach my $line (split(/\n/,$contents)) { |
foreach my $line (split(/\n/,$contents)) { |
| if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { |
if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { |
| chomp($line); |
chomp($line); |
| my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); |
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); |
| if ($id eq $me) { |
if ($id eq $me) { |
| my $ip = gethostbyname($name); |
my $ip = gethostbyname($name); |
| my $ipnew = inet_ntoa($ip); |
my $ipnew = inet_ntoa($ip); |
| $ip = $ipnew; |
$ip = $ipnew; |
| # Reconstruct the host line and append to adjusted: |
# Reconstruct the host line and append to adjusted: |
| |
|
| my $newline = "$id:$domain:$role:$name:$ip"; |
my $newline = "$id:$domain:$role:$name:$ip"; |
| if($maxcon ne "") { # Not all hosts have loncnew tuning params |
if($maxcon ne "") { # Not all hosts have loncnew tuning params |
| $newline .= ":$maxcon:$idleto:$mincon"; |
$newline .= ":$maxcon:$idleto:$mincon"; |
| } |
} |
| $adjusted .= $newline."\n"; |
$adjusted .= $newline."\n"; |
| |
|
| } else { # Not me, pass unmodified. |
} else { # Not me, pass unmodified. |
| $adjusted .= $line."\n"; |
$adjusted .= $line."\n"; |
| } |
} |
| } else { # Blank or comment never re-written. |
} else { # Blank or comment never re-written. |
| $adjusted .= $line."\n"; # Pass blanks and comments as is. |
$adjusted .= $line."\n"; # Pass blanks and comments as is. |
| } |
} |
| } |
} |
| return $adjusted; |
return $adjusted; |
| } |
} |
| # |
# |
| # InstallFile: Called to install an administrative file: |
# InstallFile: Called to install an administrative file: |
|
Line 835 sub AdjustOurHost {
|
Line 835 sub AdjustOurHost {
|
| # Use the config line to get my hostname. |
# Use the config line to get my hostname. |
| # Use gethostbyname to translate that into an IP address. |
# Use gethostbyname to translate that into an IP address. |
| # |
# |
| my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); |
my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); |
| my $BinaryIp = gethostbyname($name); |
|
| my $ip = inet_ntoa($ip); |
|
| # |
# |
| # Reassemble the config line from the elements in the list. |
# Reassemble the config line from the elements in the list. |
| # Note that if the loncnew items were not present before, they will |
# Note that if the loncnew items were not present before, they will |
| # be now even if they would be empty |
# be now even if they would be empty |
| # |
# |
| my $newConfigLine = $id; |
my $newConfigLine = $id; |
| foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) { |
foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) { |
| $newConfigLine .= ":".$item; |
$newConfigLine .= ":".$item; |
| } |
} |
| # Replace the line: |
# Replace the line: |
|
Line 890 sub EditFile {
|
Line 888 sub EditFile {
|
| |
|
| # Split the command into it's pieces: edit:filetype:script |
# Split the command into it's pieces: edit:filetype:script |
| |
|
| my ($request, $filetype, $script) = split(/:/, $request,3); # : in script |
my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script |
| |
|
| # Check the pre-coditions for success: |
# Check the pre-coditions for success: |
| |
|
| if($request != "edit") { # Something is amiss afoot alack. |
if($cmd != "edit") { # Something is amiss afoot alack. |
| return "error:edit request detected, but request != 'edit'\n"; |
return "error:edit request detected, but request != 'edit'\n"; |
| } |
} |
| if( ($filetype ne "hosts") && |
if( ($filetype ne "hosts") && |
|
Line 1252 sub push_file_handler {
|
Line 1250 sub push_file_handler {
|
| # |
# |
| sub du_handler { |
sub du_handler { |
| my ($cmd, $ududir, $client) = @_; |
my ($cmd, $ududir, $client) = @_; |
| my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier. |
($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier. |
| my $userinput = "$cmd:$ududir"; |
my $userinput = "$cmd:$ududir"; |
| |
|
| if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) { |
if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) { |
|
Line 1270 sub du_handler {
|
Line 1268 sub du_handler {
|
| my $code=sub { |
my $code=sub { |
| if ($_=~/\.\d+\./) { return;} |
if ($_=~/\.\d+\./) { return;} |
| if ($_=~/\.meta$/) { return;} |
if ($_=~/\.meta$/) { return;} |
| |
if (-d $_) { return;} |
| $total_size+=(stat($_))[7]; |
$total_size+=(stat($_))[7]; |
| }; |
}; |
| chdir($ududir); |
chdir($ududir); |
|
Line 1576 sub change_password_handler {
|
Line 1575 sub change_password_handler {
|
| # uname - Username. |
# uname - Username. |
| # upass - Current password. |
# upass - Current password. |
| # npass - New password. |
# npass - New password. |
| |
# context - Context in which this was called |
| |
# (preferences or reset_by_email). |
| |
|
| my ($udom,$uname,$upass,$npass)=split(/:/,$tail); |
my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail); |
| |
|
| $upass=&unescape($upass); |
$upass=&unescape($upass); |
| $npass=&unescape($npass); |
$npass=&unescape($npass); |
| &Debug("Trying to change password for $uname"); |
&Debug("Trying to change password for $uname"); |
| |
|
| # First require that the user can be authenticated with their |
# First require that the user can be authenticated with their |
| # old password: |
# old password unless context was 'reset_by_email': |
| |
|
| my $validated = &validate_user($udom, $uname, $upass); |
my $validated; |
| |
if ($context eq 'reset_by_email') { |
| |
$validated = 1; |
| |
} else { |
| |
$validated = &validate_user($udom, $uname, $upass); |
| |
} |
| if($validated) { |
if($validated) { |
| my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd. |
my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd. |
| |
|
|
Line 1605 sub change_password_handler {
|
Line 1611 sub change_password_handler {
|
| ."to change password"); |
."to change password"); |
| &Failure( $client, "non_authorized\n",$userinput); |
&Failure( $client, "non_authorized\n",$userinput); |
| } |
} |
| } elsif ($howpwd eq 'unix') { |
} elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') { |
| my $result = &change_unix_password($uname, $npass); |
my $result = &change_unix_password($uname, $npass); |
| &logthis("Result of password change for $uname: ". |
&logthis("Result of password change for $uname: ". |
| $result); |
$result); |
|
Line 1847 sub update_resource_handler {
|
Line 1853 sub update_resource_handler {
|
| my $reply=&reply("unsub:$fname","$clientname"); |
my $reply=&reply("unsub:$fname","$clientname"); |
| &devalidate_meta_cache($fname); |
&devalidate_meta_cache($fname); |
| unlink("$fname"); |
unlink("$fname"); |
| |
unlink("$fname.meta"); |
| } else { |
} else { |
| my $transname="$fname.in.transfer"; |
my $transname="$fname.in.transfer"; |
| my $remoteurl=&reply("sub:$fname","$clientname"); |
my $remoteurl=&reply("sub:$fname","$clientname"); |
|
Line 2124 sub token_auth_user_file_handler {
|
Line 2131 sub token_auth_user_file_handler {
|
| |
|
| chomp($session); |
chomp($session); |
| my $reply="non_auth\n"; |
my $reply="non_auth\n"; |
| if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id'; |
| $session.'.id')) { |
if (open(ENVIN,"$file")) { |
| flock(ENVIN,LOCK_SH); |
flock(ENVIN,LOCK_SH); |
| while (my $line=<ENVIN>) { |
tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640); |
| my ($envname)=split(/=/,$line,2); |
if (exists($disk_env{"userfile.$fname"})) { |
| $envname=&unescape($envname); |
$reply="ok\n"; |
| if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; } |
} else { |
| |
foreach my $envname (keys(%disk_env)) { |
| |
if ($envname=~ m|^userfile\.\Q$fname\E|) { |
| |
$reply="ok\n"; |
| |
last; |
| |
} |
| |
} |
| } |
} |
| |
untie(%disk_env); |
| close(ENVIN); |
close(ENVIN); |
| &Reply($client, $reply, "$cmd:$tail"); |
&Reply($client, $reply, "$cmd:$tail"); |
| } else { |
} else { |
|
Line 2594 sub get_profile_entry_encrypted {
|
Line 2608 sub get_profile_entry_encrypted {
|
| |
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput); |
my ($udom,$uname,$namespace,$what) = split(/:/,$tail); |
| chomp($what); |
chomp($what); |
| my $qresult = read_profile($udom, $uname, $namespace, $what); |
my $qresult = read_profile($udom, $uname, $namespace, $what); |
| my ($first) = split(/:/, $qresult); |
my ($first) = split(/:/, $qresult); |
|
Line 3039 sub restore_handler {
|
Line 3053 sub restore_handler {
|
| my ($cmd, $tail, $client) = @_; |
my ($cmd, $tail, $client) = @_; |
| |
|
| my $userinput = "$cmd:$tail"; # Only used for logging purposes. |
my $userinput = "$cmd:$tail"; # Only used for logging purposes. |
| |
my ($udom,$uname,$namespace,$rid) = split(/:/,$tail); |
| my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput); |
|
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
| $namespace=~s/\W//g; |
$namespace = &LONCAPA::clean_username($namespace); |
| |
|
| chomp($rid); |
chomp($rid); |
| my $qresult=''; |
my $qresult=''; |
| my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); |
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); |
|
Line 3215 sub reply_query_handler {
|
Line 3229 sub reply_query_handler {
|
| |
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| my ($cmd,$id,$reply)=split(/:/,$userinput); |
my ($id,$reply)=split(/:/,$tail); |
| my $store; |
my $store; |
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| if ($store=IO::File->new(">$execdir/tmp/$id")) { |
if ($store=IO::File->new(">$execdir/tmp/$id")) { |
|
Line 3279 sub put_course_id_handler {
|
Line 3293 sub put_course_id_handler {
|
| foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
| my ($key,$courseinfo) = split(/=/,$pair,2); |
my ($key,$courseinfo) = split(/=/,$pair,2); |
| $courseinfo =~ s/=/:/g; |
$courseinfo =~ s/=/:/g; |
| |
my @current_items = split(/:/,$hashref->{$key},-1); |
| my @current_items = split(/:/,$hashref->{$key}); |
|
| shift(@current_items); # remove description |
shift(@current_items); # remove description |
| pop(@current_items); # remove last access |
pop(@current_items); # remove last access |
| my $numcurrent = scalar(@current_items); |
my $numcurrent = scalar(@current_items); |
| |
if ($numcurrent > 3) { |
| my @new_items = split(/:/,$courseinfo); |
$numcurrent = 3; |
| |
} |
| |
my @new_items = split(/:/,$courseinfo,-1); |
| my $numnew = scalar(@new_items); |
my $numnew = scalar(@new_items); |
| if ($numcurrent > 0) { |
if ($numcurrent > 0) { |
| if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier |
if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 |
| $courseinfo .= ':'.join(':',@current_items); |
for (my $j=$numcurrent-$numnew; $j>=0; $j--) { |
| } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X |
$courseinfo .= ':'.$current_items[$numcurrent-$j-1]; |
| $courseinfo .= ':'.$current_items[$numcurrent-1]; |
} |
| } |
} |
| } |
} |
| $hashref->{$key}=$courseinfo.':'.$now; |
$hashref->{$key}=$courseinfo.':'.$now; |
|
Line 3335 sub put_course_id_handler {
|
Line 3350 sub put_course_id_handler {
|
| # institutional code - optional supplied code to filter |
# institutional code - optional supplied code to filter |
| # the dump. Only courses with an institutional code |
# the dump. Only courses with an institutional code |
| # that match the supplied code will be returned. |
# that match the supplied code will be returned. |
| # owner - optional supplied username of owner to filter |
# owner - optional supplied username and domain of owner to |
| # the dump. Only courses for which the course |
# filter the dump. Only courses for which the course |
| # owner matches the supplied username will be |
# owner matches the supplied username and/or domain |
| # returned. Implicit assumption that owner |
# will be returned. Pre-2.2.0 legacy entries from |
| # is a user in the domain in which the |
# nohist_courseiddump will only contain usernames. |
| # course database is defined. |
|
| # $client - The socket open on the client. |
# $client - The socket open on the client. |
| # Returns: |
# Returns: |
| # 1 - Continue processing. |
# 1 - Continue processing. |
|
Line 3351 sub dump_course_id_handler {
|
Line 3365 sub dump_course_id_handler {
|
| |
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail); |
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, |
| |
$typefilter,$regexp_ok) =split(/:/,$tail); |
| if (defined($description)) { |
if (defined($description)) { |
| $description=&unescape($description); |
$description=&unescape($description); |
| } else { |
} else { |
|
Line 3362 sub dump_course_id_handler {
|
Line 3377 sub dump_course_id_handler {
|
| } else { |
} else { |
| $instcodefilter='.'; |
$instcodefilter='.'; |
| } |
} |
| |
my ($ownerunamefilter,$ownerdomfilter); |
| if (defined($ownerfilter)) { |
if (defined($ownerfilter)) { |
| $ownerfilter=&unescape($ownerfilter); |
$ownerfilter=&unescape($ownerfilter); |
| |
if ($ownerfilter ne '.' && defined($ownerfilter)) { |
| |
if ($ownerfilter =~ /^([^:]*):([^:]*)$/) { |
| |
$ownerunamefilter = $1; |
| |
$ownerdomfilter = $2; |
| |
} else { |
| |
$ownerunamefilter = $ownerfilter; |
| |
$ownerdomfilter = ''; |
| |
} |
| |
} |
| } else { |
} else { |
| $ownerfilter='.'; |
$ownerfilter='.'; |
| } |
} |
| |
|
| if (defined($coursefilter)) { |
if (defined($coursefilter)) { |
| $coursefilter=&unescape($coursefilter); |
$coursefilter=&unescape($coursefilter); |
| } else { |
} else { |
| $coursefilter='.'; |
$coursefilter='.'; |
| } |
} |
| |
if (defined($typefilter)) { |
| |
$typefilter=&unescape($typefilter); |
| |
} else { |
| |
$typefilter='.'; |
| |
} |
| |
if (defined($regexp_ok)) { |
| |
$regexp_ok=&unescape($regexp_ok); |
| |
} |
| |
|
| unless (defined($since)) { $since=0; } |
unless (defined($since)) { $since=0; } |
| my $qresult=''; |
my $qresult=''; |
| my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); |
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); |
| if ($hashref) { |
if ($hashref) { |
| while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
| my ($descr,$lasttime,$inst_code,$owner); |
my ($descr,$lasttime,$inst_code,$owner,$type); |
| my @courseitems = split(/:/,$value); |
my @courseitems = split(/:/,$value); |
| $lasttime = pop(@courseitems); |
$lasttime = pop(@courseitems); |
| ($descr,$inst_code,$owner)=@courseitems; |
($descr,$inst_code,$owner,$type)=@courseitems; |
| if ($lasttime<$since) { next; } |
if ($lasttime<$since) { next; } |
| my $match = 1; |
my $match = 1; |
| unless ($description eq '.') { |
unless ($description eq '.') { |
|
Line 3392 sub dump_course_id_handler {
|
Line 3426 sub dump_course_id_handler {
|
| } |
} |
| unless ($instcodefilter eq '.' || !defined($instcodefilter)) { |
unless ($instcodefilter eq '.' || !defined($instcodefilter)) { |
| my $unescapeInstcode = &unescape($inst_code); |
my $unescapeInstcode = &unescape($inst_code); |
| unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) { |
if ($regexp_ok) { |
| $match = 0; |
unless (eval('$unescapeInstcode=~/$instcodefilter/')) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) { |
| |
$match = 0; |
| |
} |
| } |
} |
| } |
} |
| unless ($ownerfilter eq '.' || !defined($ownerfilter)) { |
unless ($ownerfilter eq '.' || !defined($ownerfilter)) { |
| my $unescapeOwner = &unescape($owner); |
my $unescapeOwner = &unescape($owner); |
| unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) { |
if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) { |
| $match = 0; |
if ($unescapeOwner =~ /:/) { |
| |
if (eval('$unescapeOwner !~ |
| |
/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} elsif ($ownerunamefilter ne '') { |
| |
if ($unescapeOwner =~ /:/) { |
| |
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} elsif ($ownerdomfilter ne '') { |
| |
if ($unescapeOwner =~ /:/) { |
| |
if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
if ($ownerdomfilter ne $udom) { |
| |
$match = 0; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| unless ($coursefilter eq '.' || !defined($coursefilter)) { |
unless ($coursefilter eq '.' || !defined($coursefilter)) { |
|
Line 3408 sub dump_course_id_handler {
|
Line 3477 sub dump_course_id_handler {
|
| $match = 0; |
$match = 0; |
| } |
} |
| } |
} |
| |
unless ($typefilter eq '.' || !defined($typefilter)) { |
| |
my $unescapeType = &unescape($type); |
| |
if ($type eq '') { |
| |
if ($typefilter ne 'Course') { |
| |
$match = 0; |
| |
} |
| |
} else { |
| |
unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
} |
| if ($match == 1) { |
if ($match == 1) { |
| $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
| } |
} |
|
Line 3430 sub dump_course_id_handler {
|
Line 3511 sub dump_course_id_handler {
|
| ®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); |
®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); |
| |
|
| # |
# |
| |
# Puts an unencrypted entry in a namespace db file at the domain level |
| |
# |
| |
# Parameters: |
| |
# $cmd - The command that got us here. |
| |
# $tail - Tail of the command (remaining parameters). |
| |
# $client - File descriptor connected to client. |
| |
# Returns |
| |
# 0 - Requested to exit, caller should shut down. |
| |
# 1 - Continue processing. |
| |
# Side effects: |
| |
# reply is written to $client. |
| |
# |
| |
sub put_domain_handler { |
| |
my ($cmd,$tail,$client) = @_; |
| |
|
| |
my $userinput = "$cmd:$tail"; |
| |
|
| |
my ($udom,$namespace,$what) =split(/:/,$tail,3); |
| |
chomp($what); |
| |
my @pairs=split(/\&/,$what); |
| |
my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(), |
| |
"P", $what); |
| |
if ($hashref) { |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
$hashref->{$key}=$value; |
| |
} |
| |
if (&untie_domain_hash($hashref)) { |
| |
&Reply($client, "ok\n", $userinput); |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
| |
"while attempting putdom\n", $userinput); |
| |
} |
| |
} else { |
| |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
| |
"while attempting putdom\n", $userinput); |
| |
} |
| |
|
| |
return 1; |
| |
} |
| |
®ister_handler("putdom", \&put_domain_handler, 0, 1, 0); |
| |
|
| |
# Unencrypted get from the namespace database file at the domain level. |
| |
# This function retrieves a keyed item from a specific named database in the |
| |
# domain directory. |
| |
# |
| |
# Parameters: |
| |
# $cmd - Command request keyword (get). |
| |
# $tail - Tail of the command. This is a colon separated list |
| |
# consisting of the domain and the 'namespace' |
| |
# which selects the gdbm file to do the lookup in, |
| |
# & separated list of keys to lookup. Note that |
| |
# the values are returned as an & separated list too. |
| |
# $client - File descriptor open on the client. |
| |
# Returns: |
| |
# 1 - Continue processing. |
| |
# 0 - Exit. |
| |
# Side effects: |
| |
# reply is written to $client. |
| |
# |
| |
|
| |
sub get_domain_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
|
| |
my $userinput = "$client:$tail"; |
| |
|
| |
my ($udom,$namespace,$what)=split(/:/,$tail,3); |
| |
chomp($what); |
| |
my @queries=split(/\&/,$what); |
| |
my $qresult=''; |
| |
my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER()); |
| |
if ($hashref) { |
| |
for (my $i=0;$i<=$#queries;$i++) { |
| |
$qresult.="$hashref->{$queries[$i]}&"; |
| |
} |
| |
if (&untie_domain_hash($hashref)) { |
| |
$qresult=~s/\&$//; |
| |
&Reply($client, "$qresult\n", $userinput); |
| |
} else { |
| |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
| |
"while attempting getdom\n",$userinput); |
| |
} |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". |
| |
"while attempting getdom\n",$userinput); |
| |
} |
| |
|
| |
return 1; |
| |
} |
| |
®ister_handler("getdom", \&get_domain_handler, 0, 1, 0); |
| |
|
| |
|
| |
# |
| # Puts an id to a domains id database. |
# Puts an id to a domains id database. |
| # |
# |
| # Parameters: |
# Parameters: |
|
Line 3800 sub tmp_put_handler {
|
Line 3974 sub tmp_put_handler {
|
| |
|
| my $userinput = "$cmd:$what"; # Reconstruct for logging. |
my $userinput = "$cmd:$what"; # Reconstruct for logging. |
| |
|
| |
my ($record,$context) = split(/:/,$what); |
| my $store; |
if ($context ne '') { |
| |
chomp($context); |
| |
$context = &unescape($context); |
| |
} |
| |
my ($id,$store); |
| $tmpsnum++; |
$tmpsnum++; |
| my $id=$$.'_'.$clientip.'_'.$tmpsnum; |
if ($context eq 'resetpw') { |
| |
$id = &md5_hex(&md5_hex(time.{}.rand().$$)); |
| |
} else { |
| |
$id = $$.'_'.$clientip.'_'.$tmpsnum; |
| |
} |
| $id=~s/\W/\_/g; |
$id=~s/\W/\_/g; |
| $what=~s/\n//g; |
$record=~s/\n//g; |
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { |
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { |
| print $store $what; |
print $store $record; |
| close $store; |
close $store; |
| &Reply($client, "$id\n", $userinput); |
&Reply($client, "$id\n", $userinput); |
| } else { |
} else { |
|
Line 4025 sub enrollment_enabled_handler {
|
Line 4207 sub enrollment_enabled_handler {
|
| my $userinput = $cmd.":".$tail; # For logging purposes. |
my $userinput = $cmd.":".$tail; # For logging purposes. |
| |
|
| |
|
| my $cdom = split(/:/, $tail); # Domain we're asking about. |
my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about. |
| |
|
| my $outcome = &localenroll::run($cdom); |
my $outcome = &localenroll::run($cdom); |
| &Reply($client, "$outcome\n", $userinput); |
&Reply($client, "$outcome\n", $userinput); |
| |
|
|
Line 4081 sub validate_course_owner_handler {
|
Line 4264 sub validate_course_owner_handler {
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); |
my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); |
| |
|
| |
$owner = &unescape($owner); |
| my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); |
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); |
| &Reply($client, "$outcome\n", $userinput); |
&Reply($client, "$outcome\n", $userinput); |
| |
|
|
Line 4121 sub validate_course_section_handler {
|
Line 4305 sub validate_course_section_handler {
|
| ®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0); |
®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0); |
| |
|
| # |
# |
| # Create a password for a new auto-enrollment user. |
# Validate course owner's access to enrollment data for specific class section. |
| # I think/guess, this password allows access to the institutions |
# |
| # AIS class list server/services. Stuart can correct this comment |
# |
| # when he finds out how wrong I am. |
# Formal Parameters: |
| |
# $cmd - The command request that got us dispatched. |
| |
# $tail - The tail of the command. In this case this is a colon separated |
| |
# set of words that will be split into: |
| |
# $inst_class - Institutional code for the specific class section |
| |
# $courseowner - The escaped username:domain of the course owner |
| |
# $cdom - The domain of the course from the institution's |
| |
# point of view. |
| |
# $client - The socket open on the client. |
| |
# Returns: |
| |
# 1 - continue processing. |
| |
# |
| |
|
| |
sub validate_class_access_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
my ($inst_class,$courseowner,$cdom) = split(/:/, $tail); |
| |
$courseowner = &unescape($courseowner); |
| |
my $outcome; |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
$outcome=&localenroll::check_section($inst_class,$courseowner,$cdom); |
| |
}; |
| |
&Reply($client,"$outcome\n", $userinput); |
| |
|
| |
return 1; |
| |
} |
| |
®ister_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0); |
| |
|
| |
# |
| |
# Create a password for a new LON-CAPA user added by auto-enrollment. |
| |
# Only used for case where authentication method for new user is localauth |
| # |
# |
| # Formal Parameters: |
# Formal Parameters: |
| # $cmd - The command request that got us dispatched. |
# $cmd - The command request that got us dispatched. |
| # $tail - The tail of the command. In this case this is a colon separated |
# $tail - The tail of the command. In this case this is a colon separated |
| # set of words that will be split into: |
# set of words that will be split into: |
| # $authparam - An authentication parameter (username??). |
# $authparam - An authentication parameter (localauth parameter). |
| # $cdom - The domain of the course from the institution's |
# $cdom - The domain of the course from the institution's |
| # point of view. |
# point of view. |
| # $client - The socket open on the client. |
# $client - The socket open on the client. |
|
Line 4257 sub get_institutional_code_format_handle
|
Line 4472 sub get_institutional_code_format_handle
|
| ®ister_handler("autoinstcodeformat", |
®ister_handler("autoinstcodeformat", |
| \&get_institutional_code_format_handler,0,1,0); |
\&get_institutional_code_format_handler,0,1,0); |
| |
|
| |
sub get_institutional_defaults_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
|
| |
my $dom = $tail; |
| |
my %defaults_hash; |
| |
my @code_order; |
| |
my $outcome; |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
$outcome = &localenroll::instcode_defaults($dom,\%defaults_hash, |
| |
\@code_order); |
| |
}; |
| |
if (!$@) { |
| |
if ($outcome eq 'ok') { |
| |
my $result=''; |
| |
while (my ($key,$value) = each(%defaults_hash)) { |
| |
$result.=&escape($key).'='.&escape($value).'&'; |
| |
} |
| |
$result .= 'code_order='.&escape(join('&',@code_order)); |
| |
&Reply($client,$result."\n",$userinput); |
| |
} else { |
| |
&Reply($client,"error\n", $userinput); |
| |
} |
| |
} else { |
| |
&Failure($client,"unknown_cmd\n",$userinput); |
| |
} |
| |
} |
| |
®ister_handler("autoinstcodedefaults", |
| |
\&get_institutional_defaults_handler,0,1,0); |
| |
|
| |
|
| # Get domain specific conditions for import of student photographs to a course |
# Get domain specific conditions for import of student photographs to a course |
| # |
# |
| # Retrieves information from photo_permission subroutine in localenroll. |
# Retrieves information from photo_permission subroutine in localenroll. |
|
Line 4384 sub student_photo_handler {
|
Line 4631 sub student_photo_handler {
|
| } |
} |
| ®ister_handler("studentphoto", \&student_photo_handler, 0, 1, 0); |
®ister_handler("studentphoto", \&student_photo_handler, 0, 1, 0); |
| |
|
| |
sub inst_usertypes_handler { |
| |
my ($cmd, $domain, $client) = @_; |
| |
my $res; |
| |
my $userinput = $cmd.":".$domain; # For logging purposes. |
| |
my (%typeshash,@order); |
| |
if (&localenroll::inst_usertypes($domain,\%typeshash,\@order) eq 'ok') { |
| |
if (keys(%typeshash) > 0) { |
| |
foreach my $key (keys(%typeshash)) { |
| |
$res.=&escape($key).'='.&escape($typeshash{$key}).'&'; |
| |
} |
| |
} |
| |
$res=~s/\&$//; |
| |
$res .= ':'; |
| |
if (@order > 0) { |
| |
foreach my $item (@order) { |
| |
$res .= &escape($item).'&'; |
| |
} |
| |
} |
| |
$res=~s/\&$//; |
| |
} |
| |
&Reply($client, "$res\n", $userinput); |
| |
return 1; |
| |
} |
| |
®ister_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0); |
| |
|
| # mkpath makes all directories for a file, expects an absolute path with a |
# mkpath makes all directories for a file, expects an absolute path with a |
| # file or a trailing / if just a dir is passed |
# file or a trailing / if just a dir is passed |
| # returns 1 on success 0 on failure |
# returns 1 on success 0 on failure |
|
Line 5037 sub reconlonc {
|
Line 5309 sub reconlonc {
|
| } |
} |
| } |
} |
| |
|
| # -------------------------------------------------- Non-critical communication |
sub create_connection { |
| |
my ($server) = @_; |
| |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
return 0 if (!$client); |
| |
print $client ("$server\n"); |
| |
my $result = <$client>; |
| |
chomp($result); |
| |
return 1 if ($result eq 'done'); |
| |
return 0; |
| |
} |
| |
|
| |
# -------------------------------------------------- Non-critical communication |
| |
my $max_connection_retries = 10; |
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; |
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; |
| my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
my $sclient; |
| Type => SOCK_STREAM, |
for (my $retries = 0; $retries < $max_connection_retries; $retries++) { |
| Timeout => 10) |
$sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
| or return "con_lost"; |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
if($sclient) { |
| |
last; # Connected! |
| |
} else { |
| |
&create_connection($hostname{$server}); |
| |
} |
| |
sleep(1); # Try again later if failed connection. |
| |
} |
| print $sclient "sethost:$server:$cmd\n"; |
print $sclient "sethost:$server:$cmd\n"; |
| my $answer=<$sclient>; |
my $answer=<$sclient>; |
| chomp($answer); |
chomp($answer); |
|
Line 5220 sub make_new_child {
|
Line 5513 sub make_new_child {
|
| # my $tmpsnum=0; # Now global |
# my $tmpsnum=0; # Now global |
| #---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
| &Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
| unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) { |
unless (($dist eq 'fedora5') || ($dist eq 'fedora4') || |
| |
($dist eq 'fedora6') || ($dist eq 'suse9.3')) { |
| &Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
| } |
} |
| |
|
|
Line 5261 sub make_new_child {
|
Line 5555 sub make_new_child {
|
| my $remotereq=<$client>; |
my $remotereq=<$client>; |
| chomp($remotereq); |
chomp($remotereq); |
| Debug("Got init: $remotereq"); |
Debug("Got init: $remotereq"); |
| my $inikeyword = split(/:/, $remotereq); |
|
| if ($remotereq =~ /^init/) { |
if ($remotereq =~ /^init/) { |
| &sethost("sethost:$perlvar{'lonHostID'}"); |
&sethost("sethost:$perlvar{'lonHostID'}"); |
| # |
# |
|
Line 5633 sub validate_user {
|
Line 5927 sub validate_user {
|
| my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; |
my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; |
| my $krbserver = &Authen::Krb5::parse_name($krbservice); |
my $krbserver = &Authen::Krb5::parse_name($krbservice); |
| my $credentials= &Authen::Krb5::cc_default(); |
my $credentials= &Authen::Krb5::cc_default(); |
| $credentials->initialize($krbclient); |
$credentials->initialize(&Authen::Krb5::parse_name($user.'@' |
| |
.$contentpwd)); |
| my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, |
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, |
| $krbserver, |
$krbserver, |
| $password, |
$password, |
|
Line 5646 sub validate_user {
|
Line 5941 sub validate_user {
|
| # Authenticate via installation specific authentcation method: |
# Authenticate via installation specific authentcation method: |
| $validated = &localauth::localauth($user, |
$validated = &localauth::localauth($user, |
| $password, |
$password, |
| $contentpwd); |
$contentpwd, |
| |
$domain); |
| |
if ($validated < 0) { |
| |
&logthis("localauth for $contentpwd $user:$domain returned a $validated"); |
| |
$validated = 0; |
| |
} |
| } else { # Unrecognized auth is also bad. |
} else { # Unrecognized auth is also bad. |
| $validated = 0; |
$validated = 0; |
| } |
} |
|
Line 5672 sub addline {
|
Line 5972 sub addline {
|
| my ($fname,$hostid,$ip,$newline)=@_; |
my ($fname,$hostid,$ip,$newline)=@_; |
| my $contents; |
my $contents; |
| my $found=0; |
my $found=0; |
| my $expr='^'.$hostid.':'.$ip.':'; |
my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':'; |
| $expr =~ s/\./\\\./g; |
|
| my $sh; |
my $sh; |
| if ($sh=IO::File->new("$fname.subscription")) { |
if ($sh=IO::File->new("$fname.subscription")) { |
| while (my $subline=<$sh>) { |
while (my $subline=<$sh>) { |
|
Line 5694 sub get_chat {
|
Line 5993 sub get_chat {
|
| my @entries=(); |
my @entries=(); |
| my $namespace = 'nohist_chatroom'; |
my $namespace = 'nohist_chatroom'; |
| my $namespace_inroom = 'nohist_inchatroom'; |
my $namespace_inroom = 'nohist_inchatroom'; |
| if (defined($group)) { |
if ($group ne '') { |
| $namespace .= '_'.$group; |
$namespace .= '_'.$group; |
| $namespace_inroom .= '_'.$group; |
$namespace_inroom .= '_'.$group; |
| } |
} |
|
Line 5726 sub chat_add {
|
Line 6025 sub chat_add {
|
| my $time=time; |
my $time=time; |
| my $namespace = 'nohist_chatroom'; |
my $namespace = 'nohist_chatroom'; |
| my $logfile = 'chatroom.log'; |
my $logfile = 'chatroom.log'; |
| if (defined($group)) { |
if ($group ne '') { |
| $namespace .= '_'.$group; |
$namespace .= '_'.$group; |
| $logfile = 'chatroom_'.$group.'.log'; |
$logfile = 'chatroom_'.$group.'.log'; |
| } |
} |
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom