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