--- loncom/lonsql 2002/07/05 15:07:59 1.50 +++ loncom/lonsql 2003/02/03 05:08:06 1.54 @@ -3,7 +3,7 @@ # The LearningOnline Network # lonsql - LON TCP-MySQL-Server Daemon for handling database requests. # -# $Id: lonsql,v 1.50 2002/07/05 15:07:59 matthew Exp $ +# $Id: lonsql,v 1.54 2003/02/03 05:08:06 harris41 Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,32 +27,29 @@ # # http://www.lon-capa.org/ # -# YEAR=2000 -# lonsql-based on the preforker:harsha jagasia:date:5/10/00 -# 7/25 Gerd Kortemeyer -# many different dates Scott Harrison -# YEAR=2001 -# many different dates Scott Harrison -# 03/22/2001 Scott Harrison -# 8/30 Gerd Kortemeyer -# 10/17,11/28,11/29,12/20 Scott Harrison -# YEAR=2001 -# 5/11 Scott Harrison -# -### - -############################################################################### -## ## -## ORGANIZATION OF THIS PERL SCRIPT ## -## 1. Modules used ## -## 2. Enable find subroutine ## -## 3. Read httpd config files and get variables ## -## 4. Make sure that database can be accessed ## -## 5. Make sure this process is running from user=www ## -## 6. Check if other instance is running ## -## 7. POD (plain old documentation, CPAN style) ## -## ## -############################################################################### + +=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 DESCRIPTION + +lonsql is currently mutilated. + +=head1 Internals + +=over 4 + +=cut + +use strict; use lib '/home/httpd/lib/perl/'; use LONCAPA::Configuration; @@ -66,47 +63,117 @@ use Socket; use Fcntl; use Tie::RefHash; use DBI; +use File::Find; -my @metalist; -# ----------------- Code to enable 'find' subroutine listing of the .meta files -require "find.pl"; -sub wanted { - (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && - -f _ && - /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ && - push(@metalist,"$dir/$_"); -} - -$childmaxattempts=10; -$run =0;#running counter to generate the query-id - -# -------------------------------- Read loncapa_apache.conf and loncapa.conf -my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf', - 'loncapa.conf'); -my %perlvar=%{$perlvarref}; +######################################################## +######################################################## -# ------------------------------------- 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"; - $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!"; - system("echo 'Cannot connect to MySQL database!' |\ - mailto $emailto -s '$subj' > /dev/null"); - exit 1; - } - else { - $dbh->disconnect; - } -} +=pod -# --------------------------------------------- Check if other instance running +=item Global Variables -my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; +=over 4 + +=item dbh + +=back + +=cut + +######################################################## +######################################################## +my $dbh; + +######################################################## +######################################################## + +=pod +=item Variables required for forking + +=over 4 + +=item $MAX_CLIENTS_PER_CHILD + +The number of clients each child should process. + +=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 $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); +my %perlvar=%{$perlvarref}; +# +# 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"); + exit 1; +} else { + $dbh->disconnect; +} + +# +# Check if other instance running +# +my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; if (-e $pidfile) { my $lfh=IO::File->new("$pidfile"); my $pide=<$lfh>; @@ -114,220 +181,103 @@ if (-e $pidfile) { if (kill 0 => $pide) { die "already running"; } } -# ------------------------------------------------------------- Read hosts file -$PREFORK=4; # number of children to maintain, at least four spare - +# +# Read hosts file +# +my %hostip; +my $thisserver; +my $PREFORK=4; # number of children to maintain, at least four spare open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; - -while ($configline=) { +while (my $configline=) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); chomp($ip); - $hostip{$ip}=$id; - if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } - + $thisserver=$name if ($id eq $perlvar{'lonHostID'}); $PREFORK++; } close(CONFIG); - +# $PREFORK=int($PREFORK/4); -$unixsock = "mysqlsock"; +# +# 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)) -{ + Type => SOCK_STREAM, + Listen => 10)) { print "in socket error:$@\n"; } -# -------------------------------------------------------- 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 - -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 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"; -} - -# ------------------------------------------------------------------ Course log - -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 ($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) +# Fork once and dissociate # -# 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)); -} - -# -------------------------------------------------------------------- User log - -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 ($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 'log') && ($log!~/^Log/)) { $include=0; } - if (($filters{'action'} eq 'check') && ($log!~/^Check/)) - { $include=0; } - if ($include) { - push(@results,$timestamp.':'.$log); - } - } - close IN; - return join('&',sort(@results)); -} - - -# ---------------------------------------------------- Fork once and dissociate -$fpid=fork; +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 ----------"); -# ----------------------------- 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) @@ -338,178 +288,85 @@ 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",$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 + 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,$query, $arg1,$arg2,$arg3)=split(/&/,$userinput); my $query=unescape($query); - + # #send query id which is pid_unixdatetime_runningcounter - $queryid = $thisserver; + my $queryid = $thisserver; $queryid .="_".($$)."_"; $queryid .= time."_"; $queryid .= $run; print $client "$queryid\n"; - + # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3"); 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 -# -# this goes against a user's log file -# - 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); - } - } else { - &logthis('Unable to do log query: '.$uname.'@'.$udom); - $result='no_such_file'; - } -# ------------------------------------------------------------ end of log query - } else { -# -------------------------------------------------------- This is an sql query - my $custom=unescape($arg1); - my $customshow=unescape($arg2); - #prepare and execute the query - my $sth = $dbh->prepare($query); - - my @files; - my $subsetflag=0; - if ($query) { - unless ($sth->execute()) - { - &logthis("WARNING: Could not retrieve from database: $@"); - $result=""; - } - else { - my $r1=$sth->fetchall_arrayref; - my @r2; - foreach (@$r1) {my $a=$_; - my @b=map {escape($_)} @$a; - push @files,@{$a}[3]; - push @r2,join(",", @b) - } - $result=join("&",@r2); - } - } - # do custom metadata searching here and build into result - if ($custom or $customshow) { - &logthis("am going to do custom query for $custom"); - if ($query) { - @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files; - } - else { - @metalist=(); pop @metalist; - opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"); - my @homeusers=grep - {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")} - grep {!/^\.\.?$/} readdir(RESOURCES); - closedir RESOURCES; - foreach my $user (@homeusers) { - &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user"); - } - } -# &logthis("FILELIST:" . join(":::",@metalist)); - # 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 @r2; - foreach my $m (@metalist) { - my $fh=IO::File->new($m); - 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 $m2=$m; my $docroot=$perlvar{'lonDocRoot'}; - $m2=~s/^$docroot//; - $m2=~s/\.meta$//; - unless ($query) { - my $q2="select * from metadata where url like binary '$m2'"; - my $sth = $dbh->prepare($q2); - $sth->execute(); - my $r1=$sth->fetchall_arrayref; - foreach (@$r1) {my $a=$_; - my @b=map {escape($_)} @$a; - push @files,@{$a}[3]; - push @r2,join(",", @b) - } - } -# &logthis("found: $stuff"); - $customresult.='&custom='.escape($m2).','.escape($stuff); - } - } - $result=join("&",@r2) unless $query; - $result.=$customresult; - } -# ------------------------------------------------------------ end of sql query - } - + # + # 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); + } + } else { + &logthis('Unable to do log query: '.$uname.'@'.$udom); + $result='no_such_file'; + } + # end of log query + } else { + # Do an sql query + $result = &do_sql_query($query,$arg1,$arg2); + } # result does not need to be escaped because it has already been # escaped. #$result=&escape($result); - - # reply with result, append \n unless already there - + # reply with result, append \n unless already there $result.="\n" unless ($result=~/\n$/); &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. @@ -517,14 +374,178 @@ sub make_new_child { } } -sub DISCONNECT { - $dbh->disconnect or - &logthis("WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@"); - exit; +######################################################## +######################################################## + +=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) = @_; + $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: $@"); + } 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) { + my $fh=IO::File->new($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 +######################################################## +######################################################## + +=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'}; + my $fh=IO::File->new(">>$execdir/logs/lonsql.log"); + my $now=time; + my $local=localtime($now); + print $fh "$local ($$): $message\n"; } # -------------------------------------------------- Non-critical communication +######################################################## +######################################################## + +=pod + +=item &subreply + +Sends a command to a server. Called only by &reply. + +Inputs: $cmd,$server + +Returns: The results of the message or 'con_lost' on error. + +=cut + +######################################################## +######################################################## sub subreply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; @@ -535,10 +556,27 @@ sub subreply { print $sclient "$cmd\n"; my $answer=<$sclient>; chomp($answer); - if (!$answer) { $answer="con_lost"; } + $answer="con_lost" if (!$answer); return $answer; } +######################################################## +######################################################## + +=pod + +=item &reply + +Sends a command to a server. + +Inputs: $cmd,$server + +Returns: The results of the message or 'con_lost' on error. + +=cut + +######################################################## +######################################################## sub reply { my ($cmd,$server)=@_; my $answer; @@ -555,24 +593,70 @@ sub reply { return $answer; } -# -------------------------------------------------------- Escape Special Chars +######################################################## +######################################################## + +=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; } -# ----------------------------------------------------- Un-Escape Special Chars +######################################################## +######################################################## +=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; } -# --------------------------------------- Is this the home server of an author? -# (copied from lond, modification of the return value) +######################################################## +######################################################## + +=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/; @@ -585,8 +669,21 @@ sub ishome { } } -# -------------------------------------------- Return path to profile directory -# (copied from lond) +######################################################## +######################################################## + +=pod + +=item &propath + +Inputs: user name, user domain + +Returns: The full path to the users directory. + +=cut + +######################################################## +######################################################## sub propath { my ($udom,$uname)=@_; $udom=~s/\W//g; @@ -597,74 +694,205 @@ sub propath { return $proname; } -# ----------------------------------- POD (plain old documentation, CPAN style) +######################################################## +######################################################## -=head1 NAME +=pod -lonsql - LON TCP-MySQL-Server Daemon for handling database requests. +=item &courselog -=head1 SYNOPSIS +Inputs: $path, $command -This script should be run as user=www. The following is an example invocation -from the loncron script. Note that a lonsql.pid file contains the pid of -the parent process. - - if (-e $lonsqlfile) { - my $lfh=IO::File->new("$lonsqlfile"); - my $lonsqlpid=<$lfh>; - chomp($lonsqlpid); - if (kill 0 => $lonsqlpid) { - print $fh "

lonsql at pid $lonsqlpid responding

"; - $restartflag=0; - } else { - $errors++; $errors++; - print $fh "

lonsql at pid $lonsqlpid not responding

"; - $restartflag=1; - print $fh - "

Decided to clean up stale .pid file and restart lonsql

"; - } - } - if ($restartflag==1) { - $errors++; - print $fh '
Killall lonsql: '. - system('killall lonsql').' - '; - sleep 60; - print $fh unlink($lonsqlfile).' - '. - system('killall -9 lonsql'). - '
'; - print $fh "

lonsql not running, trying to start

"; - system( - "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors"); - sleep 10; +Returns: unescaped string of values. -=head1 DESCRIPTION +=cut -Not yet written. +######################################################## +######################################################## +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 'log') && ($log!~/^Log/)) { $include=0; } + if (($filters{'action'} eq 'check') && ($log!~/^Check/)) + { $include=0; } + if ($include) { + push(@results,$timestamp.':'.$log); + } + } + close IN; + return join('&',sort(@results)); +} + +######################################################## +######################################################## + +=pod + +=item Functions required for forking + +=over 4 + +=item REAPER -=head1 README +REAPER takes care of dead children. -Not yet written. +=item HUNTSMAN -=head1 PREREQUISITES +Signal handler for SIGINT. -IO::Socket -Symbol -POSIX -IO::Select -IO::File -Socket -Fcntl -Tie::RefHash -DBI +=item HUPSMAN -=head1 COREQUISITES +Signal handler for SIGHUP -=head1 OSNAMES +=item DISCONNECT -linux +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 : $@"); + exit; +} + + + + + + + + + + + +# ----------------------------------- POD (plain old documentation, CPAN style) -=head1 SCRIPT CATEGORIES +=pod -Server/Process +=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.