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