--- loncom/lonsql 2001/03/15 14:26:56 1.6 +++ loncom/lonsql 2015/08/09 21:43:11 1.95 @@ -1,167 +1,342 @@ #!/usr/bin/perl -# lonsql-based on the preforker:harsha jagasia:date:5/10/00 -# 7/25 Gerd Kortemeyer -# many different dates Scott Harrison + +# The LearningOnline Network +# lonsql - LON TCP-MySQL-Server Daemon for handling database requests. +# +# $Id: lonsql,v 1.95 2015/08/09 21:43:11 raeburn Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# LON-CAPA is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with LON-CAPA; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# /home/httpd/html/adm/gpl.txt +# +# http://www.lon-capa.org/ +# + +=pod + +=head1 NAME + +lonsql - LON TCP-MySQL-Server Daemon for handling database requests. + +=head1 SYNOPSIS + +This script should be run as user=www. +Note that a lonsql.pid file contains the pid of the parent process. + +=head1 OVERVIEW + +=head2 Purpose within LON-CAPA + +LON-CAPA is meant to distribute A LOT of educational content to A LOT +of people. It is ineffective to directly rely on contents within the +ext2 filesystem to be speedily scanned for on-the-fly searches of +content descriptions. (Simply put, it takes a cumbersome amount of +time to open, read, analyze, and close thousands of files.) + +The solution is to index various data fields that are descriptive of +the educational resources on a LON-CAPA server machine in a +database. Descriptive data fields are referred to as "metadata". The +question then arises as to how this metadata is handled in terms of +the rest of the LON-CAPA network without burdening client and daemon +processes. + +The obvious solution, using lonc to send a query to a lond process, +doesn't work so well in general as you can see in the following +example: + + lonc= loncapa client process A-lonc= a lonc process on Server A + lond= loncapa daemon process + + database command + A-lonc --------TCP/IP----------------> B-lond + +The problem emerges that A-lonc and B-lond are kept waiting for the +MySQL server to "do its stuff", or in other words, perform the +conceivably sophisticated, data-intensive, time-sucking database +transaction. By tying up a lonc and lond process, this significantly +cripples the capabilities of LON-CAPA servers. + +The solution is to offload the work onto another process, and use +lonc and lond just for requests and notifications of completed +processing: + + database command + + A-lonc ---------TCP/IP-----------------> B-lond =====> B-lonsql + <---------------------------------/ | + "ok, I'll get back to you..." | + | + / + A-lond <------------------------------- B-lonc <====== + "Guess what? I have the result!" + +Of course, depending on success or failure, the messages may vary, but +the principle remains the same where a separate pool of children +processes (lonsql's) handle the MySQL database manipulations. + +Thus, lonc and lond spend effectively no time waiting on results from +the database. + +=head1 Internals + +=cut + +use strict; + +use lib '/home/httpd/lib/perl/'; +use LONCAPA; +use LONCAPA::Configuration; +use LONCAPA::lonmetadata(); +use Apache::lonnet; use IO::Socket; use Symbol; use POSIX; use IO::Select; -use IO::File; -use Socket; -use Fcntl; -use Tie::RefHash; use DBI; +use File::Find; +use localenroll; +use GDBM_File; +######################################################## +######################################################## -$childmaxattempts=10; -$run =0;#running counter to generate the query-id +=pod -# ------------------------------------ Read httpd access.conf and get variables -open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; +=over 4 -while ($configline=) { - if ($configline =~ /PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } -} -close(CONFIG); +=item Global Variables -# --------------------------------------------- Check if other instance running +=over 4 -my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; +=item dbh -if (-e $pidfile) { - my $lfh=IO::File->new("$pidfile"); - my $pide=<$lfh>; - chomp($pide); - if (kill 0 => $pide) { die "already running"; } -} +=back -# ------------------------------------------------------------- Read hosts file -$PREFORK=4; # number of children to maintain, at least four spare +=cut -open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; +######################################################## +######################################################## +my $dbh; -while ($configline=) { - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - chomp($ip); +######################################################## +######################################################## - $hostip{$ip}=$id; +=pod - if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } +=item Variables required for forking - $PREFORK++; -} -close(CONFIG); +=over 4 -$unixsock = "mysqlsock"; -my $localfile="$perlvar{'lonSockDir'}/$unixsock"; -my $server; -unlink ($localfile); -unless ($server=IO::Socket::UNIX->new(Local =>"$localfile", - Type => SOCK_STREAM, - Listen => 10)) -{ - print "in socket error:$@\n"; -} +=item $MAX_CLIENTS_PER_CHILD -# -------------------------------------------------------- Routines for forking -# global variables -$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process -%children = (); # keys are current child process IDs -$children = 0; # current number of children +The number of clients each child should process. -sub REAPER { # takes care of dead children - $SIG{CHLD} = \&REAPER; - my $pid = wait; - $children --; - &logthis("Child $pid died"); - delete $children{$pid}; +=item %children + +The keys to %children are the current child process IDs + +=item $children + +The current number of children + +=back + +=cut + +######################################################## +######################################################## +my $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process +my %children = (); # keys are current child process IDs +my $children = 0; # current number of children + +################################################################### +################################################################### + +=pod + +=item Main body of code. + +=over 4 + +=item Read data from loncapa_apache.conf and loncapa.conf. + +=item Ensure we can access the database. + +=item Determine if there are other instances of lonsql running. + +=item Read the hosts file. + +=item Create a socket for lonsql. + +=item Fork once and dissociate from parent. + +=item Write PID to disk. + +=item Prefork children and maintain the population of children. + +=back + +=cut + +################################################################### +################################################################### +my $childmaxattempts=10; +my $run =0; # running counter to generate the query-id +# +# Read loncapa_apache.conf and loncapa.conf +# +my %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')}; +# +# Write the /home/www/.my.cnf file +my $conf_file = '/home/www/.my.cnf'; +if (! -e $conf_file) { + if (open MYCNF, ">$conf_file") { + print MYCNF <<"ENDMYCNF"; +[client] +user=www +password=$perlvar{'lonSqlAccess'} +ENDMYCNF + close MYCNF; + } else { + warn "Unable to write $conf_file, continuing"; + } } -sub HUNTSMAN { # signal handler for SIGINT - local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children - kill 'INT' => keys %children; - my $execdir=$perlvar{'lonDaemons'}; - unlink("$execdir/logs/lonsql.pid"); - &logthis("CRITICAL: Shutting down"); - $unixsock = "mysqlsock"; - my $port="$perlvar{'lonSockDir'}/$unixsock"; - unlink(port); - exit; # clean up with dignity + +# +# 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,">$perlvar{'lonDocRoot'}/lon-status/mysql.txt"); + print SMP 'time='.time.'&mysql=defunct'."\n"; + close(SMP); + + exit 1; +} else { + unlink("$perlvar{'lonDocRoot'}/lon-status/mysql.txt"); + $dbh->disconnect; } -sub HUPSMAN { # signal handler for SIGHUP - local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children - kill 'INT' => keys %children; - close($server); # free up socket - &logthis("CRITICAL: Restarting"); - my $execdir=$perlvar{'lonDaemons'}; - $unixsock = "mysqlsock"; - my $port="$perlvar{'lonSockDir'}/$unixsock"; - unlink(port); - exec("$execdir/lonsql"); # here we go again +# +# Check if other instance running +# +my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; +if (-e $pidfile) { + open(my $lfh,"$pidfile"); + my $pide=<$lfh>; + chomp($pide); + if (kill 0 => $pide) { die "already running"; } } -sub logthis { - my $message=shift; - my $execdir=$perlvar{'lonDaemons'}; - my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log"); - my $now=time; - my $local=localtime($now); - print $fh "$local ($$): $message\n"; +my $PREFORK=4; # number of children to maintain, at least four spare +# +#$PREFORK=int($PREFORK/4); + +# +# Create a socket to talk to lond +# +my $unixsock = "mysqlsock"; +my $localfile="$perlvar{'lonSockDir'}/$unixsock"; +my $server; +unlink ($localfile); +unless ($server=IO::Socket::UNIX->new(Local =>"$localfile", + Type => SOCK_STREAM, + Listen => 10)) { + print "in socket error:$@\n"; } -# ---------------------------------------------------- Fork once and dissociate -$fpid=fork; + +# +# Fork once and dissociate +# +my $fpid=fork; exit if $fpid; die "Couldn't fork: $!" unless defined ($fpid); - POSIX::setsid() or die "Can't start new session: $!"; -# ------------------------------------------------------- Write our PID on disk - -$execdir=$perlvar{'lonDaemons'}; +# +# Write our PID on disk +my $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lonsql.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); -&logthis("CRITICAL: ---------- Starting ----------"); +&logthis("CRITICAL: ---------- Starting ----------"); -# ----------------------------- Ignore signals generated during initial startup +# +# Ignore signals generated during initial startup $SIG{HUP}=$SIG{USR1}='IGNORE'; -# ------------------------------------------------------- Now we are on our own -# Fork off our children. +# Now we are on our own +# Fork off our children. for (1 .. $PREFORK) { make_new_child(); } +# # Install signal handlers. $SIG{CHLD} = \&REAPER; $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; +# # And maintain the population. while (1) { sleep; # wait for a signal (i.e., child's death) - for ($i = $children; $i < $PREFORK; $i++) { + for (my $i = $children; $i < $PREFORK; $i++) { make_new_child(); # top up the child pool } } +######################################################## +######################################################## + +=pod + +=item &make_new_child + +Inputs: None +Returns: None + +=cut + +######################################################## +######################################################## sub make_new_child { my $pid; my $sigset; - + # # block signal for fork $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!\n"; - + # die "fork: $!" unless defined ($pid = fork); - + # if ($pid) { # Parent records the child's birth and returns. sigprocmask(SIG_UNBLOCK, $sigset) @@ -172,69 +347,163 @@ sub make_new_child { } else { # Child can *not* return from this subroutine. $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before - # unblock signals sigprocmask(SIG_UNBLOCK, $sigset) 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","123",{ RaiseError =>0,PrintError=>0}) - ) { - my $st=120+int(rand(240)); - &logthis("WARNING: Couldn't connect to database ($st secs): $@"); - print "database handle error\n"; - sleep($st); - exit; - - }; - # make sure that a database disconnection occurs with ending kill signals + unless ($dbh = DBI->connect("DBI:mysql:loncapa","www", + $perlvar{'lonSqlAccess'}, + { RaiseError =>0,PrintError=>0})) { + sleep(10+int(rand(20))); + &logthis("WARNING: Couldn't connect to database". + ": $@"); + # "($st secs): $@"); + 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; - # handle connections until we've reached $MAX_CLIENTS_PER_CHILD - for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { - $client = $server->accept() or last; - + for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { + my $client = $server->accept() or last; # do something with the connection $run = $run+1; my $userinput = <$client>; chomp($userinput); - - my ($conserver,$querytmp)=split(/&/,$userinput); - my $query=unescape($querytmp); - + $userinput=~s/\:($LONCAPA::domain_re)$//; + my $searchdomain=$1; + # + my ($conserver,$query, + $arg1,$arg2,$arg3)=split(/&/,$userinput); + my $query=unescape($query); + # #send query id which is pid_unixdatetime_runningcounter - $queryid = $thisserver; + my $queryid = &Apache::lonnet::hostname($perlvar{'lonHostID'}); $queryid .="_".($$)."_"; $queryid .= time."_"; $queryid .= $run; print $client "$queryid\n"; - - #prepare and execute the query - my $sth = $dbh->prepare($query); - my $result; - unless ($sth->execute()) - { - &logthis("WARNING: Could not retrieve from database: $@"); - $result=""; - } - else { - my $r1=$sth->fetchall_arrayref; - my @r2; map {my $a=$_; my @b=map {escape($_)} @$a; push @r2,join(",", @b)} (@$r1); - $result=join("&",@r2) . "\n"; - } - &reply("queryreply:$queryid:$result",$conserver); - + # + # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3 - $queryid"); + # sleep 1; + # + my $result=''; + # + # At this point, query is received, query-ID assigned and sent + # back, $query eq 'logquery' will mean that this is a query + # against log-files + if (($query eq 'userlog') || ($query eq 'courselog')) { + # beginning of log query + my $udom = &unescape($arg1); + my $uname = &unescape($arg2); + my $command = &unescape($arg3); + my $path = &propath($udom,$uname); + if (-e "$path/activity.log") { + if ($query eq 'userlog') { + $result=&userlog($path,$command); + } else { + $result=&courselog($path,$command); + } + $result = &escape($result); + } else { + &logthis('Unable to do log query: '.$uname.'@'.$udom); + $result='no_such_file'; + } + # end of log query + } elsif (($query eq 'fetchenrollment') || + ($query eq 'institutionalphotos')) { + # retrieve institutional class lists + my $dom = &unescape($arg1); + my %affiliates = (); + my %replies = (); + my $locresult = ''; + my $querystr = &unescape($arg3); + foreach (split/%%/,$querystr) { + if (/^([^=]+)=([^=]+)$/) { + @{$affiliates{$1}} = split/,/,$2; + } + } + 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.':'); + if ($locresult) { + $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies)); + } + } elsif ($query eq 'usersearch') { + my ($srchby,$srchtype,$srchterm); + if ((&unescape($arg1) eq $searchdomain) && + ($arg2 =~ /\%\%/)) { + ($srchby,$srchtype) = + map {&unescape($_);} (split(/\%\%/,$arg2)); + $srchterm = &unescape($arg3); + } else { + ($srchby,$srchtype,$srchterm) = + map {&unescape($_);} ($arg1,$arg2,$arg3); + } + $result = &do_user_search($searchdomain,$srchby, + $srchtype,$srchterm); + } elsif ($query eq 'instdirsearch') { + $result = &do_inst_dir_search($searchdomain,$arg1,$arg2,$arg3); + } elsif ($query eq 'getinstuser') { + $result = &get_inst_user($searchdomain,$arg1,$arg2); + } elsif ($query eq 'getmultinstusers') { + $result = &get_multiple_instusers($searchdomain,$arg3); + } elsif ($query eq 'prepare activity log') { + my ($cid,$domain) = map {&unescape($_);} ($arg1,$arg2); + &logthis('preparing activity log tables for '.$cid); + my $command = + qq{$perlvar{'lonDaemons'}/parse_activity_log.pl -course=$cid -domain=$domain}; + system($command); + &logthis($command); + my $returnvalue = $?>>8; + if ($returnvalue) { + $result = 'error: parse_activity_log.pl returned '. + $returnvalue; + } else { + $result = 'success'; + } + } elsif (($query eq 'portfolio_metadata') || + ($query eq 'portfolio_access')) { + $result = &portfolio_table_update($query,$arg1,$arg2, + $arg3); + } elsif ($query eq 'allusers') { + my ($uname,$udom) = map {&unescape($_);} ($arg1,$arg2); + my %userdata; + my (@data) = split(/\%\%/,$arg3); + foreach my $item (@data) { + my ($key,$value) = split(/=/,$item); + $userdata{$key} = &unescape($value); + } + $userdata{'username'} = $uname; + $userdata{'domain'} = $udom; + $result = &allusers_table_update($query,$uname,$udom,\%userdata); + } else { + # Do an sql query + $result = &do_sql_query($query,$arg1,$arg2,$arg3,$searchdomain); + } + # result does not need to be escaped because it has already been + # escaped. + #$result=&escape($result); + &Apache::lonnet::reply("queryreply:$queryid:$result",$conserver); } - # tidy up gracefully and finish - - #close the database handle + # + # close the database handle $dbh->disconnect - or &logthis("WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@"); - + or &logthis("WARNING: Couldn't disconnect". + " from database $DBI::errstr : $@"); # this exit is VERY important, otherwise the child will become # a producer of more and more children, forking yourself into # process death. @@ -242,55 +511,728 @@ sub make_new_child { } } +sub do_user_search { + my ($domain,$srchby,$srchtype,$srchterm) = @_; + my $result; + my $quoted_dom = $dbh->quote( $domain ); + my ($query,$quoted_srchterm,@fields); + my ($table_columns,$table_indices) = + &LONCAPA::lonmetadata::describe_metadata_storage('allusers'); + foreach my $coldata (@{$table_columns}) { + push(@fields,$coldata->{'name'}); + } + my $fieldlist = join(',',@fields); + $query = "SELECT $fieldlist FROM allusers WHERE (domain = $quoted_dom AND "; + if ($srchby eq 'lastfirst') { + my ($fraglast,$fragfirst) = split(/,/,$srchterm); + $fragfirst =~ s/^\s+//; + $fraglast =~ s/\s+$//; + if ($srchtype eq 'exact') { + $query .= 'lastname = '.$dbh->quote($fraglast). + ' AND firstname = '.$dbh->quote($fragfirst); + } elsif ($srchtype eq 'begins') { + $query .= 'lastname LIKE '.$dbh->quote($fraglast.'%'). + ' AND firstname LIKE '.$dbh->quote($fragfirst.'%'); + } else { + $query .= 'lastname LIKE '.$dbh->quote('%'.$fraglast.'%'). + ' AND firstname LIKE '.$dbh->quote('%'.$fragfirst.'%'); + } + } else { + my %srchfield = ( + uname => 'username', + lastname => 'lastname', + ); + if ($srchtype eq 'exact') { + $query .= $srchfield{$srchby}.' = '.$dbh->quote($srchterm); + } elsif ($srchtype eq 'begins') { + $query .= $srchfield{$srchby}.' LIKE '.$dbh->quote($srchterm.'%'); + } else { + $query .= $srchfield{$srchby}.' LIKE '.$dbh->quote('%'.$srchterm.'%'); + } + } + $query .= ") ORDER BY username "; + my $sth = $dbh->prepare($query); + if ($sth->execute()) { + my @results; + while (my @row = $sth->fetchrow_array) { + my @items; + for (my $i=0; $i<@row; $i++) { + push(@items,&escape($fields[$i]).'='.&escape($row[$i])); + } + my $userstr = join(':', @items); + push(@results,&escape($userstr)); + } + $sth->finish; + $result = join('&',@results); + } else { + &logthis(''. + 'WARNING: Could not retrieve from database:'. + $sth->errstr().''); + } + return $result; +} + +sub do_inst_dir_search { + my ($domain,$srchby,$srchterm,$srchtype) = @_; + $srchby = &unescape($srchby); + $srchterm = &unescape($srchterm); + $srchtype = &unescape($srchtype); + my (%instusers,%instids,$result,$response); + eval { + local($SIG{__DIE__})='DEFAULT'; + $result=&localenroll::get_userinfo($domain,undef,undef,\%instusers, + \%instids,undef,$srchby,$srchterm, + $srchtype); + }; + if ($result eq 'ok') { + if (%instusers) { + foreach my $key (keys(%instusers)) { + my $usrstr = &Apache::lonnet::freeze_escape($instusers{$key}); + $response .=&escape(&escape($key).'='.$usrstr).'&'; + } + } + $response=~s/\&$//; + } else { + $response = 'unavailable'; + } + return $response; +} + +sub get_inst_user { + my ($domain,$uname,$id) = @_; + $uname = &unescape($uname); + $id = &unescape($id); + my (%instusers,%instids,$result,$response); + eval { + local($SIG{__DIE__})='DEFAULT'; + $result=&localenroll::get_userinfo($domain,$uname,$id,\%instusers, + \%instids); + }; + if ($result eq 'ok') { + if (keys(%instusers) > 0) { + foreach my $key (keys(%instusers)) { + my $usrstr = &Apache::lonnet::freeze_escape($instusers{$key}); + $response .= &escape(&escape($key).'='.$usrstr).'&'; + } + } + $response=~s/\&$//; + } else { + $response = 'unavailable'; + } + return $response; +} + +sub get_multiple_instusers { + my ($domain,$data) = @_; + my ($type,$users) = split(/=/,$data,2); + my $requested = &Apache::lonnet::thaw_unescape($users); + my $response; + if (ref($requested) eq 'HASH') { + my (%instusers,%instids,$result); + eval { + local($SIG{__DIE__})='DEFAULT'; + $result=&localenroll::get_multusersinfo($domain,$type,$requested,\%instusers, + \%instids); + }; + if ($@) { + $response = 'error'; + } elsif ($result eq 'ok') { + $response = $result; + if (keys(%instusers)) { + $response .= '='.&Apache::lonnet::freeze_escape(\%instusers); + } + } elsif ($result eq 'unavailable') { + $response = $result; + } + } else { + $response = 'invalid'; + } + return $response; +} + +######################################################## +######################################################## + +=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 + -f $_ && # and is a normal file + /\.meta$/ && # ends in meta + ! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version + ) { + push(@metalist,$File::Find::name); + } +} + +sub do_sql_query { + my ($query,$custom,$customshow,$domainstr,$searchdomain) = @_; + +# +# limit to searchdomain if given and table is metadata +# + if ($domainstr && ($query=~/FROM metadata/)) { + my $havingstr; + $domainstr = &unescape($domainstr); + if ($domainstr =~ /,/) { + foreach my $dom (split(/,/,$domainstr)) { + if ($dom =~ /^$LONCAPA::domain_re$/) { + $havingstr .= 'domain="'.$dom.'" OR '; + } + } + $havingstr =~ s/ OR $//; + } else { + if ($domainstr =~ /^$LONCAPA::domain_re$/) { + $havingstr = 'domain="'.$domainstr.'"'; + } + } + if ($havingstr) { + $query.=' HAVING ('.$havingstr.')'; + } + } elsif (($searchdomain) && ($query=~/FROM metadata/)) { + $query.=' HAVING (domain="'.$searchdomain.'")'; + } +# &logthis('doing query ('.$searchdomain.')'.$query); + + + + $custom = &unescape($custom); + $customshow = &unescape($customshow); + # + @metalist = (); + # + my $result = ''; + my @results = (); + my @files; + my $subsetflag=0; + # + if ($query) { + #prepare and execute the query + my $sth = $dbh->prepare($query); + unless ($sth->execute()) { + &logthis(''. + 'WARNING: Could not retrieve from database:'. + $sth->errstr().''); + } else { + my $aref=$sth->fetchall_arrayref; + foreach my $row (@$aref) { + push @files,@{$row}[3] if ($custom or $customshow); + my @b=map { &escape($_); } @$row; + push @results,join(",", @b); + # Build up the @files array with the LON-CAPA urls + # of the resources. + } + } + } + # do custom metadata searching here and build into result + return join("&",@results) if (! ($custom or $customshow)); + # Only get here if there is a custom query or custom show request + &logthis("Doing custom query for $custom"); + if ($query) { + @metalist=map { + $perlvar{'lonDocRoot'}.$_.'.meta'; + } @files; + } else { + my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"; + @metalist=(); + opendir(RESOURCES,$dir); + my @homeusers=grep { + &ishome($dir.'/'.$_); + } grep {!/^\.\.?$/} readdir(RESOURCES); + closedir RESOURCES; + # Define the + foreach my $user (@homeusers) { + find (\&process_file,$dir.'/'.$user); + } + } + # if file is indicated in sql database and + # not part of sql-relevant query, do not pattern match. + # + # if file is not in sql database, output error. + # + # if file is indicated in sql database and is + # part of query result list, then do the pattern match. + my $customresult=''; + my @results; + foreach my $metafile (@metalist) { + open(my $fh,$metafile); + my @lines=<$fh>; + my $stuff=join('',@lines); + if ($stuff=~/$custom/s) { + foreach my $f ('abstract','author','copyright', + 'creationdate','keywords','language', + 'lastrevisiondate','mime','notes', + 'owner','subject','title') { + $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s; + } + my $mfile=$metafile; + my $docroot=$perlvar{'lonDocRoot'}; + $mfile=~s/^$docroot//; + $mfile=~s/\.meta$//; + unless ($query) { + my $q2="SELECT * FROM metadata WHERE url ". + " LIKE BINARY '?'"; + my $sth = $dbh->prepare($q2); + $sth->execute($mfile); + my $aref=$sth->fetchall_arrayref; + foreach my $a (@$aref) { + my @b=map { &escape($_)} @$a; + push @results,join(",", @b); + } + } + # &logthis("found: $stuff"); + $customresult.='&custom='.&escape($mfile).','. + escape($stuff); + } + } + $result=join("&",@results) unless $query; + $result.=$customresult; + # + return $result; +} # End of &do_sql_query + +} # End of scoping curly braces for &process_file and &do_sql_query + +sub portfolio_table_update { + my ($query,$arg1,$arg2,$arg3) = @_; + my %tablenames = ( + 'portfolio' => 'portfolio_metadata', + 'access' => 'portfolio_access', + 'addedfields' => 'portfolio_addedfields', + ); + my $result = 'ok'; + my $tablechk = &check_table($query); + if ($tablechk == 0) { + my $request = + &LONCAPA::lonmetadata::create_metadata_storage($query,$query); + $dbh->do($request); + if ($dbh->err) { + &logthis("create $query". + " ERROR: ".$dbh->errstr); + $result = 'error'; + } + } + if ($result eq 'ok') { + my ($uname,$udom,$group) = split(/:/,&unescape($arg1)); + my $file_name = &unescape($arg2); + my $action = $arg3; + my $is_course = 0; + if ($group ne '') { + $is_course = 1; + } + my $urlstart = '/uploaded/'.$udom.'/'.$uname; + my $pathstart = &propath($udom,$uname).'/userfiles'; + my ($fullpath,$url); + if ($is_course) { + $fullpath = $pathstart.'/groups/'.$group.'/portfolio'. + $file_name; + $url = $urlstart.'/groups/'.$group.'/portfolio'.$file_name; + } else { + $fullpath = $pathstart.'/portfolio'.$file_name; + $url = $urlstart.'/portfolio'.$file_name; + } + if ($query eq 'portfolio_metadata') { + if ($action eq 'delete') { + my %loghash = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef,\%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group,'update'); + } elsif (-e $fullpath.'.meta') { + my %loghash = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef,\%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group,'update'); + if (keys(%loghash) > 0) { + &portfolio_logging(%loghash); + } + } + } elsif ($query eq 'portfolio_access') { + my %access = &get_access_hash($uname,$udom,$group.$file_name); + my %loghash = + &LONCAPA::lonmetadata::process_portfolio_access_data($dbh,undef, + \%tablenames,$url,$fullpath,\%access,'update'); + if (keys(%loghash) > 0) { + &portfolio_logging(%loghash); + } else { + my $available = 0; + foreach my $key (keys(%access)) { + my ($num,$scope,$end,$start) = + ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); + if ($scope eq 'public' || $scope eq 'guest') { + $available = 1; + last; + } + } + if ($available) { + # Retrieve current values + my $condition = 'url='.$dbh->quote("$url"); + my ($error,$row) = + &LONCAPA::lonmetadata::lookup_metadata($dbh,$condition,undef, + 'portfolio_metadata'); + if (!$error) { + if (!(ref($row->[0]) eq 'ARRAY')) { + my %loghash = + &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef, + \%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group); + if (keys(%loghash) > 0) { + &portfolio_logging(%loghash); + } + } + } + } + } + } + } + return $result; +} + +sub get_access_hash { + my ($uname,$udom,$file) = @_; + my $hashref = &tie_user_hash($udom,$uname,'file_permissions', + &GDBM_READER()); + my %curr_perms; + my %access; + if ($hashref) { + while (my ($key,$value) = each(%$hashref)) { + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $curr_perms{$key}=&Apache::lonnet::thaw_unescape($value); + } + if (!&untie_user_hash($hashref)) { + &logthis("error: ".($!+0)." untie (GDBM) Failed"); + } + } else { + &logthis("error: ".($!+0)." tie (GDBM) Failed"); + } + if (keys(%curr_perms) > 0) { + if (ref($curr_perms{$file."\0".'accesscontrol'}) eq 'HASH') { + foreach my $acl (keys(%{$curr_perms{$file."\0".'accesscontrol'}})) { + $access{$acl} = $curr_perms{$file."\0".$acl}; + } + } + } + return %access; +} + +sub allusers_table_update { + my ($query,$uname,$udom,$userdata) = @_; + my %tablenames = ( + 'allusers' => 'allusers', + ); + my $result = 'ok'; + my $tablechk = &check_table($query); + if ($tablechk == 0) { + my $request = + &LONCAPA::lonmetadata::create_metadata_storage($query,$query); + $dbh->do($request); + if ($dbh->err) { + &logthis("create $query". + " ERROR: ".$dbh->errstr); + $result = 'error'; + } + } + if ($result eq 'ok') { + my %loghash = + &LONCAPA::lonmetadata::process_allusers_data($dbh,undef, + \%tablenames,$uname,$udom,$userdata,'update'); + foreach my $key (keys(%loghash)) { + &logthis($loghash{$key}); + } + } + return $result; +} + +########################################### +sub check_table { + my ($table_id) = @_; + my $sth=$dbh->prepare('SHOW TABLES'); + $sth->execute(); + my $aref = $sth->fetchall_arrayref; + $sth->finish(); + if ($sth->err()) { + &logthis("fetchall_arrayref after SHOW TABLES". + " ERROR: ".$sth->errstr); + return undef; + } + my $result = 0; + foreach my $table (@{$aref}) { + if ($table->[0] eq $table_id) { + $result = 1; + last; + } + } + return $result; +} + +########################################### + +sub portfolio_logging { + my (%portlog) = @_; + foreach my $key (keys(%portlog)) { + if (ref($portlog{$key}) eq 'HASH') { + foreach my $item (keys(%{$portlog{$key}})) { + &logthis($portlog{$key}{$item}); + } + } + } +} + + +######################################################## +######################################################## + +=pod + +=item &logthis + +Inputs: $message, the message to log + +Returns: nothing + +Writes $message to the logfile. + +=cut + +######################################################## +######################################################## +sub logthis { + my $message=shift; + my $execdir=$perlvar{'lonDaemons'}; + open(my $fh,">>$execdir/logs/lonsql.log"); + my $now=time; + my $local=localtime($now); + print $fh "$local ($$): $message\n"; +} + +######################################################## +######################################################## + +=pod + +=item &ishome + +Determine if the current machine is the home server for a user. +The determination is made by checking the filesystem for the users information. + +Inputs: $author + +Returns: 0 - this is not the authors home server, 1 - this is. + +=cut + +######################################################## +######################################################## +sub ishome { + my $author=shift; + $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + my ($udom,$uname)=split(/\//,$author); + my $proname=propath($udom,$uname); + if (-e $proname) { + return 1; + } else { + return 0; + } +} + +######################################################## +######################################################## + +=pod + +=item &courselog + +Inputs: $path, $command + +Returns: unescaped string of values. + +=cut + +######################################################## +######################################################## +sub courselog { + my ($path,$command)=@_; + my %filters=(); + foreach (split(/\:/,&unescape($command))) { + my ($name,$value)=split(/\=/,$_); + $filters{$name}=$value; + } + my @results=(); + open(IN,$path.'/activity.log') or return ('file_error'); + while (my $line=) { + chomp($line); + my ($timestamp,$host,$log)=split(/\:/,$line); +# +# $log has the actual log entries; currently still escaped, and +# %26(timestamp)%3a(url)%3a(user)%3a(domain) +# then additionally +# %3aPOST%3a(name)%3d(value)%3a(name)%3d(value) +# or +# %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value) +# +# get delimiter between timestamped entries to be &&& + $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g; +# now go over all log entries + foreach (split(/\&\&\&/,&unescape($log))) { + my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_); + my $values=&unescape(join(':',@values)); + $values=~s/\&/\:/g; + $res=&unescape($res); + my $include=1; + if (($filters{'username'}) && ($uname ne $filters{'username'})) + { $include=0; } + if (($filters{'domain'}) && ($udom ne $filters{'domain'})) + { $include=0; } + if (($filters{'url'}) && ($res!~/$filters{'url'}/)) + { $include=0; } + if (($filters{'start'}) && ($time<$filters{'start'})) + { $include=0; } + if (($filters{'end'}) && ($time>$filters{'end'})) + { $include=0; } + if (($filters{'action'} eq 'view') && ($action)) + { $include=0; } + if (($filters{'action'} eq 'submit') && ($action ne 'POST')) + { $include=0; } + if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) + { $include=0; } + if ($include) { + push(@results,($time<1000000000?'0':'').$time.':'.$res.':'. + $uname.':'.$udom.':'. + $action.':'.$values); + } + } + } + close IN; + return join('&',sort(@results)); +} + +######################################################## +######################################################## + +=pod + +=item &userlog + +Inputs: $path, $command + +Returns: unescaped string of values. + +=cut + +######################################################## +######################################################## +sub userlog { + my ($path,$command)=@_; + my %filters=(); + foreach (split(/\:/,&unescape($command))) { + my ($name,$value)=split(/\=/,$_); + $filters{$name}=$value; + } + my @results=(); + open(IN,$path.'/activity.log') or return ('file_error'); + while (my $line=) { + chomp($line); + my ($timestamp,$host,$log)=split(/\:/,$line); + $log=&unescape($log); + my $include=1; + if (($filters{'start'}) && ($timestamp<$filters{'start'})) + { $include=0; } + if (($filters{'end'}) && ($timestamp>$filters{'end'})) + { $include=0; } + if (($filters{'action'} eq 'Role') && ($log !~/^Role/)) + { $include=0; } + if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; } + if (($filters{'action'} eq 'check') && ($log!~/^Check/)) + { $include=0; } + if ($include) { + push(@results,$timestamp.':'.$host.':'.&escape($log)); + } + } + close IN; + return join('&',sort(@results)); +} + +######################################################## +######################################################## + +=pod + +=item Functions required for forking + +=over 4 + +=item REAPER + +REAPER takes care of dead children. + +=item HUNTSMAN + +Signal handler for SIGINT. + +=item HUPSMAN + +Signal handler for SIGHUP + +=item DISCONNECT + +Disconnects from database. + +=back + +=cut + +######################################################## +######################################################## +sub REAPER { # takes care of dead children + $SIG{CHLD} = \&REAPER; + my $pid = wait; + $children --; + &logthis("Child $pid died"); + delete $children{$pid}; +} + +sub HUNTSMAN { # signal handler for SIGINT + local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children + kill 'INT' => keys %children; + my $execdir=$perlvar{'lonDaemons'}; + unlink("$execdir/logs/lonsql.pid"); + &logthis("CRITICAL: Shutting down"); + $unixsock = "mysqlsock"; + my $port="$perlvar{'lonSockDir'}/$unixsock"; + unlink($port); + exit; # clean up with dignity +} + +sub HUPSMAN { # signal handler for SIGHUP + local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children + kill 'INT' => keys %children; + close($server); # free up socket + &logthis("CRITICAL: Restarting"); + my $execdir=$perlvar{'lonDaemons'}; + $unixsock = "mysqlsock"; + my $port="$perlvar{'lonSockDir'}/$unixsock"; + unlink($port); + exec("$execdir/lonsql"); # here we go again +} + sub DISCONNECT { $dbh->disconnect or - &logthis("WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@"); + &logthis("WARNING: Couldn't disconnect from database ". + " $DBI::errstr : $@"); exit; } -# -------------------------------------------------- Non-critical communication -sub subreply { - my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/$server"; - my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - print $sclient "$cmd\n"; - my $answer=<$sclient>; - chomp($answer); - if (!$answer) { $answer="con_lost"; } - return $answer; -} - -sub reply { - my ($cmd,$server)=@_; - my $answer; - if ($server ne $perlvar{'lonHostID'}) { - $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - $answer=subreply("ping",$server); - $answer=subreply($cmd,$server); - } - } else { - $answer='self_reply'; - } - return $answer; -} - -# -------------------------------------------------------- Escape Special Chars - -sub escape { - my $str=shift; - $str =~ s/(\W)/"%".unpack('H2',$1)/eg; - return $str; -} - -# ----------------------------------------------------- Un-Escape Special Chars - -sub unescape { - my $str=shift; - $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - return $str; -} +=pod + +=back + +=cut 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.