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