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