Annotation of loncom/lond, revision 1.68.2.1
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.68 albertel 5: # $Id: lond,v 1.67 2002/02/06 13:34:21 albertel 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 $_";
1.68 albertel 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.68.2.1! albertel 537: &logthis('Processing '.$hostid{$clientip}.': '.$userinput);
1.1 albertel 538: my $wasenc=0;
1.63 www 539: alarm(120);
1.1 albertel 540: # ------------------------------------------------------------ See if encrypted
541: if ($userinput =~ /^enc/) {
542: if ($cipher) {
543: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
544: $userinput='';
545: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
546: $userinput.=
547: $cipher->decrypt(
548: pack("H16",substr($encinput,$encidx,16))
549: );
550: }
551: $userinput=substr($userinput,0,$cmdlength);
552: $wasenc=1;
553: }
1.68.2.1! albertel 554: &logthis('Decrypted '.$hostid{$clientip}.': '.$userinput);
! 555: }
! 556:
1.1 albertel 557: # ------------------------------------------------------------- Normal commands
558: # ------------------------------------------------------------------------ ping
559: if ($userinput =~ /^ping/) {
560: print $client "$perlvar{'lonHostID'}\n";
561: # ------------------------------------------------------------------------ pong
562: } elsif ($userinput =~ /^pong/) {
563: $reply=reply("ping",$hostid{$clientip});
564: print $client "$perlvar{'lonHostID'}:$reply\n";
565: # ------------------------------------------------------------------------ ekey
566: } elsif ($userinput =~ /^ekey/) {
567: my $buildkey=time.$$.int(rand 100000);
568: $buildkey=~tr/1-6/A-F/;
569: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
570: my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
571: $key=~tr/a-z/A-Z/;
572: $key=~tr/G-P/0-9/;
573: $key=~tr/Q-Z/0-9/;
574: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
575: $key=substr($key,0,32);
576: my $cipherkey=pack("H32",$key);
577: $cipher=new IDEA $cipherkey;
578: print $client "$buildkey\n";
579: # ------------------------------------------------------------------------ load
580: } elsif ($userinput =~ /^load/) {
581: my $loadavg;
582: {
583: my $loadfile=IO::File->new('/proc/loadavg');
584: $loadavg=<$loadfile>;
585: }
586: $loadavg =~ s/\s.*//g;
587: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
588: print $client "$loadpercent\n";
1.54 harris41 589: # ----------------------------------------------------------------- currentauth
590: } elsif ($userinput =~ /^currentauth/) {
591: if ($wasenc==1) {
592: my ($cmd,$udom,$uname)=split(/:/,$userinput);
593: my $proname=propath($udom,$uname);
594: my $passfilename="$proname/passwd";
595: if (-e $passfilename) {
596: my $pf = IO::File->new($passfilename);
597: my $realpasswd=<$pf>;
598: chomp($realpasswd);
599: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
600: my $availablecontent='';
601: if ($howpwd eq 'krb4') {
602: $availablecontent=$contentpwd;
603: }
604: print $client "$howpwd:$availablecontent\n";
605: } else {
606: print $client "unknown_user\n";
607: }
608: } else {
609: print $client "refused\n";
610: }
1.1 albertel 611: # ------------------------------------------------------------------------ auth
612: } elsif ($userinput =~ /^auth/) {
613: if ($wasenc==1) {
614: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
615: chomp($upass);
1.11 www 616: $upass=unescape($upass);
1.1 albertel 617: my $proname=propath($udom,$uname);
618: my $passfilename="$proname/passwd";
619: if (-e $passfilename) {
620: my $pf = IO::File->new($passfilename);
621: my $realpasswd=<$pf>;
622: chomp($realpasswd);
1.2 www 623: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
624: my $pwdcorrect=0;
625: if ($howpwd eq 'internal') {
626: $pwdcorrect=
627: (crypt($upass,$contentpwd) eq $contentpwd);
628: } elsif ($howpwd eq 'unix') {
629: $contentpwd=(getpwnam($uname))[1];
1.52 harris41 630: my $pwauth_path="/usr/local/sbin/pwauth";
631: unless ($contentpwd eq 'x') {
632: $pwdcorrect=
633: (crypt($upass,$contentpwd) eq $contentpwd);
634: }
635: elsif (-e $pwauth_path) {
636: open PWAUTH, "|$pwauth_path" or
637: die "Cannot invoke authentication";
638: print PWAUTH "$uname\n$upass\n";
639: close PWAUTH;
640: $pwdcorrect=!$?;
641: }
1.3 www 642: } elsif ($howpwd eq 'krb4') {
643: $pwdcorrect=(
644: Authen::Krb4::get_pw_in_tkt($uname,"",
645: $contentpwd,'krbtgt',$contentpwd,1,
646: $upass) == 0);
1.50 albertel 647: } elsif ($howpwd eq 'localauth') {
1.49 albertel 648: $pwdcorrect=&localauth::localauth($uname,$upass,
649: $contentpwd);
650: }
1.2 www 651: if ($pwdcorrect) {
1.1 albertel 652: print $client "authorized\n";
653: } else {
654: print $client "non_authorized\n";
655: }
656: } else {
657: print $client "unknown_user\n";
658: }
659: } else {
660: print $client "refused\n";
661: }
662: # ---------------------------------------------------------------------- passwd
663: } elsif ($userinput =~ /^passwd/) {
664: if ($wasenc==1) {
665: my
666: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
667: chomp($npass);
1.32 www 668: $upass=&unescape($upass);
669: $npass=&unescape($npass);
1.1 albertel 670: my $proname=propath($udom,$uname);
671: my $passfilename="$proname/passwd";
672: if (-e $passfilename) {
673: my $realpasswd;
674: { my $pf = IO::File->new($passfilename);
675: $realpasswd=<$pf>; }
676: chomp($realpasswd);
1.2 www 677: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
678: if ($howpwd eq 'internal') {
679: if (crypt($upass,$contentpwd) eq $contentpwd) {
680: my $salt=time;
681: $salt=substr($salt,6,2);
682: my $ncpass=crypt($npass,$salt);
1.1 albertel 683: { my $pf = IO::File->new(">$passfilename");
1.31 www 684: print $pf "internal:$ncpass\n"; }
1.1 albertel 685: print $client "ok\n";
1.2 www 686: } else {
687: print $client "non_authorized\n";
688: }
1.1 albertel 689: } else {
1.2 www 690: print $client "auth_mode_error\n";
1.1 albertel 691: }
692: } else {
693: print $client "unknown_user\n";
1.31 www 694: }
695: } else {
696: print $client "refused\n";
697: }
698: # -------------------------------------------------------------------- makeuser
699: } elsif ($userinput =~ /^makeuser/) {
1.56 harris41 700: my $oldumask=umask(0077);
1.31 www 701: if ($wasenc==1) {
702: my
703: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
704: chomp($npass);
1.32 www 705: $npass=&unescape($npass);
1.31 www 706: my $proname=propath($udom,$uname);
707: my $passfilename="$proname/passwd";
708: if (-e $passfilename) {
709: print $client "already_exists\n";
710: } elsif ($udom ne $perlvar{'lonDefDomain'}) {
711: print $client "not_right_domain\n";
712: } else {
713: @fpparts=split(/\//,$proname);
714: $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
715: $fperror='';
716: for ($i=3;$i<=$#fpparts;$i++) {
717: $fpnow.='/'.$fpparts[$i];
718: unless (-e $fpnow) {
719: unless (mkdir($fpnow,0777)) {
1.65 www 720: $fperror="error:$!";
1.31 www 721: }
722: }
723: }
724: unless ($fperror) {
1.34 www 725: if ($umode eq 'krb4') {
1.31 www 726: {
727: my $pf = IO::File->new(">$passfilename");
1.33 www 728: print $pf "krb4:$npass\n";
1.31 www 729: }
730: print $client "ok\n";
731: } elsif ($umode eq 'internal') {
732: my $salt=time;
733: $salt=substr($salt,6,2);
734: my $ncpass=crypt($npass,$salt);
735: {
736: my $pf = IO::File->new(">$passfilename");
737: print $pf "internal:$ncpass\n";
1.50 albertel 738: }
1.31 www 739: print $client "ok\n";
1.50 albertel 740: } elsif ($umode eq 'localauth') {
741: {
742: my $pf = IO::File->new(">$passfilename");
743: print $pf "localauth:$npass\n";
744: }
745: print $client "ok\n";
1.53 harris41 746: } elsif ($umode eq 'unix') {
747: {
748: my $execpath="$perlvar{'lonDaemons'}/".
749: "lcuseradd";
1.54 harris41 750: {
751: my $se = IO::File->new("|$execpath");
752: print $se "$uname\n";
753: print $se "$npass\n";
754: print $se "$npass\n";
755: }
1.53 harris41 756: my $pf = IO::File->new(">$passfilename");
757: print $pf "unix:\n";
758: }
1.54 harris41 759: print $client "ok\n";
1.53 harris41 760: } elsif ($umode eq 'none') {
1.31 www 761: {
762: my $pf = IO::File->new(">$passfilename");
763: print $pf "none:\n";
764: }
765: print $client "ok\n";
766: } else {
767: print $client "auth_mode_error\n";
768: }
769: } else {
770: print $client "$fperror\n";
771: }
1.55 harris41 772: }
773: } else {
774: print $client "refused\n";
775: }
1.56 harris41 776: umask($oldumask);
1.55 harris41 777: # -------------------------------------------------------------- changeuserauth
778: } elsif ($userinput =~ /^changeuserauth/) {
779: if ($wasenc==1) {
780: my
781: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
782: chomp($npass);
783: $npass=&unescape($npass);
784: my $proname=propath($udom,$uname);
785: my $passfilename="$proname/passwd";
786: if ($udom ne $perlvar{'lonDefDomain'}) {
787: print $client "not_right_domain\n";
788: } else {
789: if ($umode eq 'krb4') {
790: {
791: my $pf = IO::File->new(">$passfilename");
792: print $pf "krb4:$npass\n";
793: }
794: print $client "ok\n";
795: } elsif ($umode eq 'internal') {
796: my $salt=time;
797: $salt=substr($salt,6,2);
798: my $ncpass=crypt($npass,$salt);
799: {
800: my $pf = IO::File->new(">$passfilename");
801: print $pf "internal:$ncpass\n";
802: }
803: print $client "ok\n";
804: } elsif ($umode eq 'localauth') {
805: {
806: my $pf = IO::File->new(">$passfilename");
807: print $pf "localauth:$npass\n";
808: }
809: print $client "ok\n";
810: } elsif ($umode eq 'unix') {
811: {
812: my $execpath="$perlvar{'lonDaemons'}/".
813: "lcuseradd";
814: {
815: my $se = IO::File->new("|$execpath");
816: print $se "$uname\n";
817: print $se "$npass\n";
818: print $se "$npass\n";
819: }
820: my $pf = IO::File->new(">$passfilename");
821: print $pf "unix:\n";
822: }
823: print $client "ok\n";
824: } elsif ($umode eq 'none') {
825: {
826: my $pf = IO::File->new(">$passfilename");
827: print $pf "none:\n";
828: }
829: print $client "ok\n";
830: } else {
831: print $client "auth_mode_error\n";
832: }
1.1 albertel 833: }
834: } else {
835: print $client "refused\n";
836: }
837: # ------------------------------------------------------------------------ home
838: } elsif ($userinput =~ /^home/) {
839: my ($cmd,$udom,$uname)=split(/:/,$userinput);
840: chomp($uname);
841: my $proname=propath($udom,$uname);
842: if (-e $proname) {
843: print $client "found\n";
844: } else {
845: print $client "not_found\n";
846: }
847: # ---------------------------------------------------------------------- update
848: } elsif ($userinput =~ /^update/) {
849: my ($cmd,$fname)=split(/:/,$userinput);
850: my $ownership=ishome($fname);
851: if ($ownership eq 'not_owner') {
852: if (-e $fname) {
853: my ($dev,$ino,$mode,$nlink,
854: $uid,$gid,$rdev,$size,
855: $atime,$mtime,$ctime,
856: $blksize,$blocks)=stat($fname);
857: $now=time;
858: $since=$now-$atime;
859: if ($since>$perlvar{'lonExpire'}) {
860: $reply=
861: reply("unsub:$fname","$hostid{$clientip}");
862: unlink("$fname");
863: } else {
864: my $transname="$fname.in.transfer";
865: my $remoteurl=
866: reply("sub:$fname","$hostid{$clientip}");
867: my $response;
868: {
869: my $ua=new LWP::UserAgent;
870: my $request=new HTTP::Request('GET',"$remoteurl");
871: $response=$ua->request($request,$transname);
872: }
873: if ($response->is_error()) {
1.24 albertel 874: unlink($transname);
1.1 albertel 875: my $message=$response->status_line;
876: &logthis(
877: "LWP GET: $message for $fname ($remoteurl)");
878: } else {
1.14 www 879: if ($remoteurl!~/\.meta$/) {
1.28 www 880: my $ua=new LWP::UserAgent;
1.14 www 881: my $mrequest=
882: new HTTP::Request('GET',$remoteurl.'.meta');
883: my $mresponse=
884: $ua->request($mrequest,$fname.'.meta');
885: if ($mresponse->is_error()) {
886: unlink($fname.'.meta');
887: }
888: }
1.1 albertel 889: rename($transname,$fname);
890: }
891: }
892: print $client "ok\n";
893: } else {
894: print $client "not_found\n";
895: }
896: } else {
897: print $client "rejected\n";
898: }
899: # ----------------------------------------------------------------- unsubscribe
900: } elsif ($userinput =~ /^unsub/) {
901: my ($cmd,$fname)=split(/:/,$userinput);
902: if (-e $fname) {
903: if (unlink("$fname.$hostid{$clientip}")) {
904: print $client "ok\n";
905: } else {
906: print $client "not_subscribed\n";
907: }
908: } else {
909: print $client "not_found\n";
910: }
911: # ------------------------------------------------------------------- subscribe
912: } elsif ($userinput =~ /^sub/) {
913: my ($cmd,$fname)=split(/:/,$userinput);
914: my $ownership=ishome($fname);
915: if ($ownership eq 'owner') {
916: if (-e $fname) {
1.18 www 917: if (-d $fname) {
918: print $client "directory\n";
919: } else {
1.1 albertel 920: $now=time;
921: {
1.26 www 922: my $sh;
1.25 www 923: if ($sh=
924: IO::File->new(">$fname.$hostid{$clientip}")) {
925: print $sh "$clientip:$now\n";
926: }
1.1 albertel 927: }
1.42 www 928: unless ($fname=~/\.meta$/) {
929: unlink("$fname.meta.$hostid{$clientip}");
930: }
1.1 albertel 931: $fname=~s/\/home\/httpd\/html\/res/raw/;
932: $fname="http://$thisserver/".$fname;
933: print $client "$fname\n";
1.18 www 934: }
1.1 albertel 935: } else {
936: print $client "not_found\n";
937: }
938: } else {
939: print $client "rejected\n";
940: }
1.12 harris41 941: # ------------------------------------------------------------------------- log
942: } elsif ($userinput =~ /^log/) {
943: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
944: chomp($what);
945: my $proname=propath($udom,$uname);
946: my $now=time;
947: {
948: my $hfh;
949: if ($hfh=IO::File->new(">>$proname/activity.log")) {
950: print $hfh "$now:$hostid{$clientip}:$what\n";
951: print $client "ok\n";
952: } else {
953: print $client "error:$!\n";
954: }
955: }
1.1 albertel 956: # ------------------------------------------------------------------------- put
957: } elsif ($userinput =~ /^put/) {
1.6 www 958: my ($cmd,$udom,$uname,$namespace,$what)
1.1 albertel 959: =split(/:/,$userinput);
1.8 www 960: $namespace=~s/\//\_/g;
1.6 www 961: $namespace=~s/\W//g;
962: if ($namespace ne 'roles') {
1.1 albertel 963: chomp($what);
964: my $proname=propath($udom,$uname);
965: my $now=time;
1.48 www 966: unless ($namespace=~/^nohist\_/) {
1.1 albertel 967: my $hfh;
968: if (
969: $hfh=IO::File->new(">>$proname/$namespace.hist")
970: ) { print $hfh "P:$now:$what\n"; }
971: }
972: my @pairs=split(/\&/,$what);
1.4 www 973: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 974: foreach $pair (@pairs) {
975: ($key,$value)=split(/=/,$pair);
976: $hash{$key}=$value;
977: }
1.4 www 978: if (untie(%hash)) {
1.1 albertel 979: print $client "ok\n";
980: } else {
981: print $client "error:$!\n";
982: }
983: } else {
984: print $client "error:$!\n";
985: }
1.6 www 986: } else {
987: print $client "refused\n";
988: }
989: # -------------------------------------------------------------------- rolesput
990: } elsif ($userinput =~ /^rolesput/) {
991: if ($wasenc==1) {
992: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
993: =split(/:/,$userinput);
994: my $namespace='roles';
995: chomp($what);
996: my $proname=propath($udom,$uname);
997: my $now=time;
998: {
999: my $hfh;
1000: if (
1001: $hfh=IO::File->new(">>$proname/$namespace.hist")
1002: ) {
1003: print $hfh "P:$now:$exedom:$exeuser:$what\n";
1004: }
1005: }
1006: my @pairs=split(/\&/,$what);
1007: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1008: foreach $pair (@pairs) {
1009: ($key,$value)=split(/=/,$pair);
1010: $hash{$key}=$value;
1011: }
1012: if (untie(%hash)) {
1013: print $client "ok\n";
1014: } else {
1015: print $client "error:$!\n";
1016: }
1017: } else {
1018: print $client "error:$!\n";
1019: }
1020: } else {
1021: print $client "refused\n";
1022: }
1.1 albertel 1023: # ------------------------------------------------------------------------- get
1024: } elsif ($userinput =~ /^get/) {
1025: my ($cmd,$udom,$uname,$namespace,$what)
1026: =split(/:/,$userinput);
1.8 www 1027: $namespace=~s/\//\_/g;
1.1 albertel 1028: $namespace=~s/\W//g;
1029: chomp($what);
1030: my @queries=split(/\&/,$what);
1031: my $proname=propath($udom,$uname);
1032: my $qresult='';
1.20 www 1033: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1034: for ($i=0;$i<=$#queries;$i++) {
1035: $qresult.="$hash{$queries[$i]}&";
1036: }
1.4 www 1037: if (untie(%hash)) {
1.1 albertel 1038: $qresult=~s/\&$//;
1039: print $client "$qresult\n";
1040: } else {
1041: print $client "error:$!\n";
1042: }
1043: } else {
1044: print $client "error:$!\n";
1045: }
1046: # ------------------------------------------------------------------------ eget
1047: } elsif ($userinput =~ /^eget/) {
1048: my ($cmd,$udom,$uname,$namespace,$what)
1049: =split(/:/,$userinput);
1.8 www 1050: $namespace=~s/\//\_/g;
1.1 albertel 1051: $namespace=~s/\W//g;
1052: chomp($what);
1053: my @queries=split(/\&/,$what);
1054: my $proname=propath($udom,$uname);
1055: my $qresult='';
1.20 www 1056: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1057: for ($i=0;$i<=$#queries;$i++) {
1058: $qresult.="$hash{$queries[$i]}&";
1059: }
1.4 www 1060: if (untie(%hash)) {
1.1 albertel 1061: $qresult=~s/\&$//;
1062: if ($cipher) {
1063: my $cmdlength=length($qresult);
1064: $qresult.=" ";
1065: my $encqresult='';
1066: for
1067: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1068: $encqresult.=
1069: unpack("H16",
1070: $cipher->encrypt(substr($qresult,$encidx,8)));
1071: }
1072: print $client "enc:$cmdlength:$encqresult\n";
1073: } else {
1074: print $client "error:no_key\n";
1075: }
1076: } else {
1077: print $client "error:$!\n";
1078: }
1079: } else {
1080: print $client "error:$!\n";
1081: }
1082: # ------------------------------------------------------------------------- del
1083: } elsif ($userinput =~ /^del/) {
1084: my ($cmd,$udom,$uname,$namespace,$what)
1085: =split(/:/,$userinput);
1.8 www 1086: $namespace=~s/\//\_/g;
1.1 albertel 1087: $namespace=~s/\W//g;
1088: chomp($what);
1089: my $proname=propath($udom,$uname);
1090: my $now=time;
1.48 www 1091: unless ($namespace=~/^nohist\_/) {
1.1 albertel 1092: my $hfh;
1093: if (
1094: $hfh=IO::File->new(">>$proname/$namespace.hist")
1095: ) { print $hfh "D:$now:$what\n"; }
1096: }
1097: my @keys=split(/\&/,$what);
1.4 www 1098: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 1099: foreach $key (@keys) {
1100: delete($hash{$key});
1101: }
1.4 www 1102: if (untie(%hash)) {
1.1 albertel 1103: print $client "ok\n";
1104: } else {
1105: print $client "error:$!\n";
1106: }
1107: } else {
1108: print $client "error:$!\n";
1109: }
1110: # ------------------------------------------------------------------------ keys
1111: } elsif ($userinput =~ /^keys/) {
1112: my ($cmd,$udom,$uname,$namespace)
1113: =split(/:/,$userinput);
1.8 www 1114: $namespace=~s/\//\_/g;
1.1 albertel 1115: $namespace=~s/\W//g;
1116: my $proname=propath($udom,$uname);
1117: my $qresult='';
1.20 www 1118: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1119: foreach $key (keys %hash) {
1120: $qresult.="$key&";
1121: }
1.4 www 1122: if (untie(%hash)) {
1.1 albertel 1123: $qresult=~s/\&$//;
1124: print $client "$qresult\n";
1125: } else {
1126: print $client "error:$!\n";
1127: }
1128: } else {
1129: print $client "error:$!\n";
1130: }
1131: # ------------------------------------------------------------------------ dump
1132: } elsif ($userinput =~ /^dump/) {
1.62 www 1133: my ($cmd,$udom,$uname,$namespace,$regexp)
1.1 albertel 1134: =split(/:/,$userinput);
1.8 www 1135: $namespace=~s/\//\_/g;
1.1 albertel 1136: $namespace=~s/\W//g;
1.62 www 1137: if (defined($regexp)) {
1138: $regexp=&unescape($regexp);
1139: } else {
1140: $regexp='.';
1141: }
1.1 albertel 1142: my $proname=propath($udom,$uname);
1143: my $qresult='';
1.20 www 1144: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1145: foreach $key (keys %hash) {
1.62 www 1146: if (eval('$key=~/$regexp/')) {
1147: $qresult.="$key=$hash{$key}&";
1148: }
1.7 www 1149: }
1150: if (untie(%hash)) {
1151: $qresult=~s/\&$//;
1152: print $client "$qresult\n";
1153: } else {
1154: print $client "error:$!\n";
1155: }
1156: } else {
1157: print $client "error:$!\n";
1158: }
1159: # ----------------------------------------------------------------------- store
1160: } elsif ($userinput =~ /^store/) {
1161: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1162: =split(/:/,$userinput);
1.8 www 1163: $namespace=~s/\//\_/g;
1.7 www 1164: $namespace=~s/\W//g;
1165: if ($namespace ne 'roles') {
1166: chomp($what);
1167: my $proname=propath($udom,$uname);
1168: my $now=time;
1.48 www 1169: unless ($namespace=~/^nohist\_/) {
1.7 www 1170: my $hfh;
1171: if (
1172: $hfh=IO::File->new(">>$proname/$namespace.hist")
1173: ) { print $hfh "P:$now:$rid:$what\n"; }
1174: }
1175: my @pairs=split(/\&/,$what);
1176:
1177: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1178: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1179: my $key;
1180: $hash{"version:$rid"}++;
1181: my $version=$hash{"version:$rid"};
1182: my $allkeys='';
1183: foreach $pair (@pairs) {
1184: ($key,$value)=split(/=/,$pair);
1185: $allkeys.=$key.':';
1186: $hash{"$version:$rid:$key"}=$value;
1187: }
1.36 www 1188: $hash{"$version:$rid:timestamp"}=$now;
1189: $allkeys.='timestamp';
1.7 www 1190: $hash{"$version:keys:$rid"}=$allkeys;
1191: if (untie(%hash)) {
1192: print $client "ok\n";
1193: } else {
1194: print $client "error:$!\n";
1195: }
1196: } else {
1197: print $client "error:$!\n";
1198: }
1199: } else {
1200: print $client "refused\n";
1201: }
1202: # --------------------------------------------------------------------- restore
1203: } elsif ($userinput =~ /^restore/) {
1204: my ($cmd,$udom,$uname,$namespace,$rid)
1205: =split(/:/,$userinput);
1.8 www 1206: $namespace=~s/\//\_/g;
1.7 www 1207: $namespace=~s/\W//g;
1208: chomp($rid);
1209: my $proname=propath($udom,$uname);
1210: my $qresult='';
1.20 www 1211: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.7 www 1212: my $version=$hash{"version:$rid"};
1213: $qresult.="version=$version&";
1214: my $scope;
1215: for ($scope=1;$scope<=$version;$scope++) {
1216: my $vkeys=$hash{"$scope:keys:$rid"};
1217: my @keys=split(/:/,$vkeys);
1218: my $key;
1219: $qresult.="$scope:keys=$vkeys&";
1220: foreach $key (@keys) {
1.21 www 1221: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1.7 www 1222: }
1.1 albertel 1223: }
1.4 www 1224: if (untie(%hash)) {
1.1 albertel 1225: $qresult=~s/\&$//;
1226: print $client "$qresult\n";
1227: } else {
1228: print $client "error:$!\n";
1229: }
1230: } else {
1231: print $client "error:$!\n";
1232: }
1.12 harris41 1233: # ------------------------------------------------------------------- querysend
1234: } elsif ($userinput =~ /^querysend/) {
1.44 harris41 1235: my ($cmd,$query,
1236: $custom,$customshow)=split(/:/,$userinput);
1.12 harris41 1237: $query=~s/\n*$//g;
1.45 harris41 1238: unless ($custom or $customshow) {
1.40 harris41 1239: print $client "".
1240: sqlreply("$hostid{$clientip}\&$query")."\n";
1241: }
1242: else {
1243: print $client "".
1244: sqlreply("$hostid{$clientip}\&$query".
1.44 harris41 1245: "\&$custom"."\&$customshow")."\n";
1.40 harris41 1246: }
1.12 harris41 1247: # ------------------------------------------------------------------ queryreply
1248: } elsif ($userinput =~ /^queryreply/) {
1249: my ($cmd,$id,$reply)=split(/:/,$userinput);
1250: my $store;
1.13 www 1251: my $execdir=$perlvar{'lonDaemons'};
1252: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1.43 harris41 1253: $reply=~s/\&/\n/g;
1.12 harris41 1254: print $store $reply;
1255: close $store;
1.46 harris41 1256: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1257: print $store2 "done\n";
1258: close $store2;
1.12 harris41 1259: print $client "ok\n";
1260: }
1261: else {
1262: print $client "error:$!\n";
1263: }
1.1 albertel 1264: # ----------------------------------------------------------------------- idput
1265: } elsif ($userinput =~ /^idput/) {
1266: my ($cmd,$udom,$what)=split(/:/,$userinput);
1267: chomp($what);
1268: $udom=~s/\W//g;
1269: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1270: my $now=time;
1271: {
1272: my $hfh;
1273: if (
1274: $hfh=IO::File->new(">>$proname.hist")
1275: ) { print $hfh "P:$now:$what\n"; }
1276: }
1277: my @pairs=split(/\&/,$what);
1.4 www 1278: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 1279: foreach $pair (@pairs) {
1280: ($key,$value)=split(/=/,$pair);
1281: $hash{$key}=$value;
1282: }
1.4 www 1283: if (untie(%hash)) {
1.1 albertel 1284: print $client "ok\n";
1285: } else {
1286: print $client "error:$!\n";
1287: }
1288: } else {
1289: print $client "error:$!\n";
1290: }
1291: # ----------------------------------------------------------------------- idget
1292: } elsif ($userinput =~ /^idget/) {
1293: my ($cmd,$udom,$what)=split(/:/,$userinput);
1294: chomp($what);
1295: $udom=~s/\W//g;
1296: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1297: my @queries=split(/\&/,$what);
1298: my $qresult='';
1.20 www 1299: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
1.1 albertel 1300: for ($i=0;$i<=$#queries;$i++) {
1301: $qresult.="$hash{$queries[$i]}&";
1302: }
1.4 www 1303: if (untie(%hash)) {
1.1 albertel 1304: $qresult=~s/\&$//;
1305: print $client "$qresult\n";
1306: } else {
1307: print $client "error:$!\n";
1308: }
1309: } else {
1310: print $client "error:$!\n";
1311: }
1.13 www 1312: # ---------------------------------------------------------------------- tmpput
1313: } elsif ($userinput =~ /^tmpput/) {
1314: my ($cmd,$what)=split(/:/,$userinput);
1315: my $store;
1316: $tmpsnum++;
1317: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1318: $id=~s/\W/\_/g;
1319: $what=~s/\n//g;
1320: my $execdir=$perlvar{'lonDaemons'};
1321: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1322: print $store $what;
1323: close $store;
1324: print $client "$id\n";
1325: }
1326: else {
1327: print $client "error:$!\n";
1328: }
1329:
1330: # ---------------------------------------------------------------------- tmpget
1331: } elsif ($userinput =~ /^tmpget/) {
1332: my ($cmd,$id)=split(/:/,$userinput);
1333: chomp($id);
1334: $id=~s/\W/\_/g;
1335: my $store;
1336: my $execdir=$perlvar{'lonDaemons'};
1337: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
1338: my $reply=<$store>;
1339: print $client "$reply\n";
1340: close $store;
1341: }
1342: else {
1343: print $client "error:$!\n";
1344: }
1345:
1.5 www 1346: # -------------------------------------------------------------------------- ls
1347: } elsif ($userinput =~ /^ls/) {
1348: my ($cmd,$ulsdir)=split(/:/,$userinput);
1349: my $ulsout='';
1350: my $ulsfn;
1351: if (-e $ulsdir) {
1.41 www 1352: if (opendir(LSDIR,$ulsdir)) {
1353: while ($ulsfn=readdir(LSDIR)) {
1.47 www 1354: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1.5 www 1355: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1356: }
1.41 www 1357: closedir(LSDIR);
1358: }
1.5 www 1359: } else {
1360: $ulsout='no_such_dir';
1361: }
1.17 www 1362: if ($ulsout eq '') { $ulsout='empty'; }
1.5 www 1363: print $client "$ulsout\n";
1.51 www 1364: # ------------------------------------------------------------------ Hanging up
1365: } elsif (($userinput =~ /^exit/) ||
1366: ($userinput =~ /^init/)) {
1367: &logthis(
1368: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1369: print $client "bye\n";
1.59 www 1370: $client->close();
1.51 www 1371: last;
1.1 albertel 1372: # ------------------------------------------------------------- unknown command
1373: } else {
1374: # unknown command
1375: print $client "unknown_cmd\n";
1376: }
1.58 www 1377: # -------------------------------------------------------------------- complete
1.63 www 1378: alarm(0);
1.58 www 1379: &status('Listening to '.$hostid{$clientip});
1.68.2.1! albertel 1380: &logthis('Completed '.$userinput.' Listening to '.$hostid{$clientip});
1.58 www 1381: }
1.59 www 1382: # --------------------------------------------- client unknown or fishy, refuse
1.1 albertel 1383: } else {
1384: print $client "refused\n";
1.59 www 1385: $client->close();
1.9 www 1386: &logthis("<font color=blue>WARNING: "
1387: ."Rejected client $clientip, closing connection</font>");
1.1 albertel 1388: }
1.9 www 1389: &logthis("<font color=red>CRITICAL: "
1.10 www 1390: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1.1 albertel 1391: # =============================================================================
1392: }
1393:
1394: # tidy up gracefully and finish
1395:
1.59 www 1396: $client->close();
1397: $server->close();
1398:
1.1 albertel 1399: # this exit is VERY important, otherwise the child will become
1400: # a producer of more and more children, forking yourself into
1401: # process death.
1402: exit;
1403: }
1404: }
1405:
1.61 harris41 1406: # ----------------------------------- POD (plain old documentation, CPAN style)
1407:
1408: =head1 NAME
1409:
1410: lond - "LON Daemon" Server (port "LOND" 5663)
1411:
1412: =head1 SYNOPSIS
1413:
1414: Should only be run as user=www. Invoked by loncron.
1415:
1416: =head1 DESCRIPTION
1417:
1418: Preforker - server who forks first. Runs as a daemon. HUPs.
1419: Uses IDEA encryption
1420:
1421: =head1 README
1422:
1423: Not yet written.
1424:
1425: =head1 PREREQUISITES
1426:
1427: IO::Socket
1428: IO::File
1429: Apache::File
1430: Symbol
1431: POSIX
1432: Crypt::IDEA
1433: LWP::UserAgent()
1434: GDBM_File
1435: Authen::Krb4
1436:
1437: =head1 COREQUISITES
1438:
1439: =head1 OSNAMES
1440:
1441: linux
1442:
1443: =head1 SCRIPT CATEGORIES
1444:
1445: Server/Process
1446:
1447: =cut
1.1 albertel 1448:
1449:
1450:
1451:
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