version 1.4, 2005/11/17 22:51:59
|
version 1.11, 2006/07/28 17:55:18
|
Line 1
|
Line 1
|
#!/usr/bin/perl |
#!/usr/bin/perl |
|
|
# The LearningOnline Network |
# The LearningOnline Network |
# lonsql - LON TCP-NSDL Query Handler. |
# lonsql - LON TCP-MySQL-Server Daemon for handling database requests. |
# |
# |
# $Id$ |
# $Id$ |
# |
# |
Line 102 the database.
|
Line 102 the database.
|
use strict; |
use strict; |
|
|
use lib '/home/httpd/lib/perl/'; |
use lib '/home/httpd/lib/perl/'; |
|
use LONCAPA; |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
use LONCAPA::lonmetadata(); |
use LONCAPA::lonmetadata(); |
|
|
Line 113 use IO::File;
|
Line 114 use IO::File;
|
use Socket; |
use Socket; |
use Fcntl; |
use Fcntl; |
use Tie::RefHash; |
use Tie::RefHash; |
use HTML::LCParser(); |
use DBI; |
use LWP::UserAgent(); |
|
use HTTP::Headers; |
|
use HTTP::Date; |
|
use File::Find; |
use File::Find; |
use localenroll; |
use localenroll; |
|
|
|
# FOR NSDL |
|
|
|
use HTML::LCParser(); |
|
use LWP::UserAgent(); |
|
use HTTP::Headers; |
|
use HTTP::Date; |
|
|
|
######################################################## |
|
######################################################## |
|
|
|
=pod |
|
|
|
=item Global Variables |
|
|
|
=over 4 |
|
|
|
=item dbh |
|
|
|
=back |
|
|
|
=cut |
|
|
|
######################################################## |
|
######################################################## |
|
my $dbh; |
|
|
######################################################## |
######################################################## |
######################################################## |
######################################################## |
|
|
Line 207 ENDMYCNF
|
Line 231 ENDMYCNF
|
|
|
|
|
# |
# |
|
# Make sure that database can be accessed |
|
# |
|
my $dbh; |
|
unless ($dbh = DBI->connect("DBI:mysql:loncapa","www", |
|
$perlvar{'lonSqlAccess'}, |
|
{ RaiseError =>0,PrintError=>0})) { |
|
print "Cannot connect to database!\n"; |
|
my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
|
my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!"; |
|
system("echo 'Cannot connect to MySQL database!' |". |
|
" mailto $emailto -s '$subj' > /dev/null"); |
|
|
|
open(SMP,'>/home/httpd/html/lon-status/mysql.txt'); |
|
print SMP 'time='.time.'&mysql=defunct'."\n"; |
|
close(SMP); |
|
|
|
exit 1; |
|
} else { |
|
unlink('/home/httpd/html/lon-status/mysql.txt'); |
|
$dbh->disconnect; |
|
} |
|
|
|
# |
# Check if other instance running |
# Check if other instance running |
# |
# |
my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; |
my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; |
Line 221 if (-e $pidfile) {
|
Line 268 if (-e $pidfile) {
|
# Read hosts file |
# Read hosts file |
# |
# |
my $thisserver; |
my $thisserver; |
|
my %hostname; |
my $PREFORK=4; # number of children to maintain, at least four spare |
my $PREFORK=4; # number of children to maintain, at least four spare |
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
while (my $configline=<CONFIG>) { |
while (my $configline=<CONFIG>) { |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
$name=~s/\s//g; |
$name=~s/\s//g; |
$thisserver=$name if ($id eq $perlvar{'lonHostID'}); |
$thisserver=$name if ($id eq $perlvar{'lonHostID'}); |
|
$hostname{$id}=$name; |
#$PREFORK++; |
#$PREFORK++; |
} |
} |
close(CONFIG); |
close(CONFIG); |
Line 325 sub make_new_child {
|
Line 374 sub make_new_child {
|
# unblock signals |
# unblock signals |
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
|
#open database handle |
|
# making dbh global to avoid garbage collector |
|
unless ($dbh = DBI->connect("DBI:mysql:loncapa","www", |
|
$perlvar{'lonSqlAccess'}, |
|
{ RaiseError =>0,PrintError=>0})) { |
|
sleep(10+int(rand(20))); |
|
&logthis("<font color='blue'>WARNING: Couldn't connect to database". |
|
": $@</font>"); |
|
# "($st secs): $@</font>"); |
|
print "database handle error\n"; |
|
exit; |
|
} |
|
# make sure that a database disconnection occurs with |
|
# ending kill signals |
$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; |
$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; |
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
Line 334 sub make_new_child {
|
Line 396 sub make_new_child {
|
$run = $run+1; |
$run = $run+1; |
my $userinput = <$client>; |
my $userinput = <$client>; |
chomp($userinput); |
chomp($userinput); |
|
$userinput=~s/\:(\w+)$//; |
|
my $searchdomain=$1; |
# |
# |
my ($conserver,$query, |
my ($conserver,$query, |
$arg1,$arg2,$arg3)=split(/&/,$userinput); |
$arg1,$arg2,$arg3)=split(/&/,$userinput); |
Line 371 sub make_new_child {
|
Line 435 sub make_new_child {
|
$result='no_such_file'; |
$result='no_such_file'; |
} |
} |
# end of log query |
# end of log query |
} elsif ($query eq 'fetchenrollment') { |
} elsif (($query eq 'fetchenrollment') || |
|
($query eq 'institutionalphotos')) { |
# retrieve institutional class lists |
# retrieve institutional class lists |
my $dom = &unescape($arg1); |
my $dom = &unescape($arg1); |
my %affiliates = (); |
my %affiliates = (); |
Line 383 sub make_new_child {
|
Line 448 sub make_new_child {
|
@{$affiliates{$1}} = split/,/,$2; |
@{$affiliates{$1}} = split/,/,$2; |
} |
} |
} |
} |
$locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies); |
if ($query eq 'fetchenrollment') { |
|
$locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies); |
|
} elsif ($query eq 'institutionalphotos') { |
|
my $crs = &unescape($arg2); |
|
eval { |
|
local($SIG{__DIE__})='DEFAULT'; |
|
$locresult = &localenroll::institutional_photos($dom,$crs,\%affiliates,\%replies,'update'); |
|
}; |
|
if ($@) { |
|
$locresult = 'error'; |
|
} |
|
} |
$result = &escape($locresult.':'); |
$result = &escape($locresult.':'); |
if ($locresult) { |
if ($locresult) { |
$result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies)); |
$result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies)); |
Line 404 sub make_new_child {
|
Line 480 sub make_new_child {
|
} |
} |
} else { |
} else { |
# Do an sql query |
# Do an sql query |
$result = &do_sql_query($query,$arg1,$arg2); |
$result = &nsdl_query($query,$arg1,$arg2,$searchdomain); |
} |
} |
# result does not need to be escaped because it has already been |
# result does not need to be escaped because it has already been |
# escaped. |
# escaped. |
Line 413 sub make_new_child {
|
Line 489 sub make_new_child {
|
} |
} |
# tidy up gracefully and finish |
# tidy up gracefully and finish |
# |
# |
|
# close the database handle |
|
$dbh->disconnect |
|
or &logthis("<font color='blue'>WARNING: Couldn't disconnect". |
|
" from database $DBI::errstr : $@</font>"); |
# this exit is VERY important, otherwise the child will become |
# this exit is VERY important, otherwise the child will become |
# a producer of more and more children, forking yourself into |
# a producer of more and more children, forking yourself into |
# process death. |
# process death. |
Line 421 sub make_new_child {
|
Line 500 sub make_new_child {
|
} |
} |
} |
} |
|
|
######################################################## |
|
######################################################## |
|
|
|
=pod |
|
|
|
=item &do_sql_query |
|
|
|
Runs an sql metadata table query. |
|
|
|
Inputs: $query, $custom, $customshow |
|
|
|
Returns: A string containing escaped results. |
|
|
|
=cut |
|
|
|
######################################################## |
######################################################## |
######################################################## |
######################################################## |
{ |
|
my @metalist; |
|
|
|
sub process_file { |
# |
if ( -e $_ && # file exists |
# Takes SQL query |
-f $_ && # and is a normal file |
# sends it to NSDL |
/\.meta$/ && # ends in meta |
# |
! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version |
|
) { |
|
push(@metalist,$File::Find::name); |
|
} |
|
} |
|
|
|
sub do_sql_query { |
sub nsdl_query { |
my ($query) = @_; |
my $query=shift; |
&logthis('doing query '.$query); |
my ($keyword)=($query=~/\"\%([^\%]+)\%\"/); |
|
$keyword=&escape($keyword); |
my @results = (); |
my $url='http://search.nsdl.org?verb=Search&s=0&n=500&q=-link.primaryCollection:oai\:nsdl.org\:nsdl.nsdl\:00254%20'.$keyword; |
|
my $ua=new LWP::UserAgent; |
# |
my $response=$ua->get($url); |
if ($query) { |
my $parser=HTML::LCParser->new(\$response->content); |
#prepare and execute the query |
my $is=''; |
my $aref=&nsdl_query($query); |
my $cont=''; |
foreach my $row (@$aref) { |
my $token; |
my @b=map { &escape($_); } @$row; |
my %result=(); |
push @results,join(",", @b); |
my $allresults=''; |
|
while ($token=$parser->get_token) { |
|
if ($token->[0] eq 'T') { |
|
$cont.=$token->[1]; |
|
} elsif ($token->[0] eq 'S') { |
|
if ($token->[1] eq 'record') { |
|
%result=(); |
|
} elsif ($token->[1]=~/^dc\:/) { |
|
$is=$token->[1]; |
|
$cont=''; |
|
} |
|
} elsif ($token->[0] eq 'E') { |
|
if ($token->[1] eq 'record') { |
|
# |
|
# Now store it away |
|
# |
|
my $url=$result{'dc:identifier'}; |
|
if ($url=~/^http\:/) { |
|
$url=~s/^http:\//\/ext/; |
|
} else { |
|
$url=''; |
|
} |
|
if ($url) { |
|
my ($mime)=($url=~/\.(\w+)$/); |
|
$mime=~tr/A-Z/a-z/; |
|
my $createdate=$result{'dc:date'}; |
|
if ($createdate) { |
|
unless ($createdate=~/\:\d+$/) { |
|
$createdate.=' 00:00:00'; |
|
} |
|
} |
|
unless ($createdate=~/^\d+\-\d+\-\d+\s+\d+\:\d+\:\d+$/) { |
|
$createdate=''; |
|
} |
|
$createdate=&escape($createdate); |
|
|
|
$allresults.='&'. |
|
&escape($result{'dc:title'}).','. |
|
&escape($result{'dc:creator'}).','. |
|
&escape($result{'dc:subject'}).','. |
|
&escape($url).',,,,'. |
|
&escape($result{'dc:description'}).','. |
|
&escape($mime).',seniso,'.$createdate.','.$createdate.','.&escape('public@nsdl'). |
|
',public,nsdl,,,,,,,,,,,,,,,,,,,,,,,,,,,,'; |
|
} |
|
%result=(); |
|
} elsif ($token->[1]=~/^dc\:/) { |
|
$result{$is}=$cont; |
|
} |
} |
} |
|
|
} |
} |
return join("&",@results); |
$allresults=~s/^\&//; |
} # End of &do_sql_query |
|
|
return $allresults; |
|
} |
|
|
|
|
} # End of scoping curly braces for &process_file and &do_sql_query |
|
######################################################## |
######################################################## |
######################################################## |
######################################################## |
|
|
Line 518 Returns: The results of the message or '
|
Line 625 Returns: The results of the message or '
|
######################################################## |
######################################################## |
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); |
$answer="con_lost" if (!$answer); |
$answer="con_lost" if (!$answer); |
Line 568 sub reply {
|
Line 675 sub reply {
|
|
|
=pod |
=pod |
|
|
=item &escape |
|
|
|
Escape special characters in a string. |
|
|
|
Inputs: string to escape |
|
|
|
Returns: The input string with special characters escaped. |
|
|
|
=cut |
|
|
|
######################################################## |
|
######################################################## |
|
sub escape { |
|
my $str=shift; |
|
$str =~ s/(\W)/"%".unpack('H2',$1)/eg; |
|
return $str; |
|
} |
|
|
|
######################################################## |
|
######################################################## |
|
|
|
=pod |
|
|
|
=item &unescape |
|
|
|
Unescape special characters in a string. |
|
|
|
Inputs: string to unescape |
|
|
|
Returns: The input string with special characters unescaped. |
|
|
|
=cut |
|
|
|
######################################################## |
|
######################################################## |
|
sub unescape { |
|
my $str=shift; |
|
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
|
return $str; |
|
} |
|
|
|
######################################################## |
|
######################################################## |
|
|
|
=pod |
|
|
|
=item &ishome |
=item &ishome |
|
|
Determine if the current machine is the home server for a user. |
Determine if the current machine is the home server for a user. |
Line 842 sub HUPSMAN { # sig
|
Line 903 sub HUPSMAN { # sig
|
exec("$execdir/lonsql"); # here we go again |
exec("$execdir/lonsql"); # here we go again |
} |
} |
|
|
# |
sub DISCONNECT { |
# Takes SQL query |
$dbh->disconnect or |
# sends it to NSDL |
&logthis("<font color='blue'>WARNING: Couldn't disconnect from database ". |
# has to return array reference |
" $DBI::errstr : $@</font>"); |
# |
exit; |
|
|
sub nsdl_query { |
|
my $query=shift; |
|
my ($keyword)=($query=~/\"\%([^\%]+)\%\"/); |
|
$keyword=&escape($keyword); |
|
&logthis('Doing '.$keyword); |
|
my $url='http://search.nsdl.org?verb=Search&s=0&n=500&q='.$keyword; |
|
my $ua=new LWP::UserAgent; |
|
my $response=$ua->get($url); |
|
my $parser=HTML::LCParser->new(\$response->content); |
|
my %result=(); |
|
my $is=(); |
|
my $cont=''; |
|
my $array=[]; |
|
my $token; |
|
while ($token=$parser->get_token) { |
|
if ($token->[0] eq 'T') { |
|
$cont.=$token->[1]; |
|
} elsif ($token->[0] eq 'S') { |
|
if ($token->[1] eq 'record') { |
|
%result=(); |
|
} elsif ($token->[1]=/^dc\:/) { |
|
$is=$token->[1]; |
|
$cont=''; |
|
} |
|
} elsif ($token->[0] eq 'E') { |
|
if ($token->[1] eq 'record') { |
|
# |
|
# Now store it away |
|
# |
|
} elsif ($token->[1]=/^dc\:/) { |
|
$result{$is}=$cont; |
|
} |
|
} |
|
} |
|
return $array; |
|
} |
} |
|
|
|
|
=pod |
=pod |
|
|
=back |
=back |