Annotation of loncom/lond, revision 1.67
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.67 ! albertel 5: # $Id: lond,v 1.66 2002/02/05 18:05:47 www Exp $
1.60 www 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27: # http://www.lon-capa.org/
28: #
1.1 albertel 29: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
1.2 www 30: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
1.6 www 31: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
1.11 www 32: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
1.12 harris41 33: # 03/07,05/31 Gerd Kortemeyer
1.13 www 34: # 06/26 Scott Harrison
1.20 www 35: # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
1.25 www 36: # 12/05 Scott Harrison
1.34 www 37: # 12/05,12/13,12/29 Gerd Kortemeyer
1.61 harris41 38: # YEAR=2001
1.36 www 39: # Jan 01 Scott Harrison
40: # 02/12 Gerd Kortemeyer
1.37 harris41 41: # 03/15 Scott Harrison
1.41 www 42: # 03/24 Gerd Kortemeyer
1.47 www 43: # 04/02 Scott Harrison
1.51 www 44: # 05/11,05/28,08/30 Gerd Kortemeyer
1.56 harris41 45: # 9/30,10/22,11/13,11/15,11/16 Scott Harrison
1.59 www 46: # 11/26,11/27 Gerd Kortemeyer
1.61 harris41 47: # 12/20 Scott Harrison
1.62 www 48: # 12/22 Gerd Kortemeyer
1.63 www 49: # YEAR=2002
1.65 www 50: # 01/20/02,02/05 Gerd Kortemeyer
1.54 harris41 51: ###
52:
1.1 albertel 53: # based on "Perl Cookbook" ISBN 1-56592-243-3
54: # preforker - server who forks first
55: # runs as a daemon
56: # HUPs
57: # uses IDEA encryption
58:
59: use IO::Socket;
60: use IO::File;
61: use Apache::File;
62: use Symbol;
63: use POSIX;
64: use Crypt::IDEA;
65: use LWP::UserAgent();
1.3 www 66: use GDBM_File;
67: use Authen::Krb4;
1.49 albertel 68: use lib '/home/httpd/lib/perl/';
69: use localauth;
1.1 albertel 70:
1.57 www 71: my $status='';
72: my $lastlog='';
73:
1.23 harris41 74: # grabs exception and records it to log before exiting
75: sub catchexception {
1.27 albertel 76: my ($error)=@_;
1.25 www 77: $SIG{'QUIT'}='DEFAULT';
78: $SIG{__DIE__}='DEFAULT';
1.23 harris41 79: &logthis("<font color=red>CRITICAL: "
80: ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
1.27 albertel 81: ."a crash with this error msg->[$error]</font>");
1.57 www 82: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 83: if ($client) { print $client "error: $error\n"; }
1.59 www 84: $server->close();
1.27 albertel 85: die($error);
1.23 harris41 86: }
87:
1.63 www 88: sub timeout {
89: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
90: &catchexception('Timeout');
91: }
1.22 harris41 92: # -------------------------------- Set signal handlers to record abnormal exits
93:
94: $SIG{'QUIT'}=\&catchexception;
95: $SIG{__DIE__}=\&catchexception;
96:
1.1 albertel 97: # ------------------------------------ Read httpd access.conf and get variables
98:
1.29 harris41 99: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
1.1 albertel 100:
101: while ($configline=<CONFIG>) {
102: if ($configline =~ /PerlSetVar/) {
103: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.7 www 104: chomp($varvalue);
1.1 albertel 105: $perlvar{$varname}=$varvalue;
106: }
107: }
108: close(CONFIG);
1.19 www 109:
1.35 harris41 110: # ----------------------------- Make sure this process is running from user=www
111: my $wwwid=getpwnam('www');
112: if ($wwwid!=$<) {
113: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
114: $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
1.37 harris41 115: system("echo 'User ID mismatch. lond must be run as user www.' |\
1.35 harris41 116: mailto $emailto -s '$subj' > /dev/null");
117: exit 1;
118: }
119:
1.19 www 120: # --------------------------------------------- Check if other instance running
121:
122: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
123:
124: if (-e $pidfile) {
125: my $lfh=IO::File->new("$pidfile");
126: my $pide=<$lfh>;
127: chomp($pide);
1.29 harris41 128: if (kill 0 => $pide) { die "already running"; }
1.19 www 129: }
1.1 albertel 130:
131: $PREFORK=4; # number of children to maintain, at least four spare
132:
133: # ------------------------------------------------------------- Read hosts file
134:
1.29 harris41 135: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.1 albertel 136:
137: while ($configline=<CONFIG>) {
138: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
139: chomp($ip);
140: $hostid{$ip}=$id;
141: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
142: $PREFORK++;
143: }
144: close(CONFIG);
145:
146: # establish SERVER socket, bind and listen.
147: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
148: Type => SOCK_STREAM,
149: Proto => 'tcp',
150: Reuse => 1,
151: Listen => 10 )
1.29 harris41 152: or die "making socket: $@\n";
1.1 albertel 153:
154: # --------------------------------------------------------- Do global variables
155:
156: # global variables
157:
158: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should
159: # process
160: %children = (); # keys are current child process IDs
161: $children = 0; # current number of children
162:
163: sub REAPER { # takes care of dead children
164: $SIG{CHLD} = \&REAPER;
165: my $pid = wait;
1.67 ! albertel 166: if (defined($children{$pid})) {
! 167: &logthis("Child $pid died");
! 168: $children --;
! 169: delete $children{$pid};
! 170: } else {
! 171: &logthis("Unknown Child $pid died");
! 172: }
1.1 albertel 173: }
174:
175: sub HUNTSMAN { # signal handler for SIGINT
176: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
177: kill 'INT' => keys %children;
1.59 www 178: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 179: my $execdir=$perlvar{'lonDaemons'};
180: unlink("$execdir/logs/lond.pid");
1.9 www 181: &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.1 albertel 182: exit; # clean up with dignity
183: }
184:
185: sub HUPSMAN { # signal handler for SIGHUP
186: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
187: kill 'INT' => keys %children;
1.59 www 188: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.9 www 189: &logthis("<font color=red>CRITICAL: Restarting</font>");
1.30 harris41 190: unlink("$execdir/logs/lond.pid");
1.1 albertel 191: my $execdir=$perlvar{'lonDaemons'};
192: exec("$execdir/lond"); # here we go again
193: }
194:
1.57 www 195: sub checkchildren {
196: &initnewstatus();
197: &logstatus();
198: &logthis('Going to check on the children');
1.63 www 199: $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 200: foreach (sort keys %children) {
1.57 www 201: sleep 1;
202: unless (kill 'USR1' => $_) {
203: &logthis ('Child '.$_.' is dead');
204: &logstatus($$.' is dead');
205: }
1.61 harris41 206: }
1.63 www 207: sleep 5;
208: foreach (sort keys %children) {
209: unless (-e "$docdir/lon-status/londchld/$_.txt") {
210: &logthis('Child '.$_.' did not respond');
1.67 ! albertel 211: kill 9 => $_;
! 212: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
! 213: $subj="LON: $perlvar{'lonHostID'} killed lond process $_";
! 214: my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`
1.66 www 215: $execdir=$perlvar{'lonDaemons'};
1.67 ! albertel 216: $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`
1.63 www 217: }
218: }
1.57 www 219: }
220:
1.1 albertel 221: # --------------------------------------------------------------------- Logging
222:
223: sub logthis {
224: my $message=shift;
225: my $execdir=$perlvar{'lonDaemons'};
226: my $fh=IO::File->new(">>$execdir/logs/lond.log");
227: my $now=time;
228: my $local=localtime($now);
1.58 www 229: $lastlog=$local.': '.$message;
1.1 albertel 230: print $fh "$local ($$): $message\n";
231: }
232:
1.57 www 233: # ------------------------------------------------------------------ Log status
234:
235: sub logstatus {
236: my $docdir=$perlvar{'lonDocRoot'};
1.63 www 237: {
1.57 www 238: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
239: print $fh $$."\t".$status."\t".$lastlog."\n";
1.63 www 240: $fh->close();
241: }
242: {
243: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
244: print $fh $status."\n".$lastlog."\n".time;
245: $fh->close();
246: }
1.57 www 247: }
248:
249: sub initnewstatus {
250: my $docdir=$perlvar{'lonDocRoot'};
251: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
252: my $now=time;
253: my $local=localtime($now);
254: print $fh "LOND status $local - parent $$\n\n";
1.64 www 255: opendir(DIR,"$docdir/lon-status/londchld");
256: while ($filename=readdir(DIR)) {
257: unlink("$docdir/lon-status/londchld/$filename");
258: }
259: closedir(DIR);
1.57 www 260: }
261:
262: # -------------------------------------------------------------- Status setting
263:
264: sub status {
265: my $what=shift;
266: my $now=time;
267: my $local=localtime($now);
268: $status=$local.': '.$what;
269: }
1.11 www 270:
271: # -------------------------------------------------------- Escape Special Chars
272:
273: sub escape {
274: my $str=shift;
275: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
276: return $str;
277: }
278:
279: # ----------------------------------------------------- Un-Escape Special Chars
280:
281: sub unescape {
282: my $str=shift;
283: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
284: return $str;
285: }
286:
1.1 albertel 287: # ----------------------------------------------------------- Send USR1 to lonc
288:
289: sub reconlonc {
290: my $peerfile=shift;
291: &logthis("Trying to reconnect for $peerfile");
292: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
293: if (my $fh=IO::File->new("$loncfile")) {
294: my $loncpid=<$fh>;
295: chomp($loncpid);
296: if (kill 0 => $loncpid) {
297: &logthis("lonc at pid $loncpid responding, sending USR1");
298: kill USR1 => $loncpid;
299: sleep 1;
300: if (-e "$peerfile") { return; }
301: &logthis("$peerfile still not there, give it another try");
302: sleep 5;
303: if (-e "$peerfile") { return; }
1.9 www 304: &logthis(
305: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 306: } else {
1.9 www 307: &logthis(
308: "<font color=red>CRITICAL: "
309: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 310: }
311: } else {
1.9 www 312: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
1.1 albertel 313: }
314: }
315:
316: # -------------------------------------------------- Non-critical communication
1.11 www 317:
1.1 albertel 318: sub subreply {
319: my ($cmd,$server)=@_;
320: my $peerfile="$perlvar{'lonSockDir'}/$server";
321: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
322: Type => SOCK_STREAM,
323: Timeout => 10)
324: or return "con_lost";
325: print $sclient "$cmd\n";
326: my $answer=<$sclient>;
327: chomp($answer);
328: if (!$answer) { $answer="con_lost"; }
329: return $answer;
330: }
331:
332: sub reply {
333: my ($cmd,$server)=@_;
334: my $answer;
335: if ($server ne $perlvar{'lonHostID'}) {
336: $answer=subreply($cmd,$server);
337: if ($answer eq 'con_lost') {
338: $answer=subreply("ping",$server);
339: if ($answer ne $server) {
340: &reconlonc("$perlvar{'lonSockDir'}/$server");
341: }
342: $answer=subreply($cmd,$server);
343: }
344: } else {
345: $answer='self_reply';
346: }
347: return $answer;
348: }
349:
1.13 www 350: # -------------------------------------------------------------- Talk to lonsql
351:
1.12 harris41 352: sub sqlreply {
353: my ($cmd)=@_;
354: my $answer=subsqlreply($cmd);
355: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
356: return $answer;
357: }
358:
359: sub subsqlreply {
360: my ($cmd)=@_;
361: my $unixsock="mysqlsock";
362: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
363: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
364: Type => SOCK_STREAM,
365: Timeout => 10)
366: or return "con_lost";
367: print $sclient "$cmd\n";
368: my $answer=<$sclient>;
369: chomp($answer);
370: if (!$answer) { $answer="con_lost"; }
371: return $answer;
372: }
373:
1.1 albertel 374: # -------------------------------------------- Return path to profile directory
1.11 www 375:
1.1 albertel 376: sub propath {
377: my ($udom,$uname)=@_;
378: $udom=~s/\W//g;
379: $uname=~s/\W//g;
1.16 www 380: my $subdir=$uname.'__';
1.1 albertel 381: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
382: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
383: return $proname;
384: }
385:
386: # --------------------------------------- Is this the home server of an author?
1.11 www 387:
1.1 albertel 388: sub ishome {
389: my $author=shift;
390: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
391: my ($udom,$uname)=split(/\//,$author);
392: my $proname=propath($udom,$uname);
393: if (-e $proname) {
394: return 'owner';
395: } else {
396: return 'not_owner';
397: }
398: }
399:
400: # ======================================================= Continue main program
401: # ---------------------------------------------------- Fork once and dissociate
402:
403: $fpid=fork;
404: exit if $fpid;
1.29 harris41 405: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 406:
1.29 harris41 407: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 408:
409: # ------------------------------------------------------- Write our PID on disk
410:
411: $execdir=$perlvar{'lonDaemons'};
412: open (PIDSAVE,">$execdir/logs/lond.pid");
413: print PIDSAVE "$$\n";
414: close(PIDSAVE);
1.9 www 415: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.57 www 416: &status('Starting');
1.1 albertel 417:
418: # ------------------------------------------------------- Now we are on our own
419:
420: # Fork off our children.
421: for (1 .. $PREFORK) {
422: make_new_child();
423: }
424:
425: # ----------------------------------------------------- Install signal handlers
426:
1.57 www 427: &status('Forked children');
428:
1.1 albertel 429: $SIG{CHLD} = \&REAPER;
430: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
431: $SIG{HUP} = \&HUPSMAN;
1.57 www 432: $SIG{USR1} = \&checkchildren;
1.1 albertel 433:
434: # And maintain the population.
435: while (1) {
1.57 www 436: &status('Sleeping');
1.1 albertel 437: sleep; # wait for a signal (i.e., child's death)
1.57 www 438: &logthis('Woke up');
439: &status('Woke up');
1.1 albertel 440: for ($i = $children; $i < $PREFORK; $i++) {
441: make_new_child(); # top up the child pool
442: }
443: }
444:
445: sub make_new_child {
446: my $pid;
447: my $cipher;
448: my $sigset;
449: &logthis("Attempting to start child");
450: # block signal for fork
451: $sigset = POSIX::SigSet->new(SIGINT);
452: sigprocmask(SIG_BLOCK, $sigset)
1.29 harris41 453: or die "Can't block SIGINT for fork: $!\n";
1.1 albertel 454:
1.29 harris41 455: die "fork: $!" unless defined ($pid = fork);
1.1 albertel 456:
457: if ($pid) {
458: # Parent records the child's birth and returns.
459: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 460: or die "Can't unblock SIGINT for fork: $!\n";
1.1 albertel 461: $children{$pid} = 1;
462: $children++;
1.57 www 463: &status('Started child '.$pid);
1.1 albertel 464: return;
465: } else {
466: # Child can *not* return from this subroutine.
467: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.57 www 468: $SIG{USR1}= \&logstatus;
1.63 www 469: $SIG{ALRM}= \&timeout;
1.57 www 470: $lastlog='Forked ';
471: $status='Forked';
472:
1.1 albertel 473: # unblock signals
474: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 475: or die "Can't unblock SIGINT for fork: $!\n";
1.13 www 476:
477: $tmpsnum=0;
1.1 albertel 478:
479: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
480: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
1.57 www 481: &status('Idle, waiting for connection');
1.1 albertel 482: $client = $server->accept() or last;
1.57 www 483: &status('Accepted connection');
1.1 albertel 484: # =============================================================================
485: # do something with the connection
486: # -----------------------------------------------------------------------------
1.2 www 487: # see if we know client and check for spoof IP by challenge
1.1 albertel 488: my $caller=getpeername($client);
489: my ($port,$iaddr)=unpack_sockaddr_in($caller);
490: my $clientip=inet_ntoa($iaddr);
491: my $clientrec=($hostid{$clientip} ne undef);
1.9 www 492: &logthis(
1.51 www 493: "<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"
494: );
1.57 www 495: &status("Connecting $clientip ($hostid{$clientip})");
1.2 www 496: my $clientok;
1.1 albertel 497: if ($clientrec) {
1.57 www 498: &status("Waiting for init from $clientip ($hostid{$clientip})");
1.2 www 499: my $remotereq=<$client>;
500: $remotereq=~s/\W//g;
501: if ($remotereq eq 'init') {
502: my $challenge="$$".time;
503: print $client "$challenge\n";
1.57 www 504: &status(
505: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
1.2 www 506: $remotereq=<$client>;
507: $remotereq=~s/\W//g;
508: if ($challenge eq $remotereq) {
509: $clientok=1;
510: print $client "ok\n";
511: } else {
1.9 www 512: &logthis(
513: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
1.57 www 514: &status('No challenge reply '.$clientip);
1.2 www 515: }
516: } else {
1.9 www 517: &logthis(
518: "<font color=blue>WARNING: "
519: ."$clientip failed to initialize: >$remotereq< </font>");
1.57 www 520: &status('No init '.$clientip);
1.2 www 521: }
522: } else {
1.9 www 523: &logthis(
524: "<font color=blue>WARNING: Unknown client $clientip</font>");
1.57 www 525: &status('Hung up on '.$clientip);
1.2 www 526: }
527: if ($clientok) {
1.1 albertel 528: # ---------------- New known client connecting, could mean machine online again
529: &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
1.9 www 530: &logthis(
531: "<font color=green>Established connection: $hostid{$clientip}</font>");
1.58 www 532: &status('Will listen to '.$hostid{$clientip});
1.1 albertel 533: # ------------------------------------------------------------ Process requests
534: while (my $userinput=<$client>) {
535: chomp($userinput);
1.57 www 536: &status('Processing '.$hostid{$clientip}.': '.$userinput);
1.1 albertel 537: my $wasenc=0;
1.63 www 538: alarm(120);
1.1 albertel 539: # ------------------------------------------------------------ See if encrypted
540: if ($userinput =~ /^enc/) {
541: if ($cipher) {
542: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
543: $userinput='';
544: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
545: $userinput.=
546: $cipher->decrypt(
547: pack("H16",substr($encinput,$encidx,16))
548: );
549: }
550: $userinput=substr($userinput,0,$cmdlength);
551: $wasenc=1;
552: }
553: }
554: # ------------------------------------------------------------- Normal commands
555: # ------------------------------------------------------------------------ ping
556: if ($userinput =~ /^ping/) {
557: print $client "$perlvar{'lonHostID'}\n";
558: # ------------------------------------------------------------------------ pong
559: } elsif ($userinput =~ /^pong/) {
560: $reply=reply("ping",$hostid{$clientip});
561: print $client "$perlvar{'lonHostID'}:$reply\n";
562: # ------------------------------------------------------------------------ ekey
563: } elsif ($userinput =~ /^ekey/) {
564: my $buildkey=time.$$.int(rand 100000);
565: $buildkey=~tr/1-6/A-F/;
566: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
567: my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
568: $key=~tr/a-z/A-Z/;
569: $key=~tr/G-P/0-9/;
570: $key=~tr/Q-Z/0-9/;
571: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
572: $key=substr($key,0,32);
573: my $cipherkey=pack("H32",$key);
574: $cipher=new IDEA $cipherkey;
575: print $client "$buildkey\n";
576: # ------------------------------------------------------------------------ load
577: } elsif ($userinput =~ /^load/) {
578: my $loadavg;
579: {
580: my $loadfile=IO::File->new('/proc/loadavg');
581: $loadavg=<$loadfile>;
582: }
583: $loadavg =~ s/\s.*//g;
584: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
585: print $client "$loadpercent\n";
1.54 harris41 586: # ----------------------------------------------------------------- currentauth
587: } elsif ($userinput =~ /^currentauth/) {
588: if ($wasenc==1) {
589: my ($cmd,$udom,$uname)=split(/:/,$userinput);
590: my $proname=propath($udom,$uname);
591: my $passfilename="$proname/passwd";
592: if (-e $passfilename) {
593: my $pf = IO::File->new($passfilename);
594: my $realpasswd=<$pf>;
595: chomp($realpasswd);
596: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
597: my $availablecontent='';
598: if ($howpwd eq 'krb4') {
599: $availablecontent=$contentpwd;
600: }
601: print $client "$howpwd:$availablecontent\n";
602: } else {
603: print $client "unknown_user\n";
604: }
605: } else {
606: print $client "refused\n";
607: }
1.1 albertel 608: # ------------------------------------------------------------------------ auth
609: } elsif ($userinput =~ /^auth/) {
610: if ($wasenc==1) {
611: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
612: chomp($upass);
1.11 www 613: $upass=unescape($upass);
1.1 albertel 614: my $proname=propath($udom,$uname);
615: my $passfilename="$proname/passwd";
616: if (-e $passfilename) {
617: my $pf = IO::File->new($passfilename);
618: my $realpasswd=<$pf>;
619: chomp($realpasswd);
1.2 www 620: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
621: my $pwdcorrect=0;
622: if ($howpwd eq 'internal') {
623: $pwdcorrect=
624: (crypt($upass,$contentpwd) eq $contentpwd);
625: } elsif ($howpwd eq 'unix') {
626: $contentpwd=(getpwnam($uname))[1];
1.52 harris41 627: my $pwauth_path="/usr/local/sbin/pwauth";
628: unless ($contentpwd eq 'x') {
629: $pwdcorrect=
630: (crypt($upass,$contentpwd) eq $contentpwd);
631: }
632: elsif (-e $pwauth_path) {
633: open PWAUTH, "|$pwauth_path" or
634: die "Cannot invoke authentication";
635: print PWAUTH "$uname\n$upass\n";
636: close PWAUTH;
637: $pwdcorrect=!$?;
638: }
1.3 www 639: } elsif ($howpwd eq 'krb4') {
640: $pwdcorrect=(
641: Authen::Krb4::get_pw_in_tkt($uname,"",
642: $contentpwd,'krbtgt',$contentpwd,1,
643: $upass) == 0);
1.50 albertel 644: } elsif ($howpwd eq 'localauth') {
1.49 albertel 645: $pwdcorrect=&localauth::localauth($uname,$upass,
646: $contentpwd);
647: }
1.2 www 648: if ($pwdcorrect) {
1.1 albertel 649: print $client "authorized\n";
650: } else {
651: print $client "non_authorized\n";
652: }
653: } else {
654: print $client "unknown_user\n";
655: }
656: } else {
657: print $client "refused\n";
658: }
659: # ---------------------------------------------------------------------- passwd
660: } elsif ($userinput =~ /^passwd/) {
661: if ($wasenc==1) {
662: my
663: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
664: chomp($npass);
1.32 www 665: $upass=&unescape($upass);
666: $npass=&unescape($npass);
1.1 albertel 667: my $proname=propath($udom,$uname);
668: my $passfilename="$proname/passwd";
669: if (-e $passfilename) {
670: my $realpasswd;
671: { my $pf = IO::File->new($passfilename);
672: $realpasswd=<$pf>; }
673: chomp($realpasswd);
1.2 www 674: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
675: if ($howpwd eq 'internal') {
676: if (crypt($upass,$contentpwd) eq $contentpwd) {
677: my $salt=time;
678: $salt=substr($salt,6,2);
679: my $ncpass=crypt($npass,$salt);
1.1 albertel 680: { my $pf = IO::File->new(">$passfilename");
1.31 www 681: print $pf "internal:$ncpass\n"; }
1.1 albertel 682: print $client "ok\n";
1.2 www 683: } else {
684: print $client "non_authorized\n";
685: }
1.1 albertel 686: } else {
1.2 www 687: print $client "auth_mode_error\n";
1.1 albertel 688: }
689: } else {
690: print $client "unknown_user\n";
1.31 www 691: }
692: } else {
693: print $client "refused\n";
694: }
695: # -------------------------------------------------------------------- makeuser
696: } elsif ($userinput =~ /^makeuser/) {
1.56 harris41 697: my $oldumask=umask(0077);
1.31 www 698: if ($wasenc==1) {
699: my
700: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
701: chomp($npass);
1.32 www 702: $npass=&unescape($npass);
1.31 www 703: my $proname=propath($udom,$uname);
704: my $passfilename="$proname/passwd";
705: if (-e $passfilename) {
706: print $client "already_exists\n";
707: } elsif ($udom ne $perlvar{'lonDefDomain'}) {
708: print $client "not_right_domain\n";
709: } else {
710: @fpparts=split(/\//,$proname);
711: $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
712: $fperror='';
713: for ($i=3;$i<=$#fpparts;$i++) {
714: $fpnow.='/'.$fpparts[$i];
715: unless (-e $fpnow) {
716: unless (mkdir($fpnow,0777)) {
1.65 www 717: $fperror="error:$!";
1.31 www 718: }
719: }
720: }
721: unless ($fperror) {
1.34 www 722: if ($umode eq 'krb4') {
1.31 www 723: {
724: my $pf = IO::File->new(">$passfilename");
1.33 www 725: print $pf "krb4:$npass\n";
1.31 www 726: }
727: print $client "ok\n";
728: } elsif ($umode eq 'internal') {
729: my $salt=time;
730: $salt=substr($salt,6,2);
731: my $ncpass=crypt($npass,$salt);
732: {
733: my $pf = IO::File->new(">$passfilename");
734: print $pf "internal:$ncpass\n";
1.50 albertel 735: }
1.31 www 736: print $client "ok\n";
1.50 albertel 737: } elsif ($umode eq 'localauth') {
738: {
739: my $pf = IO::File->new(">$passfilename");
740: print $pf "localauth:$npass\n";
741: }
742: print $client "ok\n";
1.53 harris41 743: } elsif ($umode eq 'unix') {
744: {
745: my $execpath="$perlvar{'lonDaemons'}/".
746: "lcuseradd";
1.54 harris41 747: {
748: my $se = IO::File->new("|$execpath");
749: print $se "$uname\n";
750: print $se "$npass\n";
751: print $se "$npass\n";
752: }
1.53 harris41 753: my $pf = IO::File->new(">$passfilename");
754: print $pf "unix:\n";
755: }
1.54 harris41 756: print $client "ok\n";
1.53 harris41 757: } elsif ($umode eq 'none') {
1.31 www 758: {
759: my $pf = IO::File->new(">$passfilename");
760: print $pf "none:\n";
761: }
762: print $client "ok\n";
763: } else {
764: print $client "auth_mode_error\n";
765: }
766: } else {
767: print $client "$fperror\n";
768: }
1.55 harris41 769: }
770: } else {
771: print $client "refused\n";
772: }
1.56 harris41 773: umask($oldumask);
1.55 harris41 774: # -------------------------------------------------------------- changeuserauth
775: } elsif ($userinput =~ /^changeuserauth/) {
776: if ($wasenc==1) {
777: my
778: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
779: chomp($npass);
780: $npass=&unescape($npass);
781: my $proname=propath($udom,$uname);
782: my $passfilename="$proname/passwd";
783: if ($udom ne $perlvar{'lonDefDomain'}) {
784: print $client "not_right_domain\n";
785: } else {
786: if ($umode eq 'krb4') {
787: {
788: my $pf = IO::File->new(">$passfilename");
789: print $pf "krb4:$npass\n";
790: }
791: print $client "ok\n";
792: } elsif ($umode eq 'internal') {
793: my $salt=time;
794: $salt=substr($salt,6,2);
795: my $ncpass=crypt($npass,$salt);
796: {
797: my $pf = IO::File->new(">$passfilename");
798: print $pf "internal:$ncpass\n";
799: }
800: print $client "ok\n";
801: } elsif ($umode eq 'localauth') {
802: {
803: my $pf = IO::File->new(">$passfilename");
804: print $pf "localauth:$npass\n";
805: }
806: print $client "ok\n";
807: } elsif ($umode eq 'unix') {
808: {
809: my $execpath="$perlvar{'lonDaemons'}/".
810: "lcuseradd";
811: {
812: my $se = IO::File->new("|$execpath");
813: print $se "$uname\n";
814: print $se "$npass\n";
815: print $se "$npass\n";
816: }
817: my $pf = IO::File->new(">$passfilename");
818: print $pf "unix:\n";
819: }
820: print $client "ok\n";
821: } elsif ($umode eq 'none') {
822: {
823: my $pf = IO::File->new(">$passfilename");
824: print $pf "none:\n";
825: }
826: print $client "ok\n";
827: } else {
828: print $client "auth_mode_error\n";
829: }
1.1 albertel 830: }
831: } else {
832: print $client "refused\n";
833: }
834: # ------------------------------------------------------------------------ home
835: } elsif ($userinput =~ /^home/) {
836: my ($cmd,$udom,$uname)=split(/:/,$userinput);
837: chomp($uname);
838: my $proname=propath($udom,$uname);
839: if (-e $proname) {
840: print $client "found\n";
841: } else {
842: print $client "not_found\n";
843: }
844: # ---------------------------------------------------------------------- update
845: } elsif ($userinput =~ /^update/) {
846: my ($cmd,$fname)=split(/:/,$userinput);
847: my $ownership=ishome($fname);
848: if ($ownership eq 'not_owner') {
849: if (-e $fname) {
850: my ($dev,$ino,$mode,$nlink,
851: $uid,$gid,$rdev,$size,
852: $atime,$mtime,$ctime,
853: $blksize,$blocks)=stat($fname);
854: $now=time;
855: $since=$now-$atime;
856: if ($since>$perlvar{'lonExpire'}) {
857: $reply=
858: reply("unsub:$fname","$hostid{$clientip}");
859: unlink("$fname");
860: } else {
861: my $transname="$fname.in.transfer";
862: my $remoteurl=
863: reply("sub:$fname","$hostid{$clientip}");
864: my $response;
865: {
866: my $ua=new LWP::UserAgent;
867: my $request=new HTTP::Request('GET',"$remoteurl");
868: $response=$ua->request($request,$transname);
869: }
870: if ($response->is_error()) {
1.24 albertel 871: unlink($transname);
1.1 albertel 872: my $message=$response->status_line;
873: &logthis(
874: "LWP GET: $message for $fname ($remoteurl)");
875: } else {
1.14 www 876: if ($remoteurl!~/\.meta$/) {
1.28 www 877: my $ua=new LWP::UserAgent;
1.14 www 878: my $mrequest=
879: new HTTP::Request('GET',$remoteurl.'.meta');
880: my $mresponse=
881: $ua->request($mrequest,$fname.'.meta');
882: if ($mresponse->is_error()) {
883: unlink($fname.'.meta');
884: }
885: }
1.1 albertel 886: rename($transname,$fname);
887: }
888: }
889: print $client "ok\n";
890: } else {
891: print $client "not_found\n";
892: }
893: } else {
894: print $client "rejected\n";
895: }
896: # ----------------------------------------------------------------- unsubscribe
897: } elsif ($userinput =~ /^unsub/) {
898: my ($cmd,$fname)=split(/:/,$userinput);
899: if (-e $fname) {
900: if (unlink("$fname.$hostid{$clientip}")) {
901: print $client "ok\n";
902: } else {
903: print $client "not_subscribed\n";
904: }
905: } else {
906: print $client "not_found\n";
907: }
908: # ------------------------------------------------------------------- subscribe
909: } elsif ($userinput =~ /^sub/) {
910: my ($cmd,$fname)=split(/:/,$userinput);
911: my $ownership=ishome($fname);
912: if ($ownership eq 'owner') {
913: if (-e $fname) {
1.18 www 914: if (-d $fname) {
915: print $client "directory\n";
916: } else {
1.1 albertel 917: $now=time;
918: {
1.26 www 919: my $sh;
1.25 www 920: if ($sh=
921: IO::File->new(">$fname.$hostid{$clientip}")) {
922: print $sh "$clientip:$now\n";
923: }
1.1 albertel 924: }
1.42 www 925: unless ($fname=~/\.meta$/) {
926: unlink("$fname.meta.$hostid{$clientip}");
927: }
1.1 albertel 928: $fname=~s/\/home\/httpd\/html\/res/raw/;
929: $fname="http://$thisserver/".$fname;
930: print $client "$fname\n";
1.18 www 931: }
1.1 albertel 932: } else {
933: print $client "not_found\n";
934: }
935: } else {
936: print $client "rejected\n";
937: }
1.12 harris41 938: # ------------------------------------------------------------------------- log
939: } elsif ($userinput =~ /^log/) {
940: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
941: chomp($what);
942: my $proname=propath($udom,$uname);
943: my $now=time;
944: {
945: my $hfh;
946: if ($hfh=IO::File->new(">>$proname/activity.log")) {
947: print $hfh "$now:$hostid{$clientip}:$what\n";
948: print $client "ok\n";
949: } else {
950: print $client "error:$!\n";
951: }
952: }
1.1 albertel 953: # ------------------------------------------------------------------------- put
954: } elsif ($userinput =~ /^put/) {
1.6 www 955: my ($cmd,$udom,$uname,$namespace,$what)
1.1 albertel 956: =split(/:/,$userinput);
1.8 www 957: $namespace=~s/\//\_/g;
1.6 www 958: $namespace=~s/\W//g;
959: if ($namespace ne 'roles') {
1.1 albertel 960: chomp($what);
961: my $proname=propath($udom,$uname);
962: my $now=time;
1.48 www 963: unless ($namespace=~/^nohist\_/) {
1.1 albertel 964: my $hfh;
965: if (
966: $hfh=IO::File->new(">>$proname/$namespace.hist")
967: ) { print $hfh "P:$now:$what\n"; }
968: }
969: my @pairs=split(/\&/,$what);
1.4 www 970: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 971: foreach $pair (@pairs) {
972: ($key,$value)=split(/=/,$pair);
973: $hash{$key}=$value;
974: }
1.4 www 975: if (untie(%hash)) {
1.1 albertel 976: print $client "ok\n";
977: } else {
978: print $client "error:$!\n";
979: }
980: } else {
981: print $client "error:$!\n";
982: }
1.6 www 983: } else {
984: print $client "refused\n";
985: }
986: # -------------------------------------------------------------------- rolesput
987: } elsif ($userinput =~ /^rolesput/) {
988: if ($wasenc==1) {
989: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
990: =split(/:/,$userinput);
991: my $namespace='roles';
992: chomp($what);
993: my $proname=propath($udom,$uname);
994: my $now=time;
995: {
996: my $hfh;
997: if (
998: $hfh=IO::File->new(">>$proname/$namespace.hist")
999: ) {
1000: print $hfh "P:$now:$exedom:$exeuser:$what\n";
1001: }
1002: }
1003: my @pairs=split(/\&/,$what);
1004: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1005: foreach $pair (@pairs) {
1006: ($key,$value)=split(/=/,$pair);
1007: $hash{$key}=$value;
1008: }
1009: if (untie(%hash)) {
1010: print $client "ok\n";
1011: } else {
1012: print $client "error:$!\n";
1013: }
1014: } else {
1015: print $client "error:$!\n";
1016: }
1017: } else {
1018: print $client "refused\n";
1019: }
1.1 albertel 1020: # ------------------------------------------------------------------------- get
1021: } elsif ($userinput =~ /^get/) {
1022: my ($cmd,$udom,$uname,$namespace,$what)
1023: =split(/:/,$userinput);
1.8 www 1024: $namespace=~s/\//\_/g;
1.1 albertel 1025: $namespace=~s/\W//g;
1026: chomp($what);
1027: my @queries=split(/\&/,$what);
1028: my $proname=propath($udom,$uname);
1029: my $qresult='';
1.20 www 1030: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1031: for ($i=0;$i<=$#queries;$i++) {
1032: $qresult.="$hash{$queries[$i]}&";
1033: }
1.4 www 1034: if (untie(%hash)) {
1.1 albertel 1035: $qresult=~s/\&$//;
1036: print $client "$qresult\n";
1037: } else {
1038: print $client "error:$!\n";
1039: }
1040: } else {
1041: print $client "error:$!\n";
1042: }
1043: # ------------------------------------------------------------------------ eget
1044: } elsif ($userinput =~ /^eget/) {
1045: my ($cmd,$udom,$uname,$namespace,$what)
1046: =split(/:/,$userinput);
1.8 www 1047: $namespace=~s/\//\_/g;
1.1 albertel 1048: $namespace=~s/\W//g;
1049: chomp($what);
1050: my @queries=split(/\&/,$what);
1051: my $proname=propath($udom,$uname);
1052: my $qresult='';
1.20 www 1053: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1054: for ($i=0;$i<=$#queries;$i++) {
1055: $qresult.="$hash{$queries[$i]}&";
1056: }
1.4 www 1057: if (untie(%hash)) {
1.1 albertel 1058: $qresult=~s/\&$//;
1059: if ($cipher) {
1060: my $cmdlength=length($qresult);
1061: $qresult.=" ";
1062: my $encqresult='';
1063: for
1064: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1065: $encqresult.=
1066: unpack("H16",
1067: $cipher->encrypt(substr($qresult,$encidx,8)));
1068: }
1069: print $client "enc:$cmdlength:$encqresult\n";
1070: } else {
1071: print $client "error:no_key\n";
1072: }
1073: } else {
1074: print $client "error:$!\n";
1075: }
1076: } else {
1077: print $client "error:$!\n";
1078: }
1079: # ------------------------------------------------------------------------- del
1080: } elsif ($userinput =~ /^del/) {
1081: my ($cmd,$udom,$uname,$namespace,$what)
1082: =split(/:/,$userinput);
1.8 www 1083: $namespace=~s/\//\_/g;
1.1 albertel 1084: $namespace=~s/\W//g;
1085: chomp($what);
1086: my $proname=propath($udom,$uname);
1087: my $now=time;
1.48 www 1088: unless ($namespace=~/^nohist\_/) {
1.1 albertel 1089: my $hfh;
1090: if (
1091: $hfh=IO::File->new(">>$proname/$namespace.hist")
1092: ) { print $hfh "D:$now:$what\n"; }
1093: }
1094: my @keys=split(/\&/,$what);
1.4 www 1095: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 1096: foreach $key (@keys) {
1097: delete($hash{$key});
1098: }
1.4 www 1099: if (untie(%hash)) {
1.1 albertel 1100: print $client "ok\n";
1101: } else {
1102: print $client "error:$!\n";
1103: }
1104: } else {
1105: print $client "error:$!\n";
1106: }
1107: # ------------------------------------------------------------------------ keys
1108: } elsif ($userinput =~ /^keys/) {
1109: my ($cmd,$udom,$uname,$namespace)
1110: =split(/:/,$userinput);
1.8 www 1111: $namespace=~s/\//\_/g;
1.1 albertel 1112: $namespace=~s/\W//g;
1113: my $proname=propath($udom,$uname);
1114: my $qresult='';
1.20 www 1115: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1116: foreach $key (keys %hash) {
1117: $qresult.="$key&";
1118: }
1.4 www 1119: if (untie(%hash)) {
1.1 albertel 1120: $qresult=~s/\&$//;
1121: print $client "$qresult\n";
1122: } else {
1123: print $client "error:$!\n";
1124: }
1125: } else {
1126: print $client "error:$!\n";
1127: }
1128: # ------------------------------------------------------------------------ dump
1129: } elsif ($userinput =~ /^dump/) {
1.62 www 1130: my ($cmd,$udom,$uname,$namespace,$regexp)
1.1 albertel 1131: =split(/:/,$userinput);
1.8 www 1132: $namespace=~s/\//\_/g;
1.1 albertel 1133: $namespace=~s/\W//g;
1.62 www 1134: if (defined($regexp)) {
1135: $regexp=&unescape($regexp);
1136: } else {
1137: $regexp='.';
1138: }
1.1 albertel 1139: my $proname=propath($udom,$uname);
1140: my $qresult='';
1.20 www 1141: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1142: foreach $key (keys %hash) {
1.62 www 1143: if (eval('$key=~/$regexp/')) {
1144: $qresult.="$key=$hash{$key}&";
1145: }
1.7 www 1146: }
1147: if (untie(%hash)) {
1148: $qresult=~s/\&$//;
1149: print $client "$qresult\n";
1150: } else {
1151: print $client "error:$!\n";
1152: }
1153: } else {
1154: print $client "error:$!\n";
1155: }
1156: # ----------------------------------------------------------------------- store
1157: } elsif ($userinput =~ /^store/) {
1158: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1159: =split(/:/,$userinput);
1.8 www 1160: $namespace=~s/\//\_/g;
1.7 www 1161: $namespace=~s/\W//g;
1162: if ($namespace ne 'roles') {
1163: chomp($what);
1164: my $proname=propath($udom,$uname);
1165: my $now=time;
1.48 www 1166: unless ($namespace=~/^nohist\_/) {
1.7 www 1167: my $hfh;
1168: if (
1169: $hfh=IO::File->new(">>$proname/$namespace.hist")
1170: ) { print $hfh "P:$now:$rid:$what\n"; }
1171: }
1172: my @pairs=split(/\&/,$what);
1173:
1174: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1175: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1176: my $key;
1177: $hash{"version:$rid"}++;
1178: my $version=$hash{"version:$rid"};
1179: my $allkeys='';
1180: foreach $pair (@pairs) {
1181: ($key,$value)=split(/=/,$pair);
1182: $allkeys.=$key.':';
1183: $hash{"$version:$rid:$key"}=$value;
1184: }
1.36 www 1185: $hash{"$version:$rid:timestamp"}=$now;
1186: $allkeys.='timestamp';
1.7 www 1187: $hash{"$version:keys:$rid"}=$allkeys;
1188: if (untie(%hash)) {
1189: print $client "ok\n";
1190: } else {
1191: print $client "error:$!\n";
1192: }
1193: } else {
1194: print $client "error:$!\n";
1195: }
1196: } else {
1197: print $client "refused\n";
1198: }
1199: # --------------------------------------------------------------------- restore
1200: } elsif ($userinput =~ /^restore/) {
1201: my ($cmd,$udom,$uname,$namespace,$rid)
1202: =split(/:/,$userinput);
1.8 www 1203: $namespace=~s/\//\_/g;
1.7 www 1204: $namespace=~s/\W//g;
1205: chomp($rid);
1206: my $proname=propath($udom,$uname);
1207: my $qresult='';
1.20 www 1208: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.7 www 1209: my $version=$hash{"version:$rid"};
1210: $qresult.="version=$version&";
1211: my $scope;
1212: for ($scope=1;$scope<=$version;$scope++) {
1213: my $vkeys=$hash{"$scope:keys:$rid"};
1214: my @keys=split(/:/,$vkeys);
1215: my $key;
1216: $qresult.="$scope:keys=$vkeys&";
1217: foreach $key (@keys) {
1.21 www 1218: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1.7 www 1219: }
1.1 albertel 1220: }
1.4 www 1221: if (untie(%hash)) {
1.1 albertel 1222: $qresult=~s/\&$//;
1223: print $client "$qresult\n";
1224: } else {
1225: print $client "error:$!\n";
1226: }
1227: } else {
1228: print $client "error:$!\n";
1229: }
1.12 harris41 1230: # ------------------------------------------------------------------- querysend
1231: } elsif ($userinput =~ /^querysend/) {
1.44 harris41 1232: my ($cmd,$query,
1233: $custom,$customshow)=split(/:/,$userinput);
1.12 harris41 1234: $query=~s/\n*$//g;
1.45 harris41 1235: unless ($custom or $customshow) {
1.40 harris41 1236: print $client "".
1237: sqlreply("$hostid{$clientip}\&$query")."\n";
1238: }
1239: else {
1240: print $client "".
1241: sqlreply("$hostid{$clientip}\&$query".
1.44 harris41 1242: "\&$custom"."\&$customshow")."\n";
1.40 harris41 1243: }
1.12 harris41 1244: # ------------------------------------------------------------------ queryreply
1245: } elsif ($userinput =~ /^queryreply/) {
1246: my ($cmd,$id,$reply)=split(/:/,$userinput);
1247: my $store;
1.13 www 1248: my $execdir=$perlvar{'lonDaemons'};
1249: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1.43 harris41 1250: $reply=~s/\&/\n/g;
1.12 harris41 1251: print $store $reply;
1252: close $store;
1.46 harris41 1253: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1254: print $store2 "done\n";
1255: close $store2;
1.12 harris41 1256: print $client "ok\n";
1257: }
1258: else {
1259: print $client "error:$!\n";
1260: }
1.1 albertel 1261: # ----------------------------------------------------------------------- idput
1262: } elsif ($userinput =~ /^idput/) {
1263: my ($cmd,$udom,$what)=split(/:/,$userinput);
1264: chomp($what);
1265: $udom=~s/\W//g;
1266: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1267: my $now=time;
1268: {
1269: my $hfh;
1270: if (
1271: $hfh=IO::File->new(">>$proname.hist")
1272: ) { print $hfh "P:$now:$what\n"; }
1273: }
1274: my @pairs=split(/\&/,$what);
1.4 www 1275: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 1276: foreach $pair (@pairs) {
1277: ($key,$value)=split(/=/,$pair);
1278: $hash{$key}=$value;
1279: }
1.4 www 1280: if (untie(%hash)) {
1.1 albertel 1281: print $client "ok\n";
1282: } else {
1283: print $client "error:$!\n";
1284: }
1285: } else {
1286: print $client "error:$!\n";
1287: }
1288: # ----------------------------------------------------------------------- idget
1289: } elsif ($userinput =~ /^idget/) {
1290: my ($cmd,$udom,$what)=split(/:/,$userinput);
1291: chomp($what);
1292: $udom=~s/\W//g;
1293: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1294: my @queries=split(/\&/,$what);
1295: my $qresult='';
1.20 www 1296: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
1.1 albertel 1297: for ($i=0;$i<=$#queries;$i++) {
1298: $qresult.="$hash{$queries[$i]}&";
1299: }
1.4 www 1300: if (untie(%hash)) {
1.1 albertel 1301: $qresult=~s/\&$//;
1302: print $client "$qresult\n";
1303: } else {
1304: print $client "error:$!\n";
1305: }
1306: } else {
1307: print $client "error:$!\n";
1308: }
1.13 www 1309: # ---------------------------------------------------------------------- tmpput
1310: } elsif ($userinput =~ /^tmpput/) {
1311: my ($cmd,$what)=split(/:/,$userinput);
1312: my $store;
1313: $tmpsnum++;
1314: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1315: $id=~s/\W/\_/g;
1316: $what=~s/\n//g;
1317: my $execdir=$perlvar{'lonDaemons'};
1318: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1319: print $store $what;
1320: close $store;
1321: print $client "$id\n";
1322: }
1323: else {
1324: print $client "error:$!\n";
1325: }
1326:
1327: # ---------------------------------------------------------------------- tmpget
1328: } elsif ($userinput =~ /^tmpget/) {
1329: my ($cmd,$id)=split(/:/,$userinput);
1330: chomp($id);
1331: $id=~s/\W/\_/g;
1332: my $store;
1333: my $execdir=$perlvar{'lonDaemons'};
1334: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
1335: my $reply=<$store>;
1336: print $client "$reply\n";
1337: close $store;
1338: }
1339: else {
1340: print $client "error:$!\n";
1341: }
1342:
1.5 www 1343: # -------------------------------------------------------------------------- ls
1344: } elsif ($userinput =~ /^ls/) {
1345: my ($cmd,$ulsdir)=split(/:/,$userinput);
1346: my $ulsout='';
1347: my $ulsfn;
1348: if (-e $ulsdir) {
1.41 www 1349: if (opendir(LSDIR,$ulsdir)) {
1350: while ($ulsfn=readdir(LSDIR)) {
1.47 www 1351: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1.5 www 1352: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1353: }
1.41 www 1354: closedir(LSDIR);
1355: }
1.5 www 1356: } else {
1357: $ulsout='no_such_dir';
1358: }
1.17 www 1359: if ($ulsout eq '') { $ulsout='empty'; }
1.5 www 1360: print $client "$ulsout\n";
1.51 www 1361: # ------------------------------------------------------------------ Hanging up
1362: } elsif (($userinput =~ /^exit/) ||
1363: ($userinput =~ /^init/)) {
1364: &logthis(
1365: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1366: print $client "bye\n";
1.59 www 1367: $client->close();
1.51 www 1368: last;
1.1 albertel 1369: # ------------------------------------------------------------- unknown command
1370: } else {
1371: # unknown command
1372: print $client "unknown_cmd\n";
1373: }
1.58 www 1374: # -------------------------------------------------------------------- complete
1.63 www 1375: alarm(0);
1.58 www 1376: &status('Listening to '.$hostid{$clientip});
1377: }
1.59 www 1378: # --------------------------------------------- client unknown or fishy, refuse
1.1 albertel 1379: } else {
1380: print $client "refused\n";
1.59 www 1381: $client->close();
1.9 www 1382: &logthis("<font color=blue>WARNING: "
1383: ."Rejected client $clientip, closing connection</font>");
1.1 albertel 1384: }
1.9 www 1385: &logthis("<font color=red>CRITICAL: "
1.10 www 1386: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1.1 albertel 1387: # =============================================================================
1388: }
1389:
1390: # tidy up gracefully and finish
1391:
1.59 www 1392: $client->close();
1393: $server->close();
1394:
1.1 albertel 1395: # this exit is VERY important, otherwise the child will become
1396: # a producer of more and more children, forking yourself into
1397: # process death.
1398: exit;
1399: }
1400: }
1401:
1.61 harris41 1402: # ----------------------------------- POD (plain old documentation, CPAN style)
1403:
1404: =head1 NAME
1405:
1406: lond - "LON Daemon" Server (port "LOND" 5663)
1407:
1408: =head1 SYNOPSIS
1409:
1410: Should only be run as user=www. Invoked by loncron.
1411:
1412: =head1 DESCRIPTION
1413:
1414: Preforker - server who forks first. Runs as a daemon. HUPs.
1415: Uses IDEA encryption
1416:
1417: =head1 README
1418:
1419: Not yet written.
1420:
1421: =head1 PREREQUISITES
1422:
1423: IO::Socket
1424: IO::File
1425: Apache::File
1426: Symbol
1427: POSIX
1428: Crypt::IDEA
1429: LWP::UserAgent()
1430: GDBM_File
1431: Authen::Krb4
1432:
1433: =head1 COREQUISITES
1434:
1435: =head1 OSNAMES
1436:
1437: linux
1438:
1439: =head1 SCRIPT CATEGORIES
1440:
1441: Server/Process
1442:
1443: =cut
1.1 albertel 1444:
1445:
1446:
1447:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom