1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
4: #
5: # $Id: lond,v 1.94 2002/09/03 02:01:14 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: # 02/05 Guy Albertelli
52: # 02/07 Scott Harrison
53: # 02/12 Gerd Kortemeyer
54: # 02/19 Matthew Hall
55: # 02/25 Gerd Kortemeyer
56: # 05/11 Scott Harrison
57: ###
58:
59: # based on "Perl Cookbook" ISBN 1-56592-243-3
60: # preforker - server who forks first
61: # runs as a daemon
62: # HUPs
63: # uses IDEA encryption
64:
65: use lib '/home/httpd/lib/perl/';
66: use LONCAPA::Configuration;
67:
68: use IO::Socket;
69: use IO::File;
70: use Apache::File;
71: use Symbol;
72: use POSIX;
73: use Crypt::IDEA;
74: use LWP::UserAgent();
75: use GDBM_File;
76: use Authen::Krb4;
77: use Authen::Krb5;
78: use lib '/home/httpd/lib/perl/';
79: use localauth;
80:
81: my $DEBUG = 0; # Non zero to enable debug log entries.
82:
83: my $status='';
84: my $lastlog='';
85:
86: # grabs exception and records it to log before exiting
87: sub catchexception {
88: my ($error)=@_;
89: $SIG{'QUIT'}='DEFAULT';
90: $SIG{__DIE__}='DEFAULT';
91: &logthis("<font color=red>CRITICAL: "
92: ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
93: ."a crash with this error msg->[$error]</font>");
94: &logthis('Famous last words: '.$status.' - '.$lastlog);
95: if ($client) { print $client "error: $error\n"; }
96: $server->close();
97: die($error);
98: }
99:
100: sub timeout {
101: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
102: &catchexception('Timeout');
103: }
104: # -------------------------------- Set signal handlers to record abnormal exits
105:
106: $SIG{'QUIT'}=\&catchexception;
107: $SIG{__DIE__}=\&catchexception;
108:
109: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
110: &status("Read loncapa_apache.conf and loncapa.conf");
111: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
112: 'loncapa.conf');
113: my %perlvar=%{$perlvarref};
114: undef $perlvarref;
115:
116: # ----------------------------- Make sure this process is running from user=www
117: my $wwwid=getpwnam('www');
118: if ($wwwid!=$<) {
119: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
120: $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
121: system("echo 'User ID mismatch. lond must be run as user www.' |\
122: mailto $emailto -s '$subj' > /dev/null");
123: exit 1;
124: }
125:
126: # --------------------------------------------- Check if other instance running
127:
128: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
129:
130: if (-e $pidfile) {
131: my $lfh=IO::File->new("$pidfile");
132: my $pide=<$lfh>;
133: chomp($pide);
134: if (kill 0 => $pide) { die "already running"; }
135: }
136:
137: $PREFORK=4; # number of children to maintain, at least four spare
138:
139: # ------------------------------------------------------------- Read hosts file
140:
141: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
142:
143: while ($configline=<CONFIG>) {
144: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
145: chomp($ip); $ip=~s/\D+$//;
146: $hostid{$ip}=$id;
147: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
148: $PREFORK++;
149: }
150: close(CONFIG);
151:
152: # establish SERVER socket, bind and listen.
153: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
154: Type => SOCK_STREAM,
155: Proto => 'tcp',
156: Reuse => 1,
157: Listen => 10 )
158: or die "making socket: $@\n";
159:
160: # --------------------------------------------------------- Do global variables
161:
162: # global variables
163:
164: $MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should
165: # process
166: %children = (); # keys are current child process IDs
167: $children = 0; # current number of children
168:
169: sub REAPER { # takes care of dead children
170: $SIG{CHLD} = \&REAPER;
171: my $pid = wait;
172: if (defined($children{$pid})) {
173: &logthis("Child $pid died");
174: $children --;
175: delete $children{$pid};
176: } else {
177: &logthis("Unknown Child $pid died");
178: }
179: }
180:
181: sub HUNTSMAN { # signal handler for SIGINT
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: my $execdir=$perlvar{'lonDaemons'};
186: unlink("$execdir/logs/lond.pid");
187: &logthis("<font color=red>CRITICAL: Shutting down</font>");
188: exit; # clean up with dignity
189: }
190:
191: sub HUPSMAN { # signal handler for SIGHUP
192: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
193: kill 'INT' => keys %children;
194: &logthis("Free socket: ".shutdown($server,2)); # free up socket
195: &logthis("<font color=red>CRITICAL: Restarting</font>");
196: unlink("$execdir/logs/lond.pid");
197: my $execdir=$perlvar{'lonDaemons'};
198: exec("$execdir/lond"); # here we go again
199: }
200:
201: sub checkchildren {
202: &initnewstatus();
203: &logstatus();
204: &logthis('Going to check on the children');
205: $docdir=$perlvar{'lonDocRoot'};
206: foreach (sort keys %children) {
207: sleep 1;
208: unless (kill 'USR1' => $_) {
209: &logthis ('Child '.$_.' is dead');
210: &logstatus($$.' is dead');
211: }
212: }
213: sleep 5;
214: foreach (sort keys %children) {
215: unless (-e "$docdir/lon-status/londchld/$_.txt") {
216: &logthis('Child '.$_.' did not respond');
217: kill 9 => $_;
218: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
219: $subj="LON: $perlvar{'lonHostID'} killed lond process $_";
220: my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
221: $execdir=$perlvar{'lonDaemons'};
222: $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`
223: }
224: }
225: }
226:
227: # --------------------------------------------------------------------- Logging
228:
229: sub logthis {
230: my $message=shift;
231: my $execdir=$perlvar{'lonDaemons'};
232: my $fh=IO::File->new(">>$execdir/logs/lond.log");
233: my $now=time;
234: my $local=localtime($now);
235: $lastlog=$local.': '.$message;
236: print $fh "$local ($$): $message\n";
237: }
238:
239: # ------------------------- Conditional log if $DEBUG true.
240: sub Debug {
241: my $message = shift;
242: if($DEBUG) {
243: &logthis($message);
244: }
245: }
246: # ------------------------------------------------------------------ Log status
247:
248: sub logstatus {
249: my $docdir=$perlvar{'lonDocRoot'};
250: {
251: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
252: print $fh $$."\t".$status."\t".$lastlog."\n";
253: $fh->close();
254: }
255: {
256: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
257: print $fh $status."\n".$lastlog."\n".time;
258: $fh->close();
259: }
260: }
261:
262: sub initnewstatus {
263: my $docdir=$perlvar{'lonDocRoot'};
264: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
265: my $now=time;
266: my $local=localtime($now);
267: print $fh "LOND status $local - parent $$\n\n";
268: opendir(DIR,"$docdir/lon-status/londchld");
269: while ($filename=readdir(DIR)) {
270: unlink("$docdir/lon-status/londchld/$filename");
271: }
272: closedir(DIR);
273: }
274:
275: # -------------------------------------------------------------- Status setting
276:
277: sub status {
278: my $what=shift;
279: my $now=time;
280: my $local=localtime($now);
281: $status=$local.': '.$what;
282: }
283:
284: # -------------------------------------------------------- Escape Special Chars
285:
286: sub escape {
287: my $str=shift;
288: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
289: return $str;
290: }
291:
292: # ----------------------------------------------------- Un-Escape Special Chars
293:
294: sub unescape {
295: my $str=shift;
296: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
297: return $str;
298: }
299:
300: # ----------------------------------------------------------- Send USR1 to lonc
301:
302: sub reconlonc {
303: my $peerfile=shift;
304: &logthis("Trying to reconnect for $peerfile");
305: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
306: if (my $fh=IO::File->new("$loncfile")) {
307: my $loncpid=<$fh>;
308: chomp($loncpid);
309: if (kill 0 => $loncpid) {
310: &logthis("lonc at pid $loncpid responding, sending USR1");
311: kill USR1 => $loncpid;
312: sleep 5;
313: if (-e "$peerfile") { return; }
314: &logthis("$peerfile still not there, give it another try");
315: sleep 10;
316: if (-e "$peerfile") { return; }
317: &logthis(
318: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
319: } else {
320: &logthis(
321: "<font color=red>CRITICAL: "
322: ."lonc at pid $loncpid not responding, giving up</font>");
323: }
324: } else {
325: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
326: }
327: }
328:
329: # -------------------------------------------------- Non-critical communication
330:
331: sub subreply {
332: my ($cmd,$server)=@_;
333: my $peerfile="$perlvar{'lonSockDir'}/$server";
334: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
335: Type => SOCK_STREAM,
336: Timeout => 10)
337: or return "con_lost";
338: print $sclient "$cmd\n";
339: my $answer=<$sclient>;
340: chomp($answer);
341: if (!$answer) { $answer="con_lost"; }
342: return $answer;
343: }
344:
345: sub reply {
346: my ($cmd,$server)=@_;
347: my $answer;
348: if ($server ne $perlvar{'lonHostID'}) {
349: $answer=subreply($cmd,$server);
350: if ($answer eq 'con_lost') {
351: $answer=subreply("ping",$server);
352: if ($answer ne $server) {
353: &logthis("sub reply: answer != server");
354: &reconlonc("$perlvar{'lonSockDir'}/$server");
355: }
356: $answer=subreply($cmd,$server);
357: }
358: } else {
359: $answer='self_reply';
360: }
361: return $answer;
362: }
363:
364: # -------------------------------------------------------------- Talk to lonsql
365:
366: sub sqlreply {
367: my ($cmd)=@_;
368: my $answer=subsqlreply($cmd);
369: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
370: return $answer;
371: }
372:
373: sub subsqlreply {
374: my ($cmd)=@_;
375: my $unixsock="mysqlsock";
376: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
377: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
378: Type => SOCK_STREAM,
379: Timeout => 10)
380: or return "con_lost";
381: print $sclient "$cmd\n";
382: my $answer=<$sclient>;
383: chomp($answer);
384: if (!$answer) { $answer="con_lost"; }
385: return $answer;
386: }
387:
388: # -------------------------------------------- Return path to profile directory
389:
390: sub propath {
391: my ($udom,$uname)=@_;
392: $udom=~s/\W//g;
393: $uname=~s/\W//g;
394: my $subdir=$uname.'__';
395: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
396: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
397: return $proname;
398: }
399:
400: # --------------------------------------- Is this the home server of an author?
401:
402: sub ishome {
403: my $author=shift;
404: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
405: my ($udom,$uname)=split(/\//,$author);
406: my $proname=propath($udom,$uname);
407: if (-e $proname) {
408: return 'owner';
409: } else {
410: return 'not_owner';
411: }
412: }
413:
414: # ======================================================= Continue main program
415: # ---------------------------------------------------- Fork once and dissociate
416:
417: $fpid=fork;
418: exit if $fpid;
419: die "Couldn't fork: $!" unless defined ($fpid);
420:
421: POSIX::setsid() or die "Can't start new session: $!";
422:
423: # ------------------------------------------------------- Write our PID on disk
424:
425: $execdir=$perlvar{'lonDaemons'};
426: open (PIDSAVE,">$execdir/logs/lond.pid");
427: print PIDSAVE "$$\n";
428: close(PIDSAVE);
429: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
430: &status('Starting');
431:
432: # ------------------------------------------------------- Now we are on our own
433:
434: # Fork off our children.
435: for (1 .. $PREFORK) {
436: make_new_child();
437: }
438:
439: # ----------------------------------------------------- Install signal handlers
440:
441: &status('Forked children');
442:
443: $SIG{CHLD} = \&REAPER;
444: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
445: $SIG{HUP} = \&HUPSMAN;
446: $SIG{USR1} = \&checkchildren;
447:
448: # And maintain the population.
449: while (1) {
450: &status('Sleeping');
451: sleep; # wait for a signal (i.e., child's death)
452: &logthis('Woke up');
453: &status('Woke up');
454: for ($i = $children; $i < $PREFORK; $i++) {
455: make_new_child(); # top up the child pool
456: }
457: }
458:
459: sub make_new_child {
460: my $pid;
461: my $cipher;
462: my $sigset;
463: &logthis("Attempting to start child");
464: # block signal for fork
465: $sigset = POSIX::SigSet->new(SIGINT);
466: sigprocmask(SIG_BLOCK, $sigset)
467: or die "Can't block SIGINT for fork: $!\n";
468:
469: die "fork: $!" unless defined ($pid = fork);
470:
471: if ($pid) {
472: # Parent records the child's birth and returns.
473: sigprocmask(SIG_UNBLOCK, $sigset)
474: or die "Can't unblock SIGINT for fork: $!\n";
475: $children{$pid} = 1;
476: $children++;
477: &status('Started child '.$pid);
478: return;
479: } else {
480: # Child can *not* return from this subroutine.
481: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
482: $SIG{USR1}= \&logstatus;
483: $SIG{ALRM}= \&timeout;
484: $lastlog='Forked ';
485: $status='Forked';
486:
487: # unblock signals
488: sigprocmask(SIG_UNBLOCK, $sigset)
489: or die "Can't unblock SIGINT for fork: $!\n";
490:
491: $tmpsnum=0;
492: #---------------------------------------------------- kerberos 5 initialization
493: &Authen::Krb5::init_context();
494: &Authen::Krb5::init_ets();
495:
496: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
497: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
498: &status('Idle, waiting for connection');
499: $client = $server->accept() or last;
500: &status('Accepted connection');
501: # =============================================================================
502: # do something with the connection
503: # -----------------------------------------------------------------------------
504: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
505: # connection liveness.
506: # see if we know client and check for spoof IP by challenge
507: my $caller=getpeername($client);
508: my ($port,$iaddr)=unpack_sockaddr_in($caller);
509: my $clientip=inet_ntoa($iaddr);
510: my $clientrec=($hostid{$clientip} ne undef);
511: &logthis(
512: "<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"
513: );
514: &status("Connecting $clientip ($hostid{$clientip})");
515: my $clientok;
516: if ($clientrec) {
517: &status("Waiting for init from $clientip ($hostid{$clientip})");
518: my $remotereq=<$client>;
519: $remotereq=~s/\W//g;
520: if ($remotereq eq 'init') {
521: my $challenge="$$".time;
522: print $client "$challenge\n";
523: &status(
524: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
525: $remotereq=<$client>;
526: $remotereq=~s/\W//g;
527: if ($challenge eq $remotereq) {
528: $clientok=1;
529: print $client "ok\n";
530: } else {
531: &logthis(
532: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
533: &status('No challenge reply '.$clientip);
534: }
535: } else {
536: &logthis(
537: "<font color=blue>WARNING: "
538: ."$clientip failed to initialize: >$remotereq< </font>");
539: &status('No init '.$clientip);
540: }
541: } else {
542: &logthis(
543: "<font color=blue>WARNING: Unknown client $clientip</font>");
544: &status('Hung up on '.$clientip);
545: }
546: if ($clientok) {
547: # ---------------- New known client connecting, could mean machine online again
548:
549: &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
550: &logthis(
551: "<font color=green>Established connection: $hostid{$clientip}</font>");
552: &status('Will listen to '.$hostid{$clientip});
553: # ------------------------------------------------------------ Process requests
554: while (my $userinput=<$client>) {
555: chomp($userinput);
556: Debug("Request = $userinput\n");
557: &status('Processing '.$hostid{$clientip}.': '.$userinput);
558: my $wasenc=0;
559: alarm(120);
560: # ------------------------------------------------------------ See if encrypted
561: if ($userinput =~ /^enc/) {
562: if ($cipher) {
563: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
564: $userinput='';
565: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
566: $userinput.=
567: $cipher->decrypt(
568: pack("H16",substr($encinput,$encidx,16))
569: );
570: }
571: $userinput=substr($userinput,0,$cmdlength);
572: $wasenc=1;
573: }
574: }
575:
576: # ------------------------------------------------------------- Normal commands
577: # ------------------------------------------------------------------------ ping
578: if ($userinput =~ /^ping/) {
579: print $client "$perlvar{'lonHostID'}\n";
580: # ------------------------------------------------------------------------ pong
581: } elsif ($userinput =~ /^pong/) {
582: $reply=reply("ping",$hostid{$clientip});
583: print $client "$perlvar{'lonHostID'}:$reply\n";
584: # ------------------------------------------------------------------------ ekey
585: } elsif ($userinput =~ /^ekey/) {
586: my $buildkey=time.$$.int(rand 100000);
587: $buildkey=~tr/1-6/A-F/;
588: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
589: my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
590: $key=~tr/a-z/A-Z/;
591: $key=~tr/G-P/0-9/;
592: $key=~tr/Q-Z/0-9/;
593: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
594: $key=substr($key,0,32);
595: my $cipherkey=pack("H32",$key);
596: $cipher=new IDEA $cipherkey;
597: print $client "$buildkey\n";
598: # ------------------------------------------------------------------------ load
599: } elsif ($userinput =~ /^load/) {
600: my $loadavg;
601: {
602: my $loadfile=IO::File->new('/proc/loadavg');
603: $loadavg=<$loadfile>;
604: }
605: $loadavg =~ s/\s.*//g;
606: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
607: print $client "$loadpercent\n";
608: # ----------------------------------------------------------------- currentauth
609: } elsif ($userinput =~ /^currentauth/) {
610: if ($wasenc==1) {
611: my ($cmd,$udom,$uname)=split(/:/,$userinput);
612: my $result = GetAuthType($udom, $uname);
613: if($result eq "nouser") {
614: print $client "unknown_user\n";
615: }
616: else {
617: print $client "$result\n"
618: }
619: } else {
620: print $client "refused\n";
621: }
622: # ------------------------------------------------------------------------ auth
623: } elsif ($userinput =~ /^auth/) {
624: if ($wasenc==1) {
625: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
626: chomp($upass);
627: $upass=unescape($upass);
628: my $proname=propath($udom,$uname);
629: my $passfilename="$proname/passwd";
630: if (-e $passfilename) {
631: my $pf = IO::File->new($passfilename);
632: my $realpasswd=<$pf>;
633: chomp($realpasswd);
634: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
635: my $pwdcorrect=0;
636: if ($howpwd eq 'internal') {
637: $pwdcorrect=
638: (crypt($upass,$contentpwd) eq $contentpwd);
639: } elsif ($howpwd eq 'unix') {
640: $contentpwd=(getpwnam($uname))[1];
641: my $pwauth_path="/usr/local/sbin/pwauth";
642: unless ($contentpwd eq 'x') {
643: $pwdcorrect=
644: (crypt($upass,$contentpwd) eq $contentpwd);
645: }
646: elsif (-e $pwauth_path) {
647: open PWAUTH, "|$pwauth_path" or
648: die "Cannot invoke authentication";
649: print PWAUTH "$uname\n$upass\n";
650: close PWAUTH;
651: $pwdcorrect=!$?;
652: }
653: } elsif ($howpwd eq 'krb4') {
654: $null=pack("C",0);
655: unless ($upass=~/$null/) {
656: $pwdcorrect=(
657: Authen::Krb4::get_pw_in_tkt($uname,"",
658: $contentpwd,'krbtgt',$contentpwd,1,
659: $upass) == 0);
660: } else { $pwdcorrect=0; }
661: } elsif ($howpwd eq 'krb5') {
662: $null=pack("C",0);
663: unless ($upass=~/$null/) {
664: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
665: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
666: my $krbserver=&Authen::Krb5::parse_name($krbservice);
667: my $credentials=&Authen::Krb5::cc_default();
668: $credentials->initialize($krbclient);
669: my $krbreturn =
670: &Authen::Krb5::get_in_tkt_with_password(
671: $krbclient,$krbserver,$upass,$credentials);
672: # unless ($krbreturn) {
673: # &logthis("Krb5 Error: ".
674: # &Authen::Krb5::error());
675: # }
676: $pwdcorrect = ($krbreturn == 1);
677: } else { $pwdcorrect=0; }
678: } elsif ($howpwd eq 'localauth') {
679: $pwdcorrect=&localauth::localauth($uname,$upass,
680: $contentpwd);
681: }
682: if ($pwdcorrect) {
683: print $client "authorized\n";
684: } else {
685: print $client "non_authorized\n";
686: }
687: } else {
688: print $client "unknown_user\n";
689: }
690: } else {
691: print $client "refused\n";
692: }
693: # ---------------------------------------------------------------------- passwd
694: } elsif ($userinput =~ /^passwd/) {
695: if ($wasenc==1) {
696: my
697: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
698: chomp($npass);
699: $upass=&unescape($upass);
700: $npass=&unescape($npass);
701: &logthis("Trying to change password for $uname");
702: my $proname=propath($udom,$uname);
703: my $passfilename="$proname/passwd";
704: if (-e $passfilename) {
705: my $realpasswd;
706: { my $pf = IO::File->new($passfilename);
707: $realpasswd=<$pf>; }
708: chomp($realpasswd);
709: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
710: if ($howpwd eq 'internal') {
711: if (crypt($upass,$contentpwd) eq $contentpwd) {
712: my $salt=time;
713: $salt=substr($salt,6,2);
714: my $ncpass=crypt($npass,$salt);
715: { my $pf = IO::File->new(">$passfilename");
716: print $pf "internal:$ncpass\n"; }
717: &logthis("Result of password change for $uname: pwchange_success");
718: print $client "ok\n";
719: } else {
720: print $client "non_authorized\n";
721: }
722: } elsif ($howpwd eq 'unix') {
723: # Unix means we have to access /etc/password
724: # one way or another.
725: # First: Make sure the current password is
726: # correct
727: $contentpwd=(getpwnam($uname))[1];
728: my $pwdcorrect = "0";
729: my $pwauth_path="/usr/local/sbin/pwauth";
730: unless ($contentpwd eq 'x') {
731: $pwdcorrect=
732: (crypt($upass,$contentpwd) eq $contentpwd);
733: } elsif (-e $pwauth_path) {
734: open PWAUTH, "|$pwauth_path" or
735: die "Cannot invoke authentication";
736: print PWAUTH "$uname\n$upass\n";
737: close PWAUTH;
738: $pwdcorrect=!$?;
739: }
740: if ($pwdcorrect) {
741: my $execdir=$perlvar{'lonDaemons'};
742: my $pf = IO::File->new("|$execdir/lcpasswd");
743: print $pf "$uname\n$npass\n$npass\n";
744: close $pf;
745: my $result = ($?>0 ? 'pwchange_failure'
746: : 'ok');
747: &logthis("Result of password change for $uname: $result");
748: print $client "$result\n";
749: } else {
750: print $client "non_authorized\n";
751: }
752: } else {
753: print $client "auth_mode_error\n";
754: }
755: } else {
756: print $client "unknown_user\n";
757: }
758: } else {
759: print $client "refused\n";
760: }
761: # -------------------------------------------------------------------- makeuser
762: } elsif ($userinput =~ /^makeuser/) {
763: &Debug("Make user received");
764: my $oldumask=umask(0077);
765: if ($wasenc==1) {
766: my
767: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
768: &Debug("cmd =".$cmd." $udom =".$udom.
769: " uname=".$uname);
770: chomp($npass);
771: $npass=&unescape($npass);
772: my $proname=propath($udom,$uname);
773: my $passfilename="$proname/passwd";
774: &Debug("Password file created will be:".
775: $passfilename);
776: if (-e $passfilename) {
777: print $client "already_exists\n";
778: } elsif ($udom ne $perlvar{'lonDefDomain'}) {
779: print $client "not_right_domain\n";
780: } else {
781: @fpparts=split(/\//,$proname);
782: $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
783: $fperror='';
784: for ($i=3;$i<=$#fpparts;$i++) {
785: $fpnow.='/'.$fpparts[$i];
786: unless (-e $fpnow) {
787: unless (mkdir($fpnow,0777)) {
788: $fperror="error:$!";
789: }
790: }
791: }
792: unless ($fperror) {
793: my $result=&make_passwd_file($umode,$npass,
794: $passfilename);
795: print $client $result;
796: } else {
797: print $client "$fperror\n";
798: }
799: }
800: } else {
801: print $client "refused\n";
802: }
803: umask($oldumask);
804: # -------------------------------------------------------------- changeuserauth
805: } elsif ($userinput =~ /^changeuserauth/) {
806: &Debug("Changing authorization");
807: if ($wasenc==1) {
808: my
809: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
810: chomp($npass);
811: &Debug("cmd = ".$cmd." domain= ".$udom.
812: "uname =".$uname." umode= ".$umode);
813: $npass=&unescape($npass);
814: my $proname=&propath($udom,$uname);
815: my $passfilename="$proname/passwd";
816: if ($udom ne $perlvar{'lonDefDomain'}) {
817: print $client "not_right_domain\n";
818: } else {
819: my $result=&make_passwd_file($umode,$npass,
820: $passfilename);
821: print $client $result;
822: }
823: } else {
824: print $client "refused\n";
825: }
826: # ------------------------------------------------------------------------ home
827: } elsif ($userinput =~ /^home/) {
828: my ($cmd,$udom,$uname)=split(/:/,$userinput);
829: chomp($uname);
830: my $proname=propath($udom,$uname);
831: if (-e $proname) {
832: print $client "found\n";
833: } else {
834: print $client "not_found\n";
835: }
836: # ---------------------------------------------------------------------- update
837: } elsif ($userinput =~ /^update/) {
838: my ($cmd,$fname)=split(/:/,$userinput);
839: my $ownership=ishome($fname);
840: if ($ownership eq 'not_owner') {
841: if (-e $fname) {
842: my ($dev,$ino,$mode,$nlink,
843: $uid,$gid,$rdev,$size,
844: $atime,$mtime,$ctime,
845: $blksize,$blocks)=stat($fname);
846: $now=time;
847: $since=$now-$atime;
848: if ($since>$perlvar{'lonExpire'}) {
849: $reply=
850: reply("unsub:$fname","$hostid{$clientip}");
851: unlink("$fname");
852: } else {
853: my $transname="$fname.in.transfer";
854: my $remoteurl=
855: reply("sub:$fname","$hostid{$clientip}");
856: my $response;
857: {
858: my $ua=new LWP::UserAgent;
859: my $request=new HTTP::Request('GET',"$remoteurl");
860: $response=$ua->request($request,$transname);
861: }
862: if ($response->is_error()) {
863: unlink($transname);
864: my $message=$response->status_line;
865: &logthis(
866: "LWP GET: $message for $fname ($remoteurl)");
867: } else {
868: if ($remoteurl!~/\.meta$/) {
869: my $ua=new LWP::UserAgent;
870: my $mrequest=
871: new HTTP::Request('GET',$remoteurl.'.meta');
872: my $mresponse=
873: $ua->request($mrequest,$fname.'.meta');
874: if ($mresponse->is_error()) {
875: unlink($fname.'.meta');
876: }
877: }
878: rename($transname,$fname);
879: }
880: }
881: print $client "ok\n";
882: } else {
883: print $client "not_found\n";
884: }
885: } else {
886: print $client "rejected\n";
887: }
888: # -------------------------------------- fetch a user file from a remote server
889: } elsif ($userinput =~ /^fetchuserfile/) {
890: my ($cmd,$fname)=split(/:/,$userinput);
891: my ($udom,$uname,$ufile)=split(/\//,$fname);
892: my $udir=propath($udom,$uname).'/userfiles';
893: unless (-e $udir) { mkdir($udir,0770); }
894: if (-e $udir) {
895: $ufile=~s/^[\.\~]+//;
896: $ufile=~s/\///g;
897: my $transname=$udir.'/'.$ufile;
898: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
899: my $response;
900: {
901: my $ua=new LWP::UserAgent;
902: my $request=new HTTP::Request('GET',"$remoteurl");
903: $response=$ua->request($request,$transname);
904: }
905: if ($response->is_error()) {
906: unlink($transname);
907: my $message=$response->status_line;
908: &logthis(
909: "LWP GET: $message for $fname ($remoteurl)");
910: print $client "failed\n";
911: } else {
912: print $client "ok\n";
913: }
914: } else {
915: print $client "not_home\n";
916: }
917: # ------------------------------------------ authenticate access to a user file
918: } elsif ($userinput =~ /^tokenauthuserfile/) {
919: my ($cmd,$fname,$session)=split(/:/,$userinput);
920: chomp($session);
921: $reply='non_auth';
922: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
923: $session.'.id')) {
924: while ($line=<ENVIN>) {
925: if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
926: }
927: close(ENVIN);
928: print $client $reply."\n";
929: } else {
930: print $client "invalid_token\n";
931: }
932: # ----------------------------------------------------------------- unsubscribe
933: } elsif ($userinput =~ /^unsub/) {
934: my ($cmd,$fname)=split(/:/,$userinput);
935: if (-e $fname) {
936: print $client &unsub($client,$fname,$clientip);
937: } else {
938: print $client "not_found\n";
939: }
940: # ------------------------------------------------------------------- subscribe
941: } elsif ($userinput =~ /^sub/) {
942: print $client &subscribe($userinput,$clientip);
943: # ------------------------------------------------------------------------- log
944: } elsif ($userinput =~ /^log/) {
945: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
946: chomp($what);
947: my $proname=propath($udom,$uname);
948: my $now=time;
949: {
950: my $hfh;
951: if ($hfh=IO::File->new(">>$proname/activity.log")) {
952: print $hfh "$now:$hostid{$clientip}:$what\n";
953: print $client "ok\n";
954: } else {
955: print $client "error:$!\n";
956: }
957: }
958: # ------------------------------------------------------------------------- put
959: } elsif ($userinput =~ /^put/) {
960: my ($cmd,$udom,$uname,$namespace,$what)
961: =split(/:/,$userinput);
962: $namespace=~s/\//\_/g;
963: $namespace=~s/\W//g;
964: if ($namespace ne 'roles') {
965: chomp($what);
966: my $proname=propath($udom,$uname);
967: my $now=time;
968: unless ($namespace=~/^nohist\_/) {
969: my $hfh;
970: if (
971: $hfh=IO::File->new(">>$proname/$namespace.hist")
972: ) { print $hfh "P:$now:$what\n"; }
973: }
974: my @pairs=split(/\&/,$what);
975: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
976: foreach $pair (@pairs) {
977: ($key,$value)=split(/=/,$pair);
978: $hash{$key}=$value;
979: }
980: if (untie(%hash)) {
981: print $client "ok\n";
982: } else {
983: print $client "error:$!\n";
984: }
985: } else {
986: print $client "error:$!\n";
987: }
988: } else {
989: print $client "refused\n";
990: }
991: # -------------------------------------------------------------------- rolesput
992: } elsif ($userinput =~ /^rolesput/) {
993: &Debug("rolesput");
994: if ($wasenc==1) {
995: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
996: =split(/:/,$userinput);
997: &Debug("cmd = ".$cmd." exedom= ".$exedom.
998: "user = ".$exeuser." udom=".$udom.
999: "what = ".$what);
1000: my $namespace='roles';
1001: chomp($what);
1002: my $proname=propath($udom,$uname);
1003: my $now=time;
1004: {
1005: my $hfh;
1006: if (
1007: $hfh=IO::File->new(">>$proname/$namespace.hist")
1008: ) {
1009: print $hfh "P:$now:$exedom:$exeuser:$what\n";
1010: }
1011: }
1012: my @pairs=split(/\&/,$what);
1013: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1014: foreach $pair (@pairs) {
1015: ($key,$value)=split(/=/,$pair);
1016: &ManagePermissions($key, $udom, $uname,
1017: &GetAuthType( $udom,
1018: $uname));
1019: $hash{$key}=$value;
1020:
1021: }
1022: if (untie(%hash)) {
1023: print $client "ok\n";
1024: } else {
1025: print $client "error:$!\n";
1026: }
1027: } else {
1028: print $client "error:$!\n";
1029: }
1030: } else {
1031: print $client "refused\n";
1032: }
1033: # ------------------------------------------------------------------------- get
1034: } elsif ($userinput =~ /^get/) {
1035: my ($cmd,$udom,$uname,$namespace,$what)
1036: =split(/:/,$userinput);
1037: $namespace=~s/\//\_/g;
1038: $namespace=~s/\W//g;
1039: chomp($what);
1040: my @queries=split(/\&/,$what);
1041: my $proname=propath($udom,$uname);
1042: my $qresult='';
1043: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1044: for ($i=0;$i<=$#queries;$i++) {
1045: $qresult.="$hash{$queries[$i]}&";
1046: }
1047: if (untie(%hash)) {
1048: $qresult=~s/\&$//;
1049: print $client "$qresult\n";
1050: } else {
1051: print $client "error:$!\n";
1052: }
1053: } else {
1054: print $client "error:$!\n";
1055: }
1056: # ------------------------------------------------------------------------ eget
1057: } elsif ($userinput =~ /^eget/) {
1058: my ($cmd,$udom,$uname,$namespace,$what)
1059: =split(/:/,$userinput);
1060: $namespace=~s/\//\_/g;
1061: $namespace=~s/\W//g;
1062: chomp($what);
1063: my @queries=split(/\&/,$what);
1064: my $proname=propath($udom,$uname);
1065: my $qresult='';
1066: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1067: for ($i=0;$i<=$#queries;$i++) {
1068: $qresult.="$hash{$queries[$i]}&";
1069: }
1070: if (untie(%hash)) {
1071: $qresult=~s/\&$//;
1072: if ($cipher) {
1073: my $cmdlength=length($qresult);
1074: $qresult.=" ";
1075: my $encqresult='';
1076: for
1077: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1078: $encqresult.=
1079: unpack("H16",
1080: $cipher->encrypt(substr($qresult,$encidx,8)));
1081: }
1082: print $client "enc:$cmdlength:$encqresult\n";
1083: } else {
1084: print $client "error:no_key\n";
1085: }
1086: } else {
1087: print $client "error:$!\n";
1088: }
1089: } else {
1090: print $client "error:$!\n";
1091: }
1092: # ------------------------------------------------------------------------- del
1093: } elsif ($userinput =~ /^del/) {
1094: my ($cmd,$udom,$uname,$namespace,$what)
1095: =split(/:/,$userinput);
1096: $namespace=~s/\//\_/g;
1097: $namespace=~s/\W//g;
1098: chomp($what);
1099: my $proname=propath($udom,$uname);
1100: my $now=time;
1101: unless ($namespace=~/^nohist\_/) {
1102: my $hfh;
1103: if (
1104: $hfh=IO::File->new(">>$proname/$namespace.hist")
1105: ) { print $hfh "D:$now:$what\n"; }
1106: }
1107: my @keys=split(/\&/,$what);
1108: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1109: foreach $key (@keys) {
1110: delete($hash{$key});
1111: }
1112: if (untie(%hash)) {
1113: print $client "ok\n";
1114: } else {
1115: print $client "error:$!\n";
1116: }
1117: } else {
1118: print $client "error:$!\n";
1119: }
1120: # ------------------------------------------------------------------------ keys
1121: } elsif ($userinput =~ /^keys/) {
1122: my ($cmd,$udom,$uname,$namespace)
1123: =split(/:/,$userinput);
1124: $namespace=~s/\//\_/g;
1125: $namespace=~s/\W//g;
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: $qresult.="$key&";
1131: }
1132: if (untie(%hash)) {
1133: $qresult=~s/\&$//;
1134: print $client "$qresult\n";
1135: } else {
1136: print $client "error:$!\n";
1137: }
1138: } else {
1139: print $client "error:$!\n";
1140: }
1141: # ------------------------------------------------------------------------ dump
1142: } elsif ($userinput =~ /^dump/) {
1143: my ($cmd,$udom,$uname,$namespace,$regexp)
1144: =split(/:/,$userinput);
1145: $namespace=~s/\//\_/g;
1146: $namespace=~s/\W//g;
1147: if (defined($regexp)) {
1148: $regexp=&unescape($regexp);
1149: } else {
1150: $regexp='.';
1151: }
1152: my $proname=propath($udom,$uname);
1153: my $qresult='';
1154: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1155: study($regexp);
1156: foreach $key (keys %hash) {
1157: my $unescapeKey = &unescape($key);
1158: if (eval('$unescapeKey=~/$regexp/')) {
1159: $qresult.="$key=$hash{$key}&";
1160: }
1161: }
1162: if (untie(%hash)) {
1163: $qresult=~s/\&$//;
1164: print $client "$qresult\n";
1165: } else {
1166: print $client "error:$!\n";
1167: }
1168: } else {
1169: print $client "error:$!\n";
1170: }
1171: # ----------------------------------------------------------------------- store
1172: } elsif ($userinput =~ /^store/) {
1173: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1174: =split(/:/,$userinput);
1175: $namespace=~s/\//\_/g;
1176: $namespace=~s/\W//g;
1177: if ($namespace ne 'roles') {
1178: chomp($what);
1179: my $proname=propath($udom,$uname);
1180: my $now=time;
1181: unless ($namespace=~/^nohist\_/) {
1182: my $hfh;
1183: if (
1184: $hfh=IO::File->new(">>$proname/$namespace.hist")
1185: ) { print $hfh "P:$now:$rid:$what\n"; }
1186: }
1187: my @pairs=split(/\&/,$what);
1188:
1189: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1190: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1191: my $key;
1192: $hash{"version:$rid"}++;
1193: my $version=$hash{"version:$rid"};
1194: my $allkeys='';
1195: foreach $pair (@pairs) {
1196: ($key,$value)=split(/=/,$pair);
1197: $allkeys.=$key.':';
1198: $hash{"$version:$rid:$key"}=$value;
1199: }
1200: $hash{"$version:$rid:timestamp"}=$now;
1201: $allkeys.='timestamp';
1202: $hash{"$version:keys:$rid"}=$allkeys;
1203: if (untie(%hash)) {
1204: print $client "ok\n";
1205: } else {
1206: print $client "error:$!\n";
1207: }
1208: } else {
1209: print $client "error:$!\n";
1210: }
1211: } else {
1212: print $client "refused\n";
1213: }
1214: # --------------------------------------------------------------------- restore
1215: } elsif ($userinput =~ /^restore/) {
1216: my ($cmd,$udom,$uname,$namespace,$rid)
1217: =split(/:/,$userinput);
1218: $namespace=~s/\//\_/g;
1219: $namespace=~s/\W//g;
1220: chomp($rid);
1221: my $proname=propath($udom,$uname);
1222: my $qresult='';
1223: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1224: my $version=$hash{"version:$rid"};
1225: $qresult.="version=$version&";
1226: my $scope;
1227: for ($scope=1;$scope<=$version;$scope++) {
1228: my $vkeys=$hash{"$scope:keys:$rid"};
1229: my @keys=split(/:/,$vkeys);
1230: my $key;
1231: $qresult.="$scope:keys=$vkeys&";
1232: foreach $key (@keys) {
1233: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1234: }
1235: }
1236: if (untie(%hash)) {
1237: $qresult=~s/\&$//;
1238: print $client "$qresult\n";
1239: } else {
1240: print $client "error:$!\n";
1241: }
1242: } else {
1243: print $client "error:$!\n";
1244: }
1245: # -------------------------------------------------------------------- chatsend
1246: } elsif ($userinput =~ /^chatsend/) {
1247: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
1248: &chatadd($cdom,$cnum,$newpost);
1249: print $client "ok\n";
1250: # -------------------------------------------------------------------- chatretr
1251: } elsif ($userinput =~ /^chatretr/) {
1252: my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);
1253: my $reply='';
1254: foreach (&getchat($cdom,$cnum)) {
1255: $reply.=&escape($_).':';
1256: }
1257: $reply=~s/\:$//;
1258: print $client $reply."\n";
1259: # ------------------------------------------------------------------- querysend
1260: } elsif ($userinput =~ /^querysend/) {
1261: my ($cmd,$query,
1262: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
1263: $query=~s/\n*$//g;
1264: print $client "".
1265: sqlreply("$hostid{$clientip}\&$query".
1266: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
1267: # ------------------------------------------------------------------ queryreply
1268: } elsif ($userinput =~ /^queryreply/) {
1269: my ($cmd,$id,$reply)=split(/:/,$userinput);
1270: my $store;
1271: my $execdir=$perlvar{'lonDaemons'};
1272: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1273: $reply=~s/\&/\n/g;
1274: print $store $reply;
1275: close $store;
1276: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1277: print $store2 "done\n";
1278: close $store2;
1279: print $client "ok\n";
1280: }
1281: else {
1282: print $client "error:$!\n";
1283: }
1284: # ----------------------------------------------------------------------- idput
1285: } elsif ($userinput =~ /^idput/) {
1286: my ($cmd,$udom,$what)=split(/:/,$userinput);
1287: chomp($what);
1288: $udom=~s/\W//g;
1289: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1290: my $now=time;
1291: {
1292: my $hfh;
1293: if (
1294: $hfh=IO::File->new(">>$proname.hist")
1295: ) { print $hfh "P:$now:$what\n"; }
1296: }
1297: my @pairs=split(/\&/,$what);
1298: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
1299: foreach $pair (@pairs) {
1300: ($key,$value)=split(/=/,$pair);
1301: $hash{$key}=$value;
1302: }
1303: if (untie(%hash)) {
1304: print $client "ok\n";
1305: } else {
1306: print $client "error:$!\n";
1307: }
1308: } else {
1309: print $client "error:$!\n";
1310: }
1311: # ----------------------------------------------------------------------- idget
1312: } elsif ($userinput =~ /^idget/) {
1313: my ($cmd,$udom,$what)=split(/:/,$userinput);
1314: chomp($what);
1315: $udom=~s/\W//g;
1316: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1317: my @queries=split(/\&/,$what);
1318: my $qresult='';
1319: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
1320: for ($i=0;$i<=$#queries;$i++) {
1321: $qresult.="$hash{$queries[$i]}&";
1322: }
1323: if (untie(%hash)) {
1324: $qresult=~s/\&$//;
1325: print $client "$qresult\n";
1326: } else {
1327: print $client "error:$!\n";
1328: }
1329: } else {
1330: print $client "error:$!\n";
1331: }
1332: # ---------------------------------------------------------------------- tmpput
1333: } elsif ($userinput =~ /^tmpput/) {
1334: my ($cmd,$what)=split(/:/,$userinput);
1335: my $store;
1336: $tmpsnum++;
1337: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1338: $id=~s/\W/\_/g;
1339: $what=~s/\n//g;
1340: my $execdir=$perlvar{'lonDaemons'};
1341: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1342: print $store $what;
1343: close $store;
1344: print $client "$id\n";
1345: }
1346: else {
1347: print $client "error:$!\n";
1348: }
1349:
1350: # ---------------------------------------------------------------------- tmpget
1351: } elsif ($userinput =~ /^tmpget/) {
1352: my ($cmd,$id)=split(/:/,$userinput);
1353: chomp($id);
1354: $id=~s/\W/\_/g;
1355: my $store;
1356: my $execdir=$perlvar{'lonDaemons'};
1357: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
1358: my $reply=<$store>;
1359: print $client "$reply\n";
1360: close $store;
1361: }
1362: else {
1363: print $client "error:$!\n";
1364: }
1365:
1366: # -------------------------------------------------------------------------- ls
1367: } elsif ($userinput =~ /^ls/) {
1368: my ($cmd,$ulsdir)=split(/:/,$userinput);
1369: my $ulsout='';
1370: my $ulsfn;
1371: if (-e $ulsdir) {
1372: if(-d $ulsdir) {
1373: if (opendir(LSDIR,$ulsdir)) {
1374: while ($ulsfn=readdir(LSDIR)) {
1375: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1376: $ulsout.=$ulsfn.'&'.
1377: join('&',@ulsstats).':';
1378: }
1379: closedir(LSDIR);
1380: }
1381: } else {
1382: my @ulsstats=stat($ulsdir);
1383: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1384: }
1385: } else {
1386: $ulsout='no_such_dir';
1387: }
1388: if ($ulsout eq '') { $ulsout='empty'; }
1389: print $client "$ulsout\n";
1390: # ------------------------------------------------------------------ Hanging up
1391: } elsif (($userinput =~ /^exit/) ||
1392: ($userinput =~ /^init/)) {
1393: &logthis(
1394: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1395: print $client "bye\n";
1396: $client->close();
1397: last;
1398: # ------------------------------------------------------------- unknown command
1399: } else {
1400: # unknown command
1401: print $client "unknown_cmd\n";
1402: }
1403: # -------------------------------------------------------------------- complete
1404: alarm(0);
1405: &status('Listening to '.$hostid{$clientip});
1406: }
1407: # --------------------------------------------- client unknown or fishy, refuse
1408: } else {
1409: print $client "refused\n";
1410: $client->close();
1411: &logthis("<font color=blue>WARNING: "
1412: ."Rejected client $clientip, closing connection</font>");
1413: }
1414: }
1415:
1416: # =============================================================================
1417:
1418: &logthis("<font color=red>CRITICAL: "
1419: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1420: # tidy up gracefully and finish
1421:
1422: $server->close();
1423:
1424: # this exit is VERY important, otherwise the child will become
1425: # a producer of more and more children, forking yourself into
1426: # process death.
1427: exit;
1428: }
1429: }
1430:
1431:
1432: #
1433: # Checks to see if the input roleput request was to set
1434: # an author role. If so, invokes the lchtmldir script to set
1435: # up a correct public_html
1436: # Parameters:
1437: # request - The request sent to the rolesput subchunk.
1438: # We're looking for /domain/_au
1439: # domain - The domain in which the user is having roles doctored.
1440: # user - Name of the user for which the role is being put.
1441: # authtype - The authentication type associated with the user.
1442: #
1443: sub ManagePermissions
1444: {
1445: my $request = shift;
1446: my $domain = shift;
1447: my $user = shift;
1448: my $authtype= shift;
1449:
1450: # See if the request is of the form /$domain/_au
1451:
1452: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
1453: my $execdir = $perlvar{'lonDaemons'};
1454: my $userhome= "/home/$user" ;
1455: Debug("system $execdir/lchtmldir $userhome $system $authtype");
1456: system("$execdir/lchtmldir $userhome $user $authtype");
1457: }
1458: }
1459: #
1460: # GetAuthType - Determines the authorization type of a user in a domain.
1461:
1462: # Returns the authorization type or nouser if there is no such user.
1463: #
1464: sub GetAuthType
1465: {
1466: my $domain = shift;
1467: my $user = shift;
1468:
1469: Debug("GetAuthType( $domain, $user ) \n");
1470: my $proname = &propath($domain, $user);
1471: my $passwdfile = "$proname/passwd";
1472: if( -e $passwdfile ) {
1473: my $pf = IO::File->new($passwdfile);
1474: my $realpassword = <$pf>;
1475: chomp($realpassword);
1476: Debug("Password info = $realpassword\n");
1477: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1478: Debug("Authtype = $authtype, content = $contentpwd\n");
1479: my $availinfo = '';
1480: if($authtype eq 'krb4' or $authtype eq 'krb5') {
1481: $availinfo = $contentpwd;
1482: }
1483:
1484: return "$authtype:$availinfo";
1485: }
1486: else {
1487: Debug("Returning nouser");
1488: return "nouser";
1489: }
1490: }
1491:
1492: sub addline {
1493: my ($fname,$hostid,$ip,$newline)=@_;
1494: my $contents;
1495: my $found=0;
1496: my $expr='^'.$hostid.':'.$ip.':';
1497: $expr =~ s/\./\\\./g;
1498: if ($sh=IO::File->new("$fname.subscription")) {
1499: while (my $subline=<$sh>) {
1500: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
1501: }
1502: $sh->close();
1503: }
1504: $sh=IO::File->new(">$fname.subscription");
1505: if ($contents) { print $sh $contents; }
1506: if ($newline) { print $sh $newline; }
1507: $sh->close();
1508: return $found;
1509: }
1510:
1511: sub getchat {
1512: my ($cdom,$cname)=@_;
1513: my %hash;
1514: my $proname=&propath($cdom,$cname);
1515: my @entries=();
1516: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1517: &GDBM_READER(),0640)) {
1518: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1519: untie %hash;
1520: }
1521: return @entries;
1522: }
1523:
1524: sub chatadd {
1525: my ($cdom,$cname,$newchat)=@_;
1526: my %hash;
1527: my $proname=&propath($cdom,$cname);
1528: my @entries=();
1529: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1530: &GDBM_WRCREAT(),0640)) {
1531: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1532: my $time=time;
1533: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
1534: my ($thentime,$idnum)=split(/\_/,$lastid);
1535: my $newid=$time.'_000000';
1536: if ($thentime==$time) {
1537: $idnum=~s/^0+//;
1538: $idnum++;
1539: $idnum=substr('000000'.$idnum,-6,6);
1540: $newid=$time.'_'.$idnum;
1541: }
1542: $hash{$newid}=$newchat;
1543: my $expired=$time-3600;
1544: foreach (keys %hash) {
1545: my ($thistime)=($_=~/(\d+)\_/);
1546: if ($thistime<$expired) {
1547: delete $hash{$_};
1548: }
1549: }
1550: untie %hash;
1551: }
1552: }
1553:
1554: sub unsub {
1555: my ($fname,$clientip)=@_;
1556: my $result;
1557: if (unlink("$fname.$hostid{$clientip}")) {
1558: $result="ok\n";
1559: } else {
1560: $result="not_subscribed\n";
1561: }
1562: if (-e "$fname.subscription") {
1563: my $found=&addline($fname,$hostid{$clientip},$clientip,'');
1564: if ($found) { $result="ok\n"; }
1565: } else {
1566: if ($result != "ok\n") { $result="not_subscribed\n"; }
1567: }
1568: return $result;
1569: }
1570:
1571: sub subscribe {
1572: my ($userinput,$clientip)=@_;
1573: my $result;
1574: my ($cmd,$fname)=split(/:/,$userinput);
1575: my $ownership=&ishome($fname);
1576: if ($ownership eq 'owner') {
1577: if (-e $fname) {
1578: if (-d $fname) {
1579: $result="directory\n";
1580: } else {
1581: if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
1582: $now=time;
1583: my $found=&addline($fname,$hostid{$clientip},$clientip,
1584: "$hostid{$clientip}:$clientip:$now\n");
1585: if ($found) { $result="$fname\n"; }
1586: # if they were subscribed to only meta data, delete that
1587: # subscription, when you subscribe to a file you also get
1588: # the metadata
1589: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
1590: $fname=~s/\/home\/httpd\/html\/res/raw/;
1591: $fname="http://$thisserver/".$fname;
1592: $result="$fname\n";
1593: }
1594: } else {
1595: $result="not_found\n";
1596: }
1597: } else {
1598: $result="rejected\n";
1599: }
1600: return $result;
1601: }
1602:
1603: sub make_passwd_file {
1604: my ($umode,$npass,$passfilename)=@_;
1605: my $result="ok\n";
1606: if ($umode eq 'krb4' or $umode eq 'krb5') {
1607: {
1608: my $pf = IO::File->new(">$passfilename");
1609: print $pf "$umode:$npass\n";
1610: }
1611: } elsif ($umode eq 'internal') {
1612: my $salt=time;
1613: $salt=substr($salt,6,2);
1614: my $ncpass=crypt($npass,$salt);
1615: {
1616: &Debug("Creating internal auth");
1617: my $pf = IO::File->new(">$passfilename");
1618: print $pf "internal:$ncpass\n";
1619: }
1620: } elsif ($umode eq 'localauth') {
1621: {
1622: my $pf = IO::File->new(">$passfilename");
1623: print $pf "localauth:$npass\n";
1624: }
1625: } elsif ($umode eq 'unix') {
1626: {
1627: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
1628: {
1629: &Debug("Executing external: ".$execpath);
1630: my $se = IO::File->new("|$execpath");
1631: print $se "$uname\n";
1632: print $se "$npass\n";
1633: print $se "$npass\n";
1634: }
1635: my $pf = IO::File->new(">$passfilename");
1636: print $pf "unix:\n";
1637: }
1638: } elsif ($umode eq 'none') {
1639: {
1640: my $pf = IO::File->new(">$passfilename");
1641: print $pf "none:\n";
1642: }
1643: } else {
1644: $result="auth_mode_error\n";
1645: }
1646: return $result;
1647: }
1648:
1649: # ----------------------------------- POD (plain old documentation, CPAN style)
1650:
1651: =head1 NAME
1652:
1653: lond - "LON Daemon" Server (port "LOND" 5663)
1654:
1655: =head1 SYNOPSIS
1656:
1657: Usage: B<lond>
1658:
1659: Should only be run as user=www. This is a command-line script which
1660: is invoked by B<loncron>. There is no expectation that a typical user
1661: will manually start B<lond> from the command-line. (In other words,
1662: DO NOT START B<lond> YOURSELF.)
1663:
1664: =head1 DESCRIPTION
1665:
1666: There are two characteristics associated with the running of B<lond>,
1667: PROCESS MANAGEMENT (starting, stopping, handling child processes)
1668: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
1669: subscriptions, etc). These are described in two large
1670: sections below.
1671:
1672: B<PROCESS MANAGEMENT>
1673:
1674: Preforker - server who forks first. Runs as a daemon. HUPs.
1675: Uses IDEA encryption
1676:
1677: B<lond> forks off children processes that correspond to the other servers
1678: in the network. Management of these processes can be done at the
1679: parent process level or the child process level.
1680:
1681: B<logs/lond.log> is the location of log messages.
1682:
1683: The process management is now explained in terms of linux shell commands,
1684: subroutines internal to this code, and signal assignments:
1685:
1686: =over 4
1687:
1688: =item *
1689:
1690: PID is stored in B<logs/lond.pid>
1691:
1692: This is the process id number of the parent B<lond> process.
1693:
1694: =item *
1695:
1696: SIGTERM and SIGINT
1697:
1698: Parent signal assignment:
1699: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
1700:
1701: Child signal assignment:
1702: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
1703: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
1704: to restart a new child.)
1705:
1706: Command-line invocations:
1707: B<kill> B<-s> SIGTERM I<PID>
1708: B<kill> B<-s> SIGINT I<PID>
1709:
1710: Subroutine B<HUNTSMAN>:
1711: This is only invoked for the B<lond> parent I<PID>.
1712: This kills all the children, and then the parent.
1713: The B<lonc.pid> file is cleared.
1714:
1715: =item *
1716:
1717: SIGHUP
1718:
1719: Current bug:
1720: This signal can only be processed the first time
1721: on the parent process. Subsequent SIGHUP signals
1722: have no effect.
1723:
1724: Parent signal assignment:
1725: $SIG{HUP} = \&HUPSMAN;
1726:
1727: Child signal assignment:
1728: none (nothing happens)
1729:
1730: Command-line invocations:
1731: B<kill> B<-s> SIGHUP I<PID>
1732:
1733: Subroutine B<HUPSMAN>:
1734: This is only invoked for the B<lond> parent I<PID>,
1735: This kills all the children, and then the parent.
1736: The B<lond.pid> file is cleared.
1737:
1738: =item *
1739:
1740: SIGUSR1
1741:
1742: Parent signal assignment:
1743: $SIG{USR1} = \&USRMAN;
1744:
1745: Child signal assignment:
1746: $SIG{USR1}= \&logstatus;
1747:
1748: Command-line invocations:
1749: B<kill> B<-s> SIGUSR1 I<PID>
1750:
1751: Subroutine B<USRMAN>:
1752: When invoked for the B<lond> parent I<PID>,
1753: SIGUSR1 is sent to all the children, and the status of
1754: each connection is logged.
1755:
1756: =item *
1757:
1758: SIGCHLD
1759:
1760: Parent signal assignment:
1761: $SIG{CHLD} = \&REAPER;
1762:
1763: Child signal assignment:
1764: none
1765:
1766: Command-line invocations:
1767: B<kill> B<-s> SIGCHLD I<PID>
1768:
1769: Subroutine B<REAPER>:
1770: This is only invoked for the B<lond> parent I<PID>.
1771: Information pertaining to the child is removed.
1772: The socket port is cleaned up.
1773:
1774: =back
1775:
1776: B<SERVER-SIDE ACTIVITIES>
1777:
1778: Server-side information can be accepted in an encrypted or non-encrypted
1779: method.
1780:
1781: =over 4
1782:
1783: =item ping
1784:
1785: Query a client in the hosts.tab table; "Are you there?"
1786:
1787: =item pong
1788:
1789: Respond to a ping query.
1790:
1791: =item ekey
1792:
1793: Read in encrypted key, make cipher. Respond with a buildkey.
1794:
1795: =item load
1796:
1797: Respond with CPU load based on a computation upon /proc/loadavg.
1798:
1799: =item currentauth
1800:
1801: Reply with current authentication information (only over an
1802: encrypted channel).
1803:
1804: =item auth
1805:
1806: Only over an encrypted channel, reply as to whether a user's
1807: authentication information can be validated.
1808:
1809: =item passwd
1810:
1811: Allow for a password to be set.
1812:
1813: =item makeuser
1814:
1815: Make a user.
1816:
1817: =item passwd
1818:
1819: Allow for authentication mechanism and password to be changed.
1820:
1821: =item home
1822:
1823: Respond to a question "are you the home for a given user?"
1824:
1825: =item update
1826:
1827: Update contents of a subscribed resource.
1828:
1829: =item unsubscribe
1830:
1831: The server is unsubscribing from a resource.
1832:
1833: =item subscribe
1834:
1835: The server is subscribing to a resource.
1836:
1837: =item log
1838:
1839: Place in B<logs/lond.log>
1840:
1841: =item put
1842:
1843: stores hash in namespace
1844:
1845: =item rolesput
1846:
1847: put a role into a user's environment
1848:
1849: =item get
1850:
1851: returns hash with keys from array
1852: reference filled in from namespace
1853:
1854: =item eget
1855:
1856: returns hash with keys from array
1857: reference filled in from namesp (encrypts the return communication)
1858:
1859: =item rolesget
1860:
1861: get a role from a user's environment
1862:
1863: =item del
1864:
1865: deletes keys out of array from namespace
1866:
1867: =item keys
1868:
1869: returns namespace keys
1870:
1871: =item dump
1872:
1873: dumps the complete (or key matching regexp) namespace into a hash
1874:
1875: =item store
1876:
1877: stores hash permanently
1878: for this url; hashref needs to be given and should be a \%hashname; the
1879: remaining args aren't required and if they aren't passed or are '' they will
1880: be derived from the ENV
1881:
1882: =item restore
1883:
1884: returns a hash for a given url
1885:
1886: =item querysend
1887:
1888: Tells client about the lonsql process that has been launched in response
1889: to a sent query.
1890:
1891: =item queryreply
1892:
1893: Accept information from lonsql and make appropriate storage in temporary
1894: file space.
1895:
1896: =item idput
1897:
1898: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
1899: for each student, defined perhaps by the institutional Registrar.)
1900:
1901: =item idget
1902:
1903: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
1904: for each student, defined perhaps by the institutional Registrar.)
1905:
1906: =item tmpput
1907:
1908: Accept and store information in temporary space.
1909:
1910: =item tmpget
1911:
1912: Send along temporarily stored information.
1913:
1914: =item ls
1915:
1916: List part of a user's directory.
1917:
1918: =item Hanging up (exit or init)
1919:
1920: What to do when a client tells the server that they (the client)
1921: are leaving the network.
1922:
1923: =item unknown command
1924:
1925: If B<lond> is sent an unknown command (not in the list above),
1926: it replys to the client "unknown_cmd".
1927:
1928: =item UNKNOWN CLIENT
1929:
1930: If the anti-spoofing algorithm cannot verify the client,
1931: the client is rejected (with a "refused" message sent
1932: to the client, and the connection is closed.
1933:
1934: =back
1935:
1936: =head1 PREREQUISITES
1937:
1938: IO::Socket
1939: IO::File
1940: Apache::File
1941: Symbol
1942: POSIX
1943: Crypt::IDEA
1944: LWP::UserAgent()
1945: GDBM_File
1946: Authen::Krb4
1947: Authen::Krb5
1948:
1949: =head1 COREQUISITES
1950:
1951: =head1 OSNAMES
1952:
1953: linux
1954:
1955: =head1 SCRIPT CATEGORIES
1956:
1957: Server/Process
1958:
1959: =cut
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