loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.78: download - view: text, annotated - select for diffs
Tue Jan 2 12:51:31 2007 UTC (17 years, 3 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

portfolio_metadata, portfolio_addedfields and portfolio_access tables in MySQL updated when portfolio access controls are modified or when portfolio metadata is updated.

Some routines in searchcat.pl moved to LONCAPA::lonmetadata.pm so they are available to lonsql when performing MySQL table updates on the library server which houses the portfolio files.

metadata updates and access control updates from lonmeta and lonnet::modify_access_controls are routed through lonnet::update_portfolio_table() which in turn does a querysend to dispatch a query to lonsql (via lond).

Only access control settings for public and passphrase-protected controls are stored in the portfolio_access MySQL table.

1: #!/usr/bin/perl 2: 3: # The LearningOnline Network 4: # lonsql - LON TCP-MySQL-Server Daemon for handling database requests. 5: # 6: # $Id: lonsql,v 1.78 2007/01/02 12:51:31 raeburn Exp $ 7: # 8: # Copyright Michigan State University Board of Trustees 9: # 10: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 11: # 12: # LON-CAPA is free software; you can redistribute it and/or modify 13: # it under the terms of the GNU General Public License as published by 14: # the Free Software Foundation; either version 2 of the License, or 15: # (at your option) any later version. 16: # 17: # LON-CAPA is distributed in the hope that it will be useful, 18: # but WITHOUT ANY WARRANTY; without even the implied warranty of 19: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20: # GNU General Public License for more details. 21: # 22: # You should have received a copy of the GNU General Public License 23: # along with LON-CAPA; if not, write to the Free Software 24: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 25: # 26: # /home/httpd/html/adm/gpl.txt 27: # 28: # http://www.lon-capa.org/ 29: # 30: 31: =pod 32: 33: =head1 NAME 34: 35: lonsql - LON TCP-MySQL-Server Daemon for handling database requests. 36: 37: =head1 SYNOPSIS 38: 39: This script should be run as user=www. 40: Note that a lonsql.pid file contains the pid of the parent process. 41: 42: =head1 OVERVIEW 43: 44: =head2 Purpose within LON-CAPA 45: 46: LON-CAPA is meant to distribute A LOT of educational content to A LOT 47: of people. It is ineffective to directly rely on contents within the 48: ext2 filesystem to be speedily scanned for on-the-fly searches of 49: content descriptions. (Simply put, it takes a cumbersome amount of 50: time to open, read, analyze, and close thousands of files.) 51: 52: The solution is to index various data fields that are descriptive of 53: the educational resources on a LON-CAPA server machine in a 54: database. Descriptive data fields are referred to as "metadata". The 55: question then arises as to how this metadata is handled in terms of 56: the rest of the LON-CAPA network without burdening client and daemon 57: processes. 58: 59: The obvious solution, using lonc to send a query to a lond process, 60: doesn't work so well in general as you can see in the following 61: example: 62: 63: lonc= loncapa client process A-lonc= a lonc process on Server A 64: lond= loncapa daemon process 65: 66: database command 67: A-lonc --------TCP/IP----------------> B-lond 68: 69: The problem emerges that A-lonc and B-lond are kept waiting for the 70: MySQL server to "do its stuff", or in other words, perform the 71: conceivably sophisticated, data-intensive, time-sucking database 72: transaction. By tying up a lonc and lond process, this significantly 73: cripples the capabilities of LON-CAPA servers. 74: 75: The solution is to offload the work onto another process, and use 76: lonc and lond just for requests and notifications of completed 77: processing: 78: 79: database command 80: 81: A-lonc ---------TCP/IP-----------------> B-lond =====> B-lonsql 82: <---------------------------------/ | 83: "ok, I'll get back to you..." | 84: | 85: / 86: A-lond <------------------------------- B-lonc <====== 87: "Guess what? I have the result!" 88: 89: Of course, depending on success or failure, the messages may vary, but 90: the principle remains the same where a separate pool of children 91: processes (lonsql's) handle the MySQL database manipulations. 92: 93: Thus, lonc and lond spend effectively no time waiting on results from 94: the database. 95: 96: =head1 Internals 97: 98: =over 4 99: 100: =cut 101: 102: use strict; 103: 104: use lib '/home/httpd/lib/perl/'; 105: use LONCAPA; 106: use LONCAPA::Configuration; 107: use LONCAPA::lonmetadata(); 108: 109: use IO::Socket; 110: use Symbol; 111: use POSIX; 112: use IO::Select; 113: use IO::File; 114: use Socket; 115: use Fcntl; 116: use Tie::RefHash; 117: use DBI; 118: use File::Find; 119: use localenroll; 120: use GDBM_File; 121: use Storable qw(thaw); 122: 123: ######################################################## 124: ######################################################## 125: 126: =pod 127: 128: =item Global Variables 129: 130: =over 4 131: 132: =item dbh 133: 134: =back 135: 136: =cut 137: 138: ######################################################## 139: ######################################################## 140: my $dbh; 141: 142: ######################################################## 143: ######################################################## 144: 145: =pod 146: 147: =item Variables required for forking 148: 149: =over 4 150: 151: =item $MAX_CLIENTS_PER_CHILD 152: 153: The number of clients each child should process. 154: 155: =item %children 156: 157: The keys to %children are the current child process IDs 158: 159: =item $children 160: 161: The current number of children 162: 163: =back 164: 165: =cut 166: 167: ######################################################## 168: ######################################################## 169: my $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process 170: my %children = (); # keys are current child process IDs 171: my $children = 0; # current number of children 172: 173: ################################################################### 174: ################################################################### 175: 176: =pod 177: 178: =item Main body of code. 179: 180: =over 4 181: 182: =item Read data from loncapa_apache.conf and loncapa.conf. 183: 184: =item Ensure we can access the database. 185: 186: =item Determine if there are other instances of lonsql running. 187: 188: =item Read the hosts file. 189: 190: =item Create a socket for lonsql. 191: 192: =item Fork once and dissociate from parent. 193: 194: =item Write PID to disk. 195: 196: =item Prefork children and maintain the population of children. 197: 198: =back 199: 200: =cut 201: 202: ################################################################### 203: ################################################################### 204: my $childmaxattempts=10; 205: my $run =0; # running counter to generate the query-id 206: # 207: # Read loncapa_apache.conf and loncapa.conf 208: # 209: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); 210: my %perlvar=%{$perlvarref}; 211: # 212: # Write the /home/www/.my.cnf file 213: my $conf_file = '/home/www/.my.cnf'; 214: if (! -e $conf_file) { 215: if (open MYCNF, ">$conf_file") { 216: print MYCNF <<"ENDMYCNF"; 217: [client] 218: user=www 219: password=$perlvar{'lonSqlAccess'} 220: ENDMYCNF 221: close MYCNF; 222: } else { 223: warn "Unable to write $conf_file, continuing"; 224: } 225: } 226: 227: 228: # 229: # Make sure that database can be accessed 230: # 231: my $dbh; 232: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www", 233: $perlvar{'lonSqlAccess'}, 234: { RaiseError =>0,PrintError=>0})) { 235: print "Cannot connect to database!\n"; 236: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 237: my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!"; 238: system("echo 'Cannot connect to MySQL database!' |". 239: " mailto $emailto -s '$subj' > /dev/null"); 240: 241: open(SMP,'>/home/httpd/html/lon-status/mysql.txt'); 242: print SMP 'time='.time.'&mysql=defunct'."\n"; 243: close(SMP); 244: 245: exit 1; 246: } else { 247: unlink('/home/httpd/html/lon-status/mysql.txt'); 248: $dbh->disconnect; 249: } 250: 251: # 252: # Check if other instance running 253: # 254: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; 255: if (-e $pidfile) { 256: my $lfh=IO::File->new("$pidfile"); 257: my $pide=<$lfh>; 258: chomp($pide); 259: if (kill 0 => $pide) { die "already running"; } 260: } 261: 262: # 263: # Read hosts file 264: # 265: my $thisserver; 266: my %hostname; 267: my $PREFORK=4; # number of children to maintain, at least four spare 268: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 269: while (my $configline=<CONFIG>) { 270: my ($id,$domain,$role,$name)=split(/:/,$configline); 271: $name=~s/\s//g; 272: $thisserver=$name if ($id eq $perlvar{'lonHostID'}); 273: $hostname{$id}=$name; 274: #$PREFORK++; 275: } 276: close(CONFIG); 277: # 278: #$PREFORK=int($PREFORK/4); 279: 280: # 281: # Create a socket to talk to lond 282: # 283: my $unixsock = "mysqlsock"; 284: my $localfile="$perlvar{'lonSockDir'}/$unixsock"; 285: my $server; 286: unlink ($localfile); 287: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile", 288: Type => SOCK_STREAM, 289: Listen => 10)) { 290: print "in socket error:$@\n"; 291: } 292: 293: # 294: # Fork once and dissociate 295: # 296: my $fpid=fork; 297: exit if $fpid; 298: die "Couldn't fork: $!" unless defined ($fpid); 299: POSIX::setsid() or die "Can't start new session: $!"; 300: 301: # 302: # Write our PID on disk 303: my $execdir=$perlvar{'lonDaemons'}; 304: open (PIDSAVE,">$execdir/logs/lonsql.pid"); 305: print PIDSAVE "$$\n"; 306: close(PIDSAVE); 307: &logthis("CRITICAL: ---------- Starting ----------"); 308: 309: # 310: # Ignore signals generated during initial startup 311: $SIG{HUP}=$SIG{USR1}='IGNORE'; 312: # Now we are on our own 313: # Fork off our children. 314: for (1 .. $PREFORK) { 315: make_new_child(); 316: } 317: 318: # 319: # Install signal handlers. 320: $SIG{CHLD} = \&REAPER; 321: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 322: $SIG{HUP} = \&HUPSMAN; 323: 324: # 325: # And maintain the population. 326: while (1) { 327: sleep; # wait for a signal (i.e., child's death) 328: for (my $i = $children; $i < $PREFORK; $i++) { 329: make_new_child(); # top up the child pool 330: } 331: } 332: 333: ######################################################## 334: ######################################################## 335: 336: =pod 337: 338: =item &make_new_child 339: 340: Inputs: None 341: 342: Returns: None 343: 344: =cut 345: 346: ######################################################## 347: ######################################################## 348: sub make_new_child { 349: my $pid; 350: my $sigset; 351: # 352: # block signal for fork 353: $sigset = POSIX::SigSet->new(SIGINT); 354: sigprocmask(SIG_BLOCK, $sigset) 355: or die "Can't block SIGINT for fork: $!\n"; 356: # 357: die "fork: $!" unless defined ($pid = fork); 358: # 359: if ($pid) { 360: # Parent records the child's birth and returns. 361: sigprocmask(SIG_UNBLOCK, $sigset) 362: or die "Can't unblock SIGINT for fork: $!\n"; 363: $children{$pid} = 1; 364: $children++; 365: return; 366: } else { 367: # Child can *not* return from this subroutine. 368: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 369: # unblock signals 370: sigprocmask(SIG_UNBLOCK, $sigset) 371: or die "Can't unblock SIGINT for fork: $!\n"; 372: #open database handle 373: # making dbh global to avoid garbage collector 374: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www", 375: $perlvar{'lonSqlAccess'}, 376: { RaiseError =>0,PrintError=>0})) { 377: sleep(10+int(rand(20))); 378: &logthis("WARNING: Couldn't connect to database". 379: ": $@"); 380: # "($st secs): $@"); 381: print "database handle error\n"; 382: exit; 383: } 384: # make sure that a database disconnection occurs with 385: # ending kill signals 386: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; 387: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD 388: for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { 389: my $client = $server->accept() or last; 390: # do something with the connection 391: $run = $run+1; 392: my $userinput = <$client>; 393: chomp($userinput); 394: $userinput=~s/\:(\w+)$//; 395: my $searchdomain=$1; 396: # 397: my ($conserver,$query, 398: $arg1,$arg2,$arg3)=split(/&/,$userinput); 399: my $query=unescape($query); 400: # 401: #send query id which is pid_unixdatetime_runningcounter 402: my $queryid = $thisserver; 403: $queryid .="_".($$)."_"; 404: $queryid .= time."_"; 405: $queryid .= $run; 406: print $client "$queryid\n"; 407: # 408: # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3"); 409: sleep 1; 410: # 411: my $result=''; 412: # 413: # At this point, query is received, query-ID assigned and sent 414: # back, $query eq 'logquery' will mean that this is a query 415: # against log-files 416: if (($query eq 'userlog') || ($query eq 'courselog')) { 417: # beginning of log query 418: my $udom = &unescape($arg1); 419: my $uname = &unescape($arg2); 420: my $command = &unescape($arg3); 421: my $path = &propath($udom,$uname); 422: if (-e "$path/activity.log") { 423: if ($query eq 'userlog') { 424: $result=&userlog($path,$command); 425: } else { 426: $result=&courselog($path,$command); 427: } 428: } else { 429: &logthis('Unable to do log query: '.$uname.'@'.$udom); 430: $result='no_such_file'; 431: } 432: # end of log query 433: } elsif (($query eq 'fetchenrollment') || 434: ($query eq 'institutionalphotos')) { 435: # retrieve institutional class lists 436: my $dom = &unescape($arg1); 437: my %affiliates = (); 438: my %replies = (); 439: my $locresult = ''; 440: my $querystr = &unescape($arg3); 441: foreach (split/%%/,$querystr) { 442: if (/^([^=]+)=([^=]+)$/) { 443: @{$affiliates{$1}} = split/,/,$2; 444: } 445: } 446: if ($query eq 'fetchenrollment') { 447: $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies); 448: } elsif ($query eq 'institutionalphotos') { 449: my $crs = &unescape($arg2); 450: eval { 451: local($SIG{__DIE__})='DEFAULT'; 452: $locresult = &localenroll::institutional_photos($dom,$crs,\%affiliates,\%replies,'update'); 453: }; 454: if ($@) { 455: $locresult = 'error'; 456: } 457: } 458: $result = &escape($locresult.':'); 459: if ($locresult) { 460: $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies)); 461: } 462: } elsif ($query eq 'prepare activity log') { 463: my ($cid,$domain) = map {&unescape($_);} ($arg1,$arg2); 464: &logthis('preparing activity log tables for '.$cid); 465: my $command = 466: qq{$perlvar{'lonDaemons'}/parse_activity_log.pl -course=$cid -domain=$domain}; 467: system($command); 468: &logthis($command); 469: my $returnvalue = $?>>8; 470: if ($returnvalue) { 471: $result = 'error: parse_activity_log.pl returned '. 472: $returnvalue; 473: } else { 474: $result = 'success'; 475: } 476: } elsif (($query eq 'portfolio_metadata') || 477: ($query eq 'portfolio_access')) { 478: $result = &portfolio_table_update($query,$arg1,$arg2, 479: $arg3); 480: } else { 481: # Do an sql query 482: $result = &do_sql_query($query,$arg1,$arg2,$searchdomain); 483: } 484: # result does not need to be escaped because it has already been 485: # escaped. 486: #$result=&escape($result); 487: &reply("queryreply:$queryid:$result",$conserver); 488: } 489: # tidy up gracefully and finish 490: # 491: # close the database handle 492: $dbh->disconnect 493: or &logthis("WARNING: Couldn't disconnect". 494: " from database $DBI::errstr : $@"); 495: # this exit is VERY important, otherwise the child will become 496: # a producer of more and more children, forking yourself into 497: # process death. 498: exit; 499: } 500: } 501: 502: ######################################################## 503: ######################################################## 504: 505: =pod 506: 507: =item &do_sql_query 508: 509: Runs an sql metadata table query. 510: 511: Inputs: $query, $custom, $customshow 512: 513: Returns: A string containing escaped results. 514: 515: =cut 516: 517: ######################################################## 518: ######################################################## 519: { 520: my @metalist; 521: 522: sub process_file { 523: if ( -e $_ && # file exists 524: -f $_ && # and is a normal file 525: /\.meta$/ && # ends in meta 526: ! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version 527: ) { 528: push(@metalist,$File::Find::name); 529: } 530: } 531: 532: sub do_sql_query { 533: my ($query,$custom,$customshow,$searchdomain) = @_; 534: 535: # 536: # limit to searchdomain if given and table is metadata 537: # 538: if (($searchdomain) && ($query=~/FROM metadata/)) { 539: $query.=' HAVING (domain="'.$searchdomain.'")'; 540: } 541: # &logthis('doing query ('.$searchdomain.')'.$query); 542: 543: 544: 545: $custom = &unescape($custom); 546: $customshow = &unescape($customshow); 547: # 548: @metalist = (); 549: # 550: my $result = ''; 551: my @results = (); 552: my @files; 553: my $subsetflag=0; 554: # 555: if ($query) { 556: #prepare and execute the query 557: my $sth = $dbh->prepare($query); 558: unless ($sth->execute()) { 559: &logthis(''. 560: 'WARNING: Could not retrieve from database:'. 561: $sth->errstr().''); 562: } else { 563: my $aref=$sth->fetchall_arrayref; 564: foreach my $row (@$aref) { 565: push @files,@{$row}[3] if ($custom or $customshow); 566: my @b=map { &escape($_); } @$row; 567: push @results,join(",", @b); 568: # Build up the @files array with the LON-CAPA urls 569: # of the resources. 570: } 571: } 572: } 573: # do custom metadata searching here and build into result 574: return join("&",@results) if (! ($custom or $customshow)); 575: # Only get here if there is a custom query or custom show request 576: &logthis("Doing custom query for $custom"); 577: if ($query) { 578: @metalist=map { 579: $perlvar{'lonDocRoot'}.$_.'.meta'; 580: } @files; 581: } else { 582: my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"; 583: @metalist=(); 584: opendir(RESOURCES,$dir); 585: my @homeusers=grep { 586: &ishome($dir.'/'.$_); 587: } grep {!/^\.\.?$/} readdir(RESOURCES); 588: closedir RESOURCES; 589: # Define the 590: foreach my $user (@homeusers) { 591: find (\&process_file,$dir.'/'.$user); 592: } 593: } 594: # if file is indicated in sql database and 595: # not part of sql-relevant query, do not pattern match. 596: # 597: # if file is not in sql database, output error. 598: # 599: # if file is indicated in sql database and is 600: # part of query result list, then do the pattern match. 601: my $customresult=''; 602: my @results; 603: foreach my $metafile (@metalist) { 604: my $fh=IO::File->new($metafile); 605: my @lines=<$fh>; 606: my $stuff=join('',@lines); 607: if ($stuff=~/$custom/s) { 608: foreach my $f ('abstract','author','copyright', 609: 'creationdate','keywords','language', 610: 'lastrevisiondate','mime','notes', 611: 'owner','subject','title') { 612: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s; 613: } 614: my $mfile=$metafile; 615: my $docroot=$perlvar{'lonDocRoot'}; 616: $mfile=~s/^$docroot//; 617: $mfile=~s/\.meta$//; 618: unless ($query) { 619: my $q2="SELECT * FROM metadata WHERE url ". 620: " LIKE BINARY '?'"; 621: my $sth = $dbh->prepare($q2); 622: $sth->execute($mfile); 623: my $aref=$sth->fetchall_arrayref; 624: foreach my $a (@$aref) { 625: my @b=map { &escape($_)} @$a; 626: push @results,join(",", @b); 627: } 628: } 629: # &logthis("found: $stuff"); 630: $customresult.='&custom='.&escape($mfile).','. 631: escape($stuff); 632: } 633: } 634: $result=join("&",@results) unless $query; 635: $result.=$customresult; 636: # 637: return $result; 638: } # End of &do_sql_query 639: 640: } # End of scoping curly braces for &process_file and &do_sql_query 641: 642: sub portfolio_table_update { 643: my ($query,$arg1,$arg2,$arg3) = @_; 644: my %tablenames = ( 645: 'portfolio' => 'portfolio_metadata', 646: 'access' => 'portfolio_access', 647: 'addedfields' => 'portfolio_addedfields', 648: ); 649: my $result = 'ok'; 650: my $tablechk = &check_table($query); 651: if ($tablechk == 0) { 652: my $request = 653: &LONCAPA::lonmetadata::create_metadata_storage($query,$query); 654: $dbh->do($request); 655: if ($dbh->err) { 656: &logthis("create $query". 657: " ERROR: ".$dbh->errstr); 658: $result = 'error'; 659: } 660: } 661: if ($result eq 'ok') { 662: my ($uname,$udom) = split(/:/,&unescape($arg1)); 663: my $file_name = &unescape($arg2); 664: my $group = &unescape($arg3); 665: my $is_course = 0; 666: if ($group ne '') { 667: $is_course = 1; 668: } 669: my $urlstart = '/uploaded/'.$udom.'/'.$uname; 670: my $pathstart = &propath($udom,$uname).'/userfiles'; 671: my ($fullpath,$url); 672: if ($is_course) { 673: $fullpath = $pathstart.'/groups/'.$group.'/portfolio'. 674: $file_name; 675: $url = $urlstart.'/groups/'.$group.'/portfolio'.$file_name; 676: } else { 677: $fullpath = $pathstart.'/portfolio'.$file_name; 678: $url = $urlstart.'/portfolio'.$file_name; 679: } 680: my %access = &get_access_hash($uname,$udom,$group.$file_name); 681: if ($query eq 'portfolio_metadata') { 682: if (-e $fullpath.'.meta') { 683: my %loghash = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef,\%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group,'update'); 684: if (keys(%loghash) > 0) { 685: &portfolio_logging(%loghash); 686: } 687: } 688: } elsif ($query eq 'portfolio_access') { 689: my %loghash = 690: &LONCAPA::lonmetadata::process_portfolio_access_data($dbh,undef, 691: \%tablenames,$url,$fullpath,\%access,'update'); 692: if (keys(%loghash) > 0) { 693: &portfolio_logging(%loghash); 694: } else { 695: my $available = 0; 696: foreach my $key (keys(%access)) { 697: my ($num,$scope,$end,$start) = 698: ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); 699: if ($scope eq 'public' || $scope eq 'guest') { 700: $available = 1; 701: last; 702: } 703: } 704: if ($available) { 705: # Retrieve current values 706: my $condition = 'url='.$dbh->quote("$url"); 707: my ($error,$row) = 708: &LONCAPA::lonmetadata::lookup_metadata($dbh,$condition,undef, 709: 'portfolio_metadata'); 710: if (!$error) { 711: if (!(ref($row->[0]) eq 'ARRAY')) { 712: my %loghash = 713: &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef, 714: \%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group); 715: if (keys(%loghash) > 0) { 716: &portfolio_logging(%loghash); 717: } 718: } 719: } 720: } 721: } 722: } 723: } 724: return $result; 725: } 726: 727: sub get_access_hash { 728: my ($uname,$udom,$file) = @_; 729: my $hashref = &tie_user_hash($udom,$uname,'file_permissions', 730: &GDBM_READER()); 731: my %curr_perms; 732: my %access; 733: if ($hashref) { 734: while (my ($key,$value) = each(%$hashref)) { 735: $key = &unescape($key); 736: next if ($key =~ /^error: 2 /); 737: $curr_perms{$key}=&thaw_unescape($value); 738: } 739: if (!&untie_user_hash($hashref)) { 740: &logthis("error: ".($!+0)." untie (GDBM) Failed"); 741: } 742: } else { 743: &logthis("error: ".($!+0)." tie (GDBM) Failed"); 744: } 745: if (keys(%curr_perms) > 0) { 746: if (ref($curr_perms{$file."\0".'accesscontrol'}) eq 'HASH') { 747: foreach my $acl (keys(%{$curr_perms{$file."\0".'accesscontrol'}})) { 748: $access{$acl} = $curr_perms{$file."\0".$acl}; 749: } 750: } 751: } 752: return %access; 753: } 754: 755: sub thaw_unescape { 756: my ($value)=@_; 757: if ($value =~ /^__FROZEN__/) { 758: substr($value,0,10,undef); 759: $value=&unescape($value); 760: return &thaw($value); 761: } 762: return &unescape($value); 763: } 764: 765: ########################################### 766: sub check_table { 767: my ($table_id) = @_; 768: my $sth=$dbh->prepare('SHOW TABLES'); 769: $sth->execute(); 770: my $aref = $sth->fetchall_arrayref; 771: $sth->finish(); 772: if ($sth->err()) { 773: &logthis("fetchall_arrayref after SHOW TABLES". 774: " ERROR: ".$sth->errstr); 775: return undef; 776: } 777: my $result = 0; 778: foreach my $table (@{$aref}) { 779: if ($table->[0] eq $table_id) { 780: $result = 1; 781: last; 782: } 783: } 784: return $result; 785: } 786: 787: ########################################### 788: 789: sub portfolio_logging { 790: my (%portlog) = @_; 791: foreach my $key (keys(%portlog)) { 792: if (ref($portlog{$key}) eq 'HASH') { 793: foreach my $item (keys(%{$portlog{$key}})) { 794: &logthis($portlog{$key}{$item}); 795: } 796: } 797: } 798: } 799: 800: 801: ######################################################## 802: ######################################################## 803: 804: =pod 805: 806: =item &logthis 807: 808: Inputs: $message, the message to log 809: 810: Returns: nothing 811: 812: Writes $message to the logfile. 813: 814: =cut 815: 816: ######################################################## 817: ######################################################## 818: sub logthis { 819: my $message=shift; 820: my $execdir=$perlvar{'lonDaemons'}; 821: my $fh=IO::File->new(">>$execdir/logs/lonsql.log"); 822: my $now=time; 823: my $local=localtime($now); 824: print $fh "$local ($$): $message\n"; 825: } 826: 827: # -------------------------------------------------- Non-critical communication 828: 829: ######################################################## 830: ######################################################## 831: 832: =pod 833: 834: =item &subreply 835: 836: Sends a command to a server. Called only by &reply. 837: 838: Inputs: $cmd,$server 839: 840: Returns: The results of the message or 'con_lost' on error. 841: 842: =cut 843: 844: ######################################################## 845: ######################################################## 846: sub subreply { 847: my ($cmd,$server)=@_; 848: my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; 849: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 850: Type => SOCK_STREAM, 851: Timeout => 10) 852: or return "con_lost"; 853: print $sclient "sethost:$server:$cmd\n"; 854: my $answer=<$sclient>; 855: chomp($answer); 856: $answer="con_lost" if (!$answer); 857: return $answer; 858: } 859: 860: ######################################################## 861: ######################################################## 862: 863: =pod 864: 865: =item &reply 866: 867: Sends a command to a server. 868: 869: Inputs: $cmd,$server 870: 871: Returns: The results of the message or 'con_lost' on error. 872: 873: =cut 874: 875: ######################################################## 876: ######################################################## 877: sub reply { 878: my ($cmd,$server)=@_; 879: my $answer; 880: if ($server ne $perlvar{'lonHostID'}) { 881: $answer=subreply($cmd,$server); 882: if ($answer eq 'con_lost') { 883: $answer=subreply("ping",$server); 884: $answer=subreply($cmd,$server); 885: } 886: } else { 887: $answer='self_reply'; 888: $answer=subreply($cmd,$server); 889: } 890: return $answer; 891: } 892: 893: ######################################################## 894: ######################################################## 895: 896: =pod 897: 898: =item &ishome 899: 900: Determine if the current machine is the home server for a user. 901: The determination is made by checking the filesystem for the users information. 902: 903: Inputs: $author 904: 905: Returns: 0 - this is not the authors home server, 1 - this is. 906: 907: =cut 908: 909: ######################################################## 910: ######################################################## 911: sub ishome { 912: my $author=shift; 913: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 914: my ($udom,$uname)=split(/\//,$author); 915: my $proname=propath($udom,$uname); 916: if (-e $proname) { 917: return 1; 918: } else { 919: return 0; 920: } 921: } 922: 923: ######################################################## 924: ######################################################## 925: 926: =pod 927: 928: =item &propath 929: 930: Inputs: user name, user domain 931: 932: Returns: The full path to the users directory. 933: 934: =cut 935: 936: ######################################################## 937: ######################################################## 938: sub propath { 939: my ($udom,$uname)=@_; 940: $udom=~s/\W//g; 941: $uname=~s/\W//g; 942: my $subdir=$uname.'__'; 943: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 944: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 945: return $proname; 946: } 947: 948: ######################################################## 949: ######################################################## 950: 951: =pod 952: 953: =item &courselog 954: 955: Inputs: $path, $command 956: 957: Returns: unescaped string of values. 958: 959: =cut 960: 961: ######################################################## 962: ######################################################## 963: sub courselog { 964: my ($path,$command)=@_; 965: my %filters=(); 966: foreach (split(/\:/,&unescape($command))) { 967: my ($name,$value)=split(/\=/,$_); 968: $filters{$name}=$value; 969: } 970: my @results=(); 971: open(IN,$path.'/activity.log') or return ('file_error'); 972: while (my $line=<IN>) { 973: chomp($line); 974: my ($timestamp,$host,$log)=split(/\:/,$line); 975: # 976: # $log has the actual log entries; currently still escaped, and 977: # %26(timestamp)%3a(url)%3a(user)%3a(domain) 978: # then additionally 979: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value) 980: # or 981: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value) 982: # 983: # get delimiter between timestamped entries to be &&& 984: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g; 985: # now go over all log entries 986: foreach (split(/\&\&\&/,&unescape($log))) { 987: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_); 988: my $values=&unescape(join(':',@values)); 989: $values=~s/\&/\:/g; 990: $res=&unescape($res); 991: my $include=1; 992: if (($filters{'username'}) && ($uname ne $filters{'username'})) 993: { $include=0; } 994: if (($filters{'domain'}) && ($udom ne $filters{'domain'})) 995: { $include=0; } 996: if (($filters{'url'}) && ($res!~/$filters{'url'}/)) 997: { $include=0; } 998: if (($filters{'start'}) && ($time<$filters{'start'})) 999: { $include=0; } 1000: if (($filters{'end'}) && ($time>$filters{'end'})) 1001: { $include=0; } 1002: if (($filters{'action'} eq 'view') && ($action)) 1003: { $include=0; } 1004: if (($filters{'action'} eq 'submit') && ($action ne 'POST')) 1005: { $include=0; } 1006: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) 1007: { $include=0; } 1008: if ($include) { 1009: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'. 1010: $uname.':'.$udom.':'. 1011: $action.':'.$values); 1012: } 1013: } 1014: } 1015: close IN; 1016: return join('&',sort(@results)); 1017: } 1018: 1019: ######################################################## 1020: ######################################################## 1021: 1022: =pod 1023: 1024: =item &userlog 1025: 1026: Inputs: $path, $command 1027: 1028: Returns: unescaped string of values. 1029: 1030: =cut 1031: 1032: ######################################################## 1033: ######################################################## 1034: sub userlog { 1035: my ($path,$command)=@_; 1036: my %filters=(); 1037: foreach (split(/\:/,&unescape($command))) { 1038: my ($name,$value)=split(/\=/,$_); 1039: $filters{$name}=$value; 1040: } 1041: my @results=(); 1042: open(IN,$path.'/activity.log') or return ('file_error'); 1043: while (my $line=<IN>) { 1044: chomp($line); 1045: my ($timestamp,$host,$log)=split(/\:/,$line); 1046: $log=&unescape($log); 1047: my $include=1; 1048: if (($filters{'start'}) && ($timestamp<$filters{'start'})) 1049: { $include=0; } 1050: if (($filters{'end'}) && ($timestamp>$filters{'end'})) 1051: { $include=0; } 1052: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; } 1053: if (($filters{'action'} eq 'check') && ($log!~/^Check/)) 1054: { $include=0; } 1055: if ($include) { 1056: push(@results,$timestamp.':'.$log); 1057: } 1058: } 1059: close IN; 1060: return join('&',sort(@results)); 1061: } 1062: 1063: ######################################################## 1064: ######################################################## 1065: 1066: =pod 1067: 1068: =item Functions required for forking 1069: 1070: =over 4 1071: 1072: =item REAPER 1073: 1074: REAPER takes care of dead children. 1075: 1076: =item HUNTSMAN 1077: 1078: Signal handler for SIGINT. 1079: 1080: =item HUPSMAN 1081: 1082: Signal handler for SIGHUP 1083: 1084: =item DISCONNECT 1085: 1086: Disconnects from database. 1087: 1088: =back 1089: 1090: =cut 1091: 1092: ######################################################## 1093: ######################################################## 1094: sub REAPER { # takes care of dead children 1095: $SIG{CHLD} = \&REAPER; 1096: my $pid = wait; 1097: $children --; 1098: &logthis("Child $pid died"); 1099: delete $children{$pid}; 1100: } 1101: 1102: sub HUNTSMAN { # signal handler for SIGINT 1103: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 1104: kill 'INT' => keys %children; 1105: my $execdir=$perlvar{'lonDaemons'}; 1106: unlink("$execdir/logs/lonsql.pid"); 1107: &logthis("CRITICAL: Shutting down"); 1108: $unixsock = "mysqlsock"; 1109: my $port="$perlvar{'lonSockDir'}/$unixsock"; 1110: unlink($port); 1111: exit; # clean up with dignity 1112: } 1113: 1114: sub HUPSMAN { # signal handler for SIGHUP 1115: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 1116: kill 'INT' => keys %children; 1117: close($server); # free up socket 1118: &logthis("CRITICAL: Restarting"); 1119: my $execdir=$perlvar{'lonDaemons'}; 1120: $unixsock = "mysqlsock"; 1121: my $port="$perlvar{'lonSockDir'}/$unixsock"; 1122: unlink($port); 1123: exec("$execdir/lonsql"); # here we go again 1124: } 1125: 1126: sub DISCONNECT { 1127: $dbh->disconnect or 1128: &logthis("WARNING: Couldn't disconnect from database ". 1129: " $DBI::errstr : $@"); 1130: exit; 1131: } 1132: 1133: 1134: =pod 1135: 1136: =back 1137: 1138: =cut