version 1.305.2.2, 2006/02/02 10:32:31
|
version 1.323, 2006/03/04 00:59:59
|
Line 89 my $ConnectionType;
|
Line 89 my $ConnectionType;
|
|
|
my %hostid; # ID's for hosts in cluster by ip. |
my %hostid; # ID's for hosts in cluster by ip. |
my %hostdom; # LonCAPA domain for hosts in cluster. |
my %hostdom; # LonCAPA domain for hosts in cluster. |
|
my %hostname; # DNSname -> ID's mapping. |
my %hostip; # IPs for hosts in cluster. |
my %hostip; # IPs for hosts in cluster. |
my %hostdns; # ID's of hosts looked up by DNS name. |
my %hostdns; # ID's of hosts looked up by DNS name. |
|
|
Line 2975 sub dump_with_regexp {
|
Line 2976 sub dump_with_regexp {
|
|
|
my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
|
|
my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); |
my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail); |
if (defined($regexp)) { |
if (defined($regexp)) { |
$regexp=&unescape($regexp); |
$regexp=&unescape($regexp); |
} else { |
} else { |
$regexp='.'; |
$regexp='.'; |
} |
} |
|
my ($start,$end); |
|
if (defined($range)) { |
|
if ($range =~/^(\d+)\-(\d+)$/) { |
|
($start,$end) = ($1,$2); |
|
} elsif ($range =~/^(\d+)$/) { |
|
($start,$end) = (0,$1); |
|
} else { |
|
undef($range); |
|
} |
|
} |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
&GDBM_READER()); |
&GDBM_READER()); |
if ($hashref) { |
if ($hashref) { |
my $qresult=''; |
my $qresult=''; |
|
my $count=0; |
while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
if ($regexp eq '.') { |
if ($regexp eq '.') { |
|
$count++; |
|
if (defined($range) && $count >= $end) { last; } |
|
if (defined($range) && $count < $start) { next; } |
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} else { |
} else { |
my $unescapeKey = &unescape($key); |
my $unescapeKey = &unescape($key); |
if (eval('$unescapeKey=~/$regexp/')) { |
if (eval('$unescapeKey=~/$regexp/')) { |
|
$count++; |
|
if (defined($range) && $count >= $end) { last; } |
|
if (defined($range) && $count < $start) { next; } |
$qresult.="$key=$value&"; |
$qresult.="$key=$value&"; |
} |
} |
} |
} |
Line 3075 sub store_handler {
|
Line 3093 sub store_handler {
|
} |
} |
®ister_handler("store", \&store_handler, 0, 1, 0); |
®ister_handler("store", \&store_handler, 0, 1, 0); |
|
|
|
# Modify a set of key=value pairs associated with a versioned name. |
|
# |
|
# Parameters: |
|
# $cmd - Request command keyword. |
|
# $tail - Tail of the request. This is a colon |
|
# separated list containing: |
|
# domain/user - User and authentication domain. |
|
# namespace - Name of the database being modified |
|
# rid - Resource keyword to modify. |
|
# v - Version item to modify |
|
# what - new value associated with rid. |
|
# |
|
# $client - Socket open on the client. |
|
# |
|
# |
|
# Returns: |
|
# 1 (keep on processing). |
|
# Side-Effects: |
|
# Writes to the client |
|
sub putstore_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
|
|
my $userinput = "$cmd:$tail"; |
|
|
|
my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail); |
|
if ($namespace ne 'roles') { |
|
|
|
chomp($what); |
|
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
|
&GDBM_WRCREAT(), "M", |
|
"$rid:$v:$what"); |
|
if ($hashref) { |
|
my $now = time; |
|
my %data = &hash_extract($what); |
|
my @allkeys; |
|
while (my($key,$value) = each(%data)) { |
|
push(@allkeys,$key); |
|
$hashref->{"$v:$rid:$key"} = $value; |
|
} |
|
my $allkeys = join(':',@allkeys); |
|
$hashref->{"$v:keys:$rid"}=$allkeys; |
|
|
|
if (&untie_user_hash($hashref)) { |
|
&Reply($client, "ok\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting store\n", $userinput); |
|
} |
|
} else { |
|
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
|
"while attempting store\n", $userinput); |
|
} |
|
} else { |
|
&Failure($client, "refused\n", $userinput); |
|
} |
|
|
|
return 1; |
|
} |
|
®ister_handler("putstore", \&putstore_handler, 0, 1, 0); |
|
|
|
sub hash_extract { |
|
my ($str)=@_; |
|
my %hash; |
|
foreach my $pair (split(/\&/,$str)) { |
|
my ($key,$value)=split(/=/,$pair); |
|
$hash{$key}=$value; |
|
} |
|
return (%hash); |
|
} |
|
sub hash_to_str { |
|
my ($hash_ref)=@_; |
|
my $str; |
|
foreach my $key (keys(%$hash_ref)) { |
|
$str.=$key.'='.$hash_ref->{$key}.'&'; |
|
} |
|
$str=~s/\&$//; |
|
return $str; |
|
} |
|
|
# |
# |
# Dump out all versions of a resource that has key=value pairs associated |
# Dump out all versions of a resource that has key=value pairs associated |
# with it for each version. These resources are built up via the store |
# with it for each version. These resources are built up via the store |
Line 4318 sub get_institutional_code_format_handle
|
Line 4415 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); |
|
|
|
# Get domain specific conditions for import of student photographs to a course |
|
# |
|
# Retrieves information from photo_permission subroutine in localenroll. |
|
# Returns outcome (ok) if no processing errors, and whether course owner is |
|
# required to accept conditions of use (yes/no). |
|
# |
|
# |
|
sub photo_permission_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
my $cdom = $tail; |
|
my ($perm_reqd,$conditions); |
|
my $outcome; |
|
eval { |
|
local($SIG{__DIE__})='DEFAULT'; |
|
$outcome = &localenroll::photo_permission($cdom,\$perm_reqd, |
|
\$conditions); |
|
}; |
|
if (!$@) { |
|
&Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n", |
|
$userinput); |
|
} else { |
|
&Failure($client,"unknown_cmd\n",$userinput); |
|
} |
|
return 1; |
|
} |
|
®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0); |
|
|
|
# |
|
# Checks if student photo is available for a user in the domain, in the user's |
|
# directory (in /userfiles/internal/studentphoto.jpg). |
|
# Uses localstudentphoto:fetch() to ensure there is an up to date copy of |
|
# the student's photo. |
|
|
|
sub photo_check_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
my ($udom,$uname,$pid) = split(/:/,$tail); |
|
$udom = &unescape($udom); |
|
$uname = &unescape($uname); |
|
$pid = &unescape($pid); |
|
my $path=&propath($udom,$uname).'/userfiles/internal/'; |
|
if (!-e $path) { |
|
&mkpath($path); |
|
} |
|
my $response; |
|
my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response); |
|
$result .= ':'.$response; |
|
&Reply($client, &escape($result)."\n",$userinput); |
|
return 1; |
|
} |
|
®ister_handler("autophotocheck",\&photo_check_handler,0,1,0); |
|
|
|
# |
|
# Retrieve information from localenroll about whether to provide a button |
|
# for users who have enbled import of student photos to initiate an |
|
# update of photo files for registered students. Also include |
|
# comment to display alongside button. |
|
|
|
sub photo_choice_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
my $cdom = &unescape($tail); |
|
my ($update,$comment); |
|
eval { |
|
local($SIG{__DIE__})='DEFAULT'; |
|
($update,$comment) = &localenroll::manager_photo_update($cdom); |
|
}; |
|
if (!$@) { |
|
&Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput); |
|
} else { |
|
&Failure($client,"unknown_cmd\n",$userinput); |
|
} |
|
return 1; |
|
} |
|
®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0); |
|
|
# |
# |
# Gets a student's photo to exist (in the correct image type) in the user's |
# Gets a student's photo to exist (in the correct image type) in the user's |
# directory. |
# directory. |
Line 4330 sub get_institutional_code_format_handle
|
Line 4504 sub get_institutional_code_format_handle
|
# $client - The socket open on the client. |
# $client - The socket open on the client. |
# Returns: |
# Returns: |
# 1 - continue processing. |
# 1 - continue processing. |
|
|
sub student_photo_handler { |
sub student_photo_handler { |
my ($cmd, $tail, $client) = @_; |
my ($cmd, $tail, $client) = @_; |
my ($domain,$uname,$type) = split(/:/, $tail); |
my ($domain,$uname,$ext,$type) = split(/:/, $tail); |
|
|
my $path=&propath($domain,$uname). |
my $path=&propath($domain,$uname). '/userfiles/internal/'; |
'/userfiles/internal/studentphoto.'.$type; |
my $filename = 'studentphoto.'.$ext; |
if (-e $path) { |
if ($type eq 'thumbnail') { |
|
$filename = 'studentphoto_tn.'.$ext; |
|
} |
|
if (-e $path.$filename) { |
&Reply($client,"ok\n","$cmd:$tail"); |
&Reply($client,"ok\n","$cmd:$tail"); |
return 1; |
return 1; |
} |
} |
&mkpath($path); |
&mkpath($path); |
my $file=&localstudentphoto::fetch($domain,$uname); |
my $file; |
|
if ($type eq 'thumbnail') { |
|
eval { |
|
local($SIG{__DIE__})='DEFAULT'; |
|
$file=&localstudentphoto::fetch_thumbnail($domain,$uname); |
|
}; |
|
} else { |
|
$file=&localstudentphoto::fetch($domain,$uname); |
|
} |
if (!$file) { |
if (!$file) { |
&Failure($client,"unavailable\n","$cmd:$tail"); |
&Failure($client,"unavailable\n","$cmd:$tail"); |
return 1; |
return 1; |
} |
} |
if (!-e $path) { &convert_photo($file,$path); } |
if (!-e $path.$filename) { &convert_photo($file,$path.$filename); } |
if (-e $path) { |
if (-e $path.$filename) { |
&Reply($client,"ok\n","$cmd:$tail"); |
&Reply($client,"ok\n","$cmd:$tail"); |
return 1; |
return 1; |
} |
} |
Line 4408 sub process_request {
|
Line 4594 sub process_request {
|
# fix all the userinput -> user_input. |
# fix all the userinput -> user_input. |
my $wasenc = 0; # True if request was encrypted. |
my $wasenc = 0; # True if request was encrypted. |
# ------------------------------------------------------------ See if encrypted |
# ------------------------------------------------------------ See if encrypted |
|
# for command |
|
# sethost:<server> |
|
# <command>:<args> |
|
# we just send it to the processor |
|
# for |
|
# sethost:<server>:<command>:<args> |
|
# we do the implict set host and then do the command |
|
if ($userinput =~ /^sethost:/) { |
|
(my $cmd,my $newid,$userinput) = split(':',$userinput,3); |
|
if (defined($userinput)) { |
|
&sethost("$cmd:$newid"); |
|
} else { |
|
$userinput = "$cmd:$newid"; |
|
} |
|
} |
|
|
if ($userinput =~ /^enc/) { |
if ($userinput =~ /^enc/) { |
$userinput = decipher($userinput); |
$userinput = decipher($userinput); |
$wasenc=1; |
$wasenc=1; |
Line 4762 sub ReadHostTable {
|
Line 4964 sub ReadHostTable {
|
} |
} |
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
|
$hostname{$id}=$name; # LonCAPA name -> DNS name |
$hostip{$id}=$ip; # IP address of host. |
$hostip{$id}=$ip; # IP address of host. |
$hostdns{$name} = $id; # LonCAPA name of host by DNS. |
$hostdns{$name} = $id; # LonCAPA name of host by DNS. |
|
|
Line 5012 sub reconlonc {
|
Line 5215 sub reconlonc {
|
|
|
sub subreply { |
sub subreply { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; |
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
Timeout => 10) |
Timeout => 10) |
or return "con_lost"; |
or return "con_lost"; |
print $sclient "$cmd\n"; |
print $sclient "sethost:$server:$cmd\n"; |
my $answer=<$sclient>; |
my $answer=<$sclient>; |
chomp($answer); |
chomp($answer); |
if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
Line 5033 sub reply {
|
Line 5236 sub reply {
|
$answer=subreply("ping",$server); |
$answer=subreply("ping",$server); |
if ($answer ne $server) { |
if ($answer ne $server) { |
&logthis("sub reply: answer != server answer is $answer, server is $server"); |
&logthis("sub reply: answer != server answer is $answer, server is $server"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server}); |
} |
} |
$answer=subreply($cmd,$server); |
$answer=subreply($cmd,$server); |
} |
} |
Line 5060 sub sub_sql_reply {
|
Line 5263 sub sub_sql_reply {
|
Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
Timeout => 10) |
Timeout => 10) |
or return "con_lost"; |
or return "con_lost"; |
print $sclient "$cmd\n"; |
print $sclient "$cmd:$currentdomainid\n"; |
my $answer=<$sclient>; |
my $answer=<$sclient>; |
chomp($answer); |
chomp($answer); |
if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
Line 5339 sub make_new_child {
|
Line 5542 sub make_new_child {
|
# no need to try to do recon's to myself |
# no need to try to do recon's to myself |
next; |
next; |
} |
} |
&reconlonc("$perlvar{'lonSockDir'}/$id"); |
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id}); |
} |
} |
&logthis("<font color='green'>Established connection: $clientname</font>"); |
&logthis("<font color='green'>Established connection: $clientname</font>"); |
&status('Will listen to '.$clientname); |
&status('Will listen to '.$clientname); |
Line 5395 sub is_author {
|
Line 5598 sub is_author {
|
|
|
# Author role should show up as a key /domain/_au |
# Author role should show up as a key /domain/_au |
|
|
my $key = "/$domain/_au"; |
my $key = "/$domain/_au"; |
my $value = $hashref->{$key}; |
my $value; |
|
if (defined($hashref)) { |
|
$value = $hashref->{$key}; |
|
} |
|
|
if(defined($value)) { |
if(defined($value)) { |
&Debug("$user @ $domain is an author"); |
&Debug("$user @ $domain is an author"); |
Line 5996 sub convert_photo {
|
Line 6202 sub convert_photo {
|
sub sethost { |
sub sethost { |
my ($remotereq) = @_; |
my ($remotereq) = @_; |
my (undef,$hostid)=split(/:/,$remotereq); |
my (undef,$hostid)=split(/:/,$remotereq); |
|
# ignore sethost if we are already correct |
|
if ($hostid eq $currenthostid) { |
|
return 'ok'; |
|
} |
|
|
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } |
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } |
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { |
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { |
$currenthostid =$hostid; |
$currenthostid =$hostid; |