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