File:
[LON-CAPA] /
loncom /
lond
Revision
1.140:
download - view:
text,
annotated -
select for diffs
Tue Aug 26 11:15:57 2003 UTC (20 years, 8 months ago) by
foxr
Branches:
MAIN
CVS tags:
HEAD
Added infrastructure for validating management requests... based on
loncapa host id. In the present testing version, a host is authenticated as
a manager if it is a valid member of the cluster. This will, of course, change
soon.
1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
4: #
5: # $Id: lond,v 1.140 2003/08/26 11:15:57 foxr 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/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
35: # 12/05,12/13,12/29 Gerd Kortemeyer
36: # YEAR=2001
37: # 02/12 Gerd Kortemeyer
38: # 03/24 Gerd Kortemeyer
39: # 05/11,05/28,08/30 Gerd Kortemeyer
40: # 11/26,11/27 Gerd Kortemeyer
41: # 12/22 Gerd Kortemeyer
42: # YEAR=2002
43: # 01/20/02,02/05 Gerd Kortemeyer
44: # 02/05 Guy Albertelli
45: # 02/12 Gerd Kortemeyer
46: # 02/19 Matthew Hall
47: # 02/25 Gerd Kortemeyer
48: # 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon
49: # logic simpler (and there were problems maintaining the preforked
50: # population). Since the time averaged connection rate is close to zero
51: # because lonc's purpose is to maintain near continuous connnections,
52: # preforking is not really needed.
53: # 08/xx/2003 Ron Fox: Add management requests. Management requests
54: # will be validated via a call to ValidateManager. At present, this
55: # is done by simple host verification. In the future we can modify
56: # this function to do a certificate check.
57: # Management functions supported include:
58: # - pushing /home/httpd/lonTabs/hosts.tab
59: # - pushing /home/httpd/lonTabs/domain.tab
60: ###
61:
62: use strict;
63: use lib '/home/httpd/lib/perl/';
64: use LONCAPA::Configuration;
65:
66: use IO::Socket;
67: use IO::File;
68: #use Apache::File;
69: use Symbol;
70: use POSIX;
71: use Crypt::IDEA;
72: use LWP::UserAgent();
73: use GDBM_File;
74: use Authen::Krb4;
75: use Authen::Krb5;
76: use lib '/home/httpd/lib/perl/';
77: use localauth;
78:
79: my $DEBUG = 0; # Non zero to enable debug log entries.
80:
81: my $status='';
82: my $lastlog='';
83:
84: my $VERSION='$Revision: 1.140 $'; #' stupid emacs
85: my $remoteVERSION;
86: my $currenthostid;
87: my $currentdomainid;
88:
89: my $client;
90: my $clientip;
91:
92: my $server;
93: my $thisserver;
94:
95: my %hostid;
96: my %hostdom;
97: my %hostip;
98:
99: #
100: # The array below are password error strings."
101: #
102: my $lastpwderror = 13; # Largest error number from lcpasswd.
103: my @passwderrors = ("ok",
104: "lcpasswd must be run as user 'www'",
105: "lcpasswd got incorrect number of arguments",
106: "lcpasswd did not get the right nubmer of input text lines",
107: "lcpasswd too many simultaneous pwd changes in progress",
108: "lcpasswd User does not exist.",
109: "lcpasswd Incorrect current passwd",
110: "lcpasswd Unable to su to root.",
111: "lcpasswd Cannot set new passwd.",
112: "lcpasswd Username has invalid characters",
113: "lcpasswd Invalid characters in password",
114: "11", "12",
115: "lcpasswd Password mismatch");
116:
117:
118: # The array below are lcuseradd error strings.:
119:
120: my $lastadderror = 13;
121: my @adderrors = ("ok",
122: "User ID mismatch, lcuseradd must run as user www",
123: "lcuseradd Incorrect number of command line parameters must be 3",
124: "lcuseradd Incorrect number of stdinput lines, must be 3",
125: "lcuseradd Too many other simultaneous pwd changes in progress",
126: "lcuseradd User does not exist",
127: "lcuseradd Unabel to mak ewww member of users's group",
128: "lcuseradd Unable to su to root",
129: "lcuseradd Unable to set password",
130: "lcuseradd Usrname has invbalid charcters",
131: "lcuseradd Password has an invalid character",
132: "lcuseradd User already exists",
133: "lcuseradd Could not add user.",
134: "lcuseradd Password mismatch");
135:
136:
137: #
138: # GetCertificate: Given a transaction that requires a certificate,
139: # this function will extract the certificate from the transaction
140: # request. Note that at this point, the only concept of a certificate
141: # is the hostname to which we are connected.
142: #
143: # Parameter:
144: # request - The request sent by our client (this parameterization may
145: # need to change when we really use a certificate granting
146: # authority.
147: #
148: sub GetCertificate {
149: my $request = shift;
150:
151: return $clientip;
152: }
153:
154:
155: #
156: # ValidManager: Determines if a given certificate represents a valid manager.
157: # in this primitive implementation, the 'certificate' is
158: # just the connecting loncapa client name. This is checked
159: # against a valid client list in the configuration.
160: #
161: #
162: sub ValidManager {
163: my $certificate = shift;
164:
165: my $hostentry = $hostid{$certificate};
166: if ($hostentry ne undef) {
167: &logthis('<font color="yellow">Authenticating manager'.
168: " $hostentry</font>");
169: return 1;
170: } else {
171: &logthis('<font color="red"> Failed manager authentication '.
172: "$certificate </font>");
173: }
174: }
175: #
176: # Convert an error return code from lcpasswd to a string value.
177: #
178: sub lcpasswdstrerror {
179: my $ErrorCode = shift;
180: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
181: return "lcpasswd Unrecognized error return value ".$ErrorCode;
182: } else {
183: return $passwderrors[$ErrorCode];
184: }
185: }
186:
187: #
188: # Convert an error return code from lcuseradd to a string value:
189: #
190: sub lcuseraddstrerror {
191: my $ErrorCode = shift;
192: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
193: return "lcuseradd - Unrecognized error code: ".$ErrorCode;
194: } else {
195: return $adderrors[$ErrorCode];
196: }
197: }
198:
199: # grabs exception and records it to log before exiting
200: sub catchexception {
201: my ($error)=@_;
202: $SIG{'QUIT'}='DEFAULT';
203: $SIG{__DIE__}='DEFAULT';
204: &logthis("<font color=red>CRITICAL: "
205: ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
206: ."a crash with this error msg->[$error]</font>");
207: &logthis('Famous last words: '.$status.' - '.$lastlog);
208: if ($client) { print $client "error: $error\n"; }
209: $server->close();
210: die($error);
211: }
212:
213: sub timeout {
214: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
215: &catchexception('Timeout');
216: }
217: # -------------------------------- Set signal handlers to record abnormal exits
218:
219: $SIG{'QUIT'}=\&catchexception;
220: $SIG{__DIE__}=\&catchexception;
221:
222: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
223: &status("Read loncapa.conf and loncapa_apache.conf");
224: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
225: my %perlvar=%{$perlvarref};
226: undef $perlvarref;
227:
228: # ----------------------------- Make sure this process is running from user=www
229: my $wwwid=getpwnam('www');
230: if ($wwwid!=$<) {
231: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
232: my $subj="LON: $currenthostid User ID mismatch";
233: system("echo 'User ID mismatch. lond must be run as user www.' |\
234: mailto $emailto -s '$subj' > /dev/null");
235: exit 1;
236: }
237:
238: # --------------------------------------------- Check if other instance running
239:
240: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
241:
242: if (-e $pidfile) {
243: my $lfh=IO::File->new("$pidfile");
244: my $pide=<$lfh>;
245: chomp($pide);
246: if (kill 0 => $pide) { die "already running"; }
247: }
248:
249: # ------------------------------------------------------------- Read hosts file
250:
251: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
252:
253: while (my $configline=<CONFIG>) {
254: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
255: chomp($ip); $ip=~s/\D+$//;
256: $hostid{$ip}=$id;
257: $hostdom{$id}=$domain;
258: $hostip{$id}=$ip;
259: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
260: }
261: close(CONFIG);
262:
263: # establish SERVER socket, bind and listen.
264: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
265: Type => SOCK_STREAM,
266: Proto => 'tcp',
267: Reuse => 1,
268: Listen => 10 )
269: or die "making socket: $@\n";
270:
271: # --------------------------------------------------------- Do global variables
272:
273: # global variables
274:
275: my %children = (); # keys are current child process IDs
276: my $children = 0; # current number of children
277:
278: sub REAPER { # takes care of dead children
279: $SIG{CHLD} = \&REAPER;
280: my $pid = wait;
281: if (defined($children{$pid})) {
282: &logthis("Child $pid died");
283: $children --;
284: delete $children{$pid};
285: } else {
286: &logthis("Unknown Child $pid died");
287: }
288: }
289:
290: sub HUNTSMAN { # signal handler for SIGINT
291: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
292: kill 'INT' => keys %children;
293: &logthis("Free socket: ".shutdown($server,2)); # free up socket
294: my $execdir=$perlvar{'lonDaemons'};
295: unlink("$execdir/logs/lond.pid");
296: &logthis("<font color=red>CRITICAL: Shutting down</font>");
297: exit; # clean up with dignity
298: }
299:
300: sub HUPSMAN { # signal handler for SIGHUP
301: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
302: kill 'INT' => keys %children;
303: &logthis("Free socket: ".shutdown($server,2)); # free up socket
304: &logthis("<font color=red>CRITICAL: Restarting</font>");
305: my $execdir=$perlvar{'lonDaemons'};
306: unlink("$execdir/logs/lond.pid");
307: exec("$execdir/lond"); # here we go again
308: }
309:
310: sub checkchildren {
311: &initnewstatus();
312: &logstatus();
313: &logthis('Going to check on the children');
314: my $docdir=$perlvar{'lonDocRoot'};
315: foreach (sort keys %children) {
316: sleep 1;
317: unless (kill 'USR1' => $_) {
318: &logthis ('Child '.$_.' is dead');
319: &logstatus($$.' is dead');
320: }
321: }
322: sleep 5;
323: $SIG{ALRM} = sub { die "timeout" };
324: $SIG{__DIE__} = 'DEFAULT';
325: foreach (sort keys %children) {
326: unless (-e "$docdir/lon-status/londchld/$_.txt") {
327: eval {
328: alarm(300);
329: &logthis('Child '.$_.' did not respond');
330: kill 9 => $_;
331: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
332: #$subj="LON: $currenthostid killed lond process $_";
333: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
334: #$execdir=$perlvar{'lonDaemons'};
335: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
336: alarm(0);
337: }
338: }
339: }
340: $SIG{ALRM} = 'DEFAULT';
341: $SIG{__DIE__} = \&cathcexception;
342: }
343:
344: # --------------------------------------------------------------------- Logging
345:
346: sub logthis {
347: my $message=shift;
348: my $execdir=$perlvar{'lonDaemons'};
349: my $fh=IO::File->new(">>$execdir/logs/lond.log");
350: my $now=time;
351: my $local=localtime($now);
352: $lastlog=$local.': '.$message;
353: print $fh "$local ($$): $message\n";
354: }
355:
356: # ------------------------- Conditional log if $DEBUG true.
357: sub Debug {
358: my $message = shift;
359: if($DEBUG) {
360: &logthis($message);
361: }
362: }
363: # ------------------------------------------------------------------ Log status
364:
365: sub logstatus {
366: my $docdir=$perlvar{'lonDocRoot'};
367: {
368: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
369: print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
370: $fh->close();
371: }
372: {
373: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
374: print $fh $status."\n".$lastlog."\n".time;
375: $fh->close();
376: }
377: }
378:
379: sub initnewstatus {
380: my $docdir=$perlvar{'lonDocRoot'};
381: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
382: my $now=time;
383: my $local=localtime($now);
384: print $fh "LOND status $local - parent $$\n\n";
385: opendir(DIR,"$docdir/lon-status/londchld");
386: while (my $filename=readdir(DIR)) {
387: unlink("$docdir/lon-status/londchld/$filename");
388: }
389: closedir(DIR);
390: }
391:
392: # -------------------------------------------------------------- Status setting
393:
394: sub status {
395: my $what=shift;
396: my $now=time;
397: my $local=localtime($now);
398: $status=$local.': '.$what;
399: $0='lond: '.$what.' '.$local;
400: }
401:
402: # -------------------------------------------------------- Escape Special Chars
403:
404: sub escape {
405: my $str=shift;
406: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
407: return $str;
408: }
409:
410: # ----------------------------------------------------- Un-Escape Special Chars
411:
412: sub unescape {
413: my $str=shift;
414: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
415: return $str;
416: }
417:
418: # ----------------------------------------------------------- Send USR1 to lonc
419:
420: sub reconlonc {
421: my $peerfile=shift;
422: &logthis("Trying to reconnect for $peerfile");
423: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
424: if (my $fh=IO::File->new("$loncfile")) {
425: my $loncpid=<$fh>;
426: chomp($loncpid);
427: if (kill 0 => $loncpid) {
428: &logthis("lonc at pid $loncpid responding, sending USR1");
429: kill USR1 => $loncpid;
430: } else {
431: &logthis(
432: "<font color=red>CRITICAL: "
433: ."lonc at pid $loncpid not responding, giving up</font>");
434: }
435: } else {
436: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
437: }
438: }
439:
440: # -------------------------------------------------- Non-critical communication
441:
442: sub subreply {
443: my ($cmd,$server)=@_;
444: my $peerfile="$perlvar{'lonSockDir'}/$server";
445: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
446: Type => SOCK_STREAM,
447: Timeout => 10)
448: or return "con_lost";
449: print $sclient "$cmd\n";
450: my $answer=<$sclient>;
451: chomp($answer);
452: if (!$answer) { $answer="con_lost"; }
453: return $answer;
454: }
455:
456: sub reply {
457: my ($cmd,$server)=@_;
458: my $answer;
459: if ($server ne $currenthostid) {
460: $answer=subreply($cmd,$server);
461: if ($answer eq 'con_lost') {
462: $answer=subreply("ping",$server);
463: if ($answer ne $server) {
464: &logthis("sub reply: answer != server answer is $answer, server is $server");
465: &reconlonc("$perlvar{'lonSockDir'}/$server");
466: }
467: $answer=subreply($cmd,$server);
468: }
469: } else {
470: $answer='self_reply';
471: }
472: return $answer;
473: }
474:
475: # -------------------------------------------------------------- Talk to lonsql
476:
477: sub sqlreply {
478: my ($cmd)=@_;
479: my $answer=subsqlreply($cmd);
480: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
481: return $answer;
482: }
483:
484: sub subsqlreply {
485: my ($cmd)=@_;
486: my $unixsock="mysqlsock";
487: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
488: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
489: Type => SOCK_STREAM,
490: Timeout => 10)
491: or return "con_lost";
492: print $sclient "$cmd\n";
493: my $answer=<$sclient>;
494: chomp($answer);
495: if (!$answer) { $answer="con_lost"; }
496: return $answer;
497: }
498:
499: # -------------------------------------------- Return path to profile directory
500:
501: sub propath {
502: my ($udom,$uname)=@_;
503: $udom=~s/\W//g;
504: $uname=~s/\W//g;
505: my $subdir=$uname.'__';
506: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
507: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
508: return $proname;
509: }
510:
511: # --------------------------------------- Is this the home server of an author?
512:
513: sub ishome {
514: my $author=shift;
515: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
516: my ($udom,$uname)=split(/\//,$author);
517: my $proname=propath($udom,$uname);
518: if (-e $proname) {
519: return 'owner';
520: } else {
521: return 'not_owner';
522: }
523: }
524:
525: # ======================================================= Continue main program
526: # ---------------------------------------------------- Fork once and dissociate
527:
528: my $fpid=fork;
529: exit if $fpid;
530: die "Couldn't fork: $!" unless defined ($fpid);
531:
532: POSIX::setsid() or die "Can't start new session: $!";
533:
534: # ------------------------------------------------------- Write our PID on disk
535:
536: my $execdir=$perlvar{'lonDaemons'};
537: open (PIDSAVE,">$execdir/logs/lond.pid");
538: print PIDSAVE "$$\n";
539: close(PIDSAVE);
540: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
541: &status('Starting');
542:
543:
544:
545: # ----------------------------------------------------- Install signal handlers
546:
547:
548: $SIG{CHLD} = \&REAPER;
549: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
550: $SIG{HUP} = \&HUPSMAN;
551: $SIG{USR1} = \&checkchildren;
552:
553:
554:
555: # --------------------------------------------------------------
556: # Accept connections. When a connection comes in, it is validated
557: # and if good, a child process is created to process transactions
558: # along the connection.
559:
560: while (1) {
561: $client = $server->accept() or next;
562: make_new_child($client);
563: }
564:
565: sub make_new_child {
566: my $pid;
567: my $cipher;
568: my $sigset;
569:
570: $client = shift;
571: &logthis("Attempting to start child");
572: # block signal for fork
573: $sigset = POSIX::SigSet->new(SIGINT);
574: sigprocmask(SIG_BLOCK, $sigset)
575: or die "Can't block SIGINT for fork: $!\n";
576:
577: die "fork: $!" unless defined ($pid = fork);
578:
579: if ($pid) {
580: # Parent records the child's birth and returns.
581: sigprocmask(SIG_UNBLOCK, $sigset)
582: or die "Can't unblock SIGINT for fork: $!\n";
583: $children{$pid} = 1;
584: $children++;
585: &status('Started child '.$pid);
586: return;
587: } else {
588: # Child can *not* return from this subroutine.
589: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
590: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
591: #don't get intercepted
592: $SIG{USR1}= \&logstatus;
593: $SIG{ALRM}= \&timeout;
594: $lastlog='Forked ';
595: $status='Forked';
596:
597: # unblock signals
598: sigprocmask(SIG_UNBLOCK, $sigset)
599: or die "Can't unblock SIGINT for fork: $!\n";
600:
601: my $tmpsnum=0;
602: #---------------------------------------------------- kerberos 5 initialization
603: &Authen::Krb5::init_context();
604: &Authen::Krb5::init_ets();
605:
606: &status('Accepted connection');
607: # =============================================================================
608: # do something with the connection
609: # -----------------------------------------------------------------------------
610: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
611: # connection liveness.
612: # see if we know client and check for spoof IP by challenge
613: my $caller = getpeername($client);
614: my ($port,$iaddr)=unpack_sockaddr_in($caller);
615: $clientip=inet_ntoa($iaddr);
616: my $clientrec=($hostid{$clientip} ne undef);
617: &logthis(
618: "<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
619: );
620: &status("Connecting $clientip ($hostid{$clientip})");
621: my $clientok;
622: if ($clientrec) {
623: &status("Waiting for init from $clientip ($hostid{$clientip})");
624: my $remotereq=<$client>;
625: $remotereq=~s/[^\w:]//g;
626: if ($remotereq =~ /^init/) {
627: &sethost("sethost:$perlvar{'lonHostID'}");
628: my $challenge="$$".time;
629: print $client "$challenge\n";
630: &status(
631: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
632: $remotereq=<$client>;
633: $remotereq=~s/\W//g;
634: if ($challenge eq $remotereq) {
635: $clientok=1;
636: print $client "ok\n";
637: } else {
638: &logthis(
639: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
640: &status('No challenge reply '.$clientip);
641: }
642: } else {
643: &logthis(
644: "<font color=blue>WARNING: "
645: ."$clientip failed to initialize: >$remotereq< </font>");
646: &status('No init '.$clientip);
647: }
648: } else {
649: &logthis(
650: "<font color=blue>WARNING: Unknown client $clientip</font>");
651: &status('Hung up on '.$clientip);
652: }
653: if ($clientok) {
654: # ---------------- New known client connecting, could mean machine online again
655:
656: foreach my $id (keys(%hostip)) {
657: if ($hostip{$id} ne $clientip ||
658: $hostip{$currenthostid} eq $clientip) {
659: # no need to try to do recon's to myself
660: next;
661: }
662: &reconlonc("$perlvar{'lonSockDir'}/$id");
663: }
664: &logthis("<font color=green>Established connection: $hostid{$clientip}</font>");
665: &status('Will listen to '.$hostid{$clientip});
666: # ------------------------------------------------------------ Process requests
667: while (my $userinput=<$client>) {
668: chomp($userinput);
669: Debug("Request = $userinput\n");
670: &status('Processing '.$hostid{$clientip}.': '.$userinput);
671: my $wasenc=0;
672: alarm(120);
673: # ------------------------------------------------------------ See if encrypted
674: if ($userinput =~ /^enc/) {
675: if ($cipher) {
676: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
677: $userinput='';
678: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
679: $userinput.=
680: $cipher->decrypt(
681: pack("H16",substr($encinput,$encidx,16))
682: );
683: }
684: $userinput=substr($userinput,0,$cmdlength);
685: $wasenc=1;
686: }
687: }
688:
689: # ------------------------------------------------------------- Normal commands
690: # ------------------------------------------------------------------------ ping
691: if ($userinput =~ /^ping/) {
692: print $client "$currenthostid\n";
693: # ------------------------------------------------------------------------ pong
694: }elsif ($userinput =~ /^pong/) {
695: my $reply=&reply("ping",$hostid{$clientip});
696: print $client "$currenthostid:$reply\n";
697: # ------------------------------------------------------------------------ ekey
698: } elsif ($userinput =~ /^ekey/) {
699: my $buildkey=time.$$.int(rand 100000);
700: $buildkey=~tr/1-6/A-F/;
701: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
702: my $key=$currenthostid.$hostid{$clientip};
703: $key=~tr/a-z/A-Z/;
704: $key=~tr/G-P/0-9/;
705: $key=~tr/Q-Z/0-9/;
706: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
707: $key=substr($key,0,32);
708: my $cipherkey=pack("H32",$key);
709: $cipher=new IDEA $cipherkey;
710: print $client "$buildkey\n";
711: # ------------------------------------------------------------------------ load
712: } elsif ($userinput =~ /^load/) {
713: my $loadavg;
714: {
715: my $loadfile=IO::File->new('/proc/loadavg');
716: $loadavg=<$loadfile>;
717: }
718: $loadavg =~ s/\s.*//g;
719: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
720: print $client "$loadpercent\n";
721: # -------------------------------------------------------------------- userload
722: } elsif ($userinput =~ /^userload/) {
723: my $userloadpercent=&userload();
724: print $client "$userloadpercent\n";
725:
726: #
727: # Transactions requiring encryption:
728: #
729: # ----------------------------------------------------------------- currentauth
730: } elsif ($userinput =~ /^currentauth/) {
731: if ($wasenc==1) {
732: my ($cmd,$udom,$uname)=split(/:/,$userinput);
733: my $result = GetAuthType($udom, $uname);
734: if($result eq "nouser") {
735: print $client "unknown_user\n";
736: }
737: else {
738: print $client "$result\n"
739: }
740: } else {
741: print $client "refused\n";
742: }
743: #--------------------------------------------------------------------- pushfile
744: } elsif($userinput =~ /^pushfile/) {
745: if($wasenc == 1) {
746: my $cert = GetCertificate($userinput);
747: if(ValidManager($cert)) {
748: print $client "ok\n";
749: } else {
750: print $client "refused\n";
751: }
752: } else {
753: print $client "refused\n";
754: }
755: #--------------------------------------------------------------------- reinit
756: } elsif($userinput =~ /^reinit/) {
757: if ($wasenc == 1) {
758: my $cert = GetCertificate($userinput);
759: if(ValidManager($cert)) {
760: print $client "ok\n";
761: } else {
762: print $client "refused\n";
763: }
764: } else {
765: print $client "refused\n";
766: }
767: # ------------------------------------------------------------------------ auth
768: } elsif ($userinput =~ /^auth/) {
769: if ($wasenc==1) {
770: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
771: chomp($upass);
772: $upass=unescape($upass);
773: my $proname=propath($udom,$uname);
774: my $passfilename="$proname/passwd";
775: if (-e $passfilename) {
776: my $pf = IO::File->new($passfilename);
777: my $realpasswd=<$pf>;
778: chomp($realpasswd);
779: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
780: my $pwdcorrect=0;
781: if ($howpwd eq 'internal') {
782: &Debug("Internal auth");
783: $pwdcorrect=
784: (crypt($upass,$contentpwd) eq $contentpwd);
785: } elsif ($howpwd eq 'unix') {
786: &Debug("Unix auth");
787: if((getpwnam($uname))[1] eq "") { #no such user!
788: $pwdcorrect = 0;
789: } else {
790: $contentpwd=(getpwnam($uname))[1];
791: my $pwauth_path="/usr/local/sbin/pwauth";
792: unless ($contentpwd eq 'x') {
793: $pwdcorrect=
794: (crypt($upass,$contentpwd) eq
795: $contentpwd);
796: }
797:
798: elsif (-e $pwauth_path) {
799: open PWAUTH, "|$pwauth_path" or
800: die "Cannot invoke authentication";
801: print PWAUTH "$uname\n$upass\n";
802: close PWAUTH;
803: $pwdcorrect=!$?;
804: }
805: }
806: } elsif ($howpwd eq 'krb4') {
807: my $null=pack("C",0);
808: unless ($upass=~/$null/) {
809: my $krb4_error = &Authen::Krb4::get_pw_in_tkt
810: ($uname,"",$contentpwd,'krbtgt',
811: $contentpwd,1,$upass);
812: if (!$krb4_error) {
813: $pwdcorrect = 1;
814: } else {
815: $pwdcorrect=0;
816: # log error if it is not a bad password
817: if ($krb4_error != 62) {
818: &logthis('krb4:'.$uname.','.$contentpwd.','.
819: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
820: }
821: }
822: }
823: } elsif ($howpwd eq 'krb5') {
824: my $null=pack("C",0);
825: unless ($upass=~/$null/) {
826: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
827: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
828: my $krbserver=&Authen::Krb5::parse_name($krbservice);
829: my $credentials=&Authen::Krb5::cc_default();
830: $credentials->initialize($krbclient);
831: my $krbreturn =
832: &Authen::Krb5::get_in_tkt_with_password(
833: $krbclient,$krbserver,$upass,$credentials);
834: # unless ($krbreturn) {
835: # &logthis("Krb5 Error: ".
836: # &Authen::Krb5::error());
837: # }
838: $pwdcorrect = ($krbreturn == 1);
839: } else { $pwdcorrect=0; }
840: } elsif ($howpwd eq 'localauth') {
841: $pwdcorrect=&localauth::localauth($uname,$upass,
842: $contentpwd);
843: }
844: if ($pwdcorrect) {
845: print $client "authorized\n";
846: } else {
847: print $client "non_authorized\n";
848: }
849: } else {
850: print $client "unknown_user\n";
851: }
852: } else {
853: print $client "refused\n";
854: }
855: # ---------------------------------------------------------------------- passwd
856: } elsif ($userinput =~ /^passwd/) {
857: if ($wasenc==1) {
858: my
859: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
860: chomp($npass);
861: $upass=&unescape($upass);
862: $npass=&unescape($npass);
863: &Debug("Trying to change password for $uname");
864: my $proname=propath($udom,$uname);
865: my $passfilename="$proname/passwd";
866: if (-e $passfilename) {
867: my $realpasswd;
868: { my $pf = IO::File->new($passfilename);
869: $realpasswd=<$pf>; }
870: chomp($realpasswd);
871: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
872: if ($howpwd eq 'internal') {
873: &Debug("internal auth");
874: if (crypt($upass,$contentpwd) eq $contentpwd) {
875: my $salt=time;
876: $salt=substr($salt,6,2);
877: my $ncpass=crypt($npass,$salt);
878: {
879: my $pf;
880: if ($pf = IO::File->new(">$passfilename")) {
881: print $pf "internal:$ncpass\n";
882: &logthis("Result of password change for $uname: pwchange_success");
883: print $client "ok\n";
884: } else {
885: &logthis("Unable to open $uname passwd to change password");
886: print $client "non_authorized\n";
887: }
888: }
889:
890: } else {
891: print $client "non_authorized\n";
892: }
893: } elsif ($howpwd eq 'unix') {
894: # Unix means we have to access /etc/password
895: # one way or another.
896: # First: Make sure the current password is
897: # correct
898: &Debug("auth is unix");
899: $contentpwd=(getpwnam($uname))[1];
900: my $pwdcorrect = "0";
901: my $pwauth_path="/usr/local/sbin/pwauth";
902: unless ($contentpwd eq 'x') {
903: $pwdcorrect=
904: (crypt($upass,$contentpwd) eq $contentpwd);
905: } elsif (-e $pwauth_path) {
906: open PWAUTH, "|$pwauth_path" or
907: die "Cannot invoke authentication";
908: print PWAUTH "$uname\n$upass\n";
909: close PWAUTH;
910: &Debug("exited pwauth with $? ($uname,$upass) ");
911: $pwdcorrect=($? == 0);
912: }
913: if ($pwdcorrect) {
914: my $execdir=$perlvar{'lonDaemons'};
915: &Debug("Opening lcpasswd pipeline");
916: my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
917: print $pf "$uname\n$npass\n$npass\n";
918: close $pf;
919: my $err = $?;
920: my $result = ($err>0 ? 'pwchange_failure'
921: : 'ok');
922: &logthis("Result of password change for $uname: ".
923: &lcpasswdstrerror($?));
924: print $client "$result\n";
925: } else {
926: print $client "non_authorized\n";
927: }
928: } else {
929: print $client "auth_mode_error\n";
930: }
931: } else {
932: print $client "unknown_user\n";
933: }
934: } else {
935: print $client "refused\n";
936: }
937: # -------------------------------------------------------------------- makeuser
938: } elsif ($userinput =~ /^makeuser/) {
939: &Debug("Make user received");
940: my $oldumask=umask(0077);
941: if ($wasenc==1) {
942: my
943: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
944: &Debug("cmd =".$cmd." $udom =".$udom.
945: " uname=".$uname);
946: chomp($npass);
947: $npass=&unescape($npass);
948: my $proname=propath($udom,$uname);
949: my $passfilename="$proname/passwd";
950: &Debug("Password file created will be:".
951: $passfilename);
952: if (-e $passfilename) {
953: print $client "already_exists\n";
954: } elsif ($udom ne $currentdomainid) {
955: print $client "not_right_domain\n";
956: } else {
957: my @fpparts=split(/\//,$proname);
958: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
959: my $fperror='';
960: for (my $i=3;$i<=$#fpparts;$i++) {
961: $fpnow.='/'.$fpparts[$i];
962: unless (-e $fpnow) {
963: unless (mkdir($fpnow,0777)) {
964: $fperror="error: ".($!+0)
965: ." mkdir failed while attempting "
966: ."makeuser\n";
967: }
968: }
969: }
970: unless ($fperror) {
971: my $result=&make_passwd_file($uname, $umode,$npass,
972: $passfilename);
973: print $client $result;
974: } else {
975: print $client "$fperror\n";
976: }
977: }
978: } else {
979: print $client "refused\n";
980: }
981: umask($oldumask);
982: # -------------------------------------------------------------- changeuserauth
983: } elsif ($userinput =~ /^changeuserauth/) {
984: &Debug("Changing authorization");
985: if ($wasenc==1) {
986: my
987: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
988: chomp($npass);
989: &Debug("cmd = ".$cmd." domain= ".$udom.
990: "uname =".$uname." umode= ".$umode);
991: $npass=&unescape($npass);
992: my $proname=&propath($udom,$uname);
993: my $passfilename="$proname/passwd";
994: if ($udom ne $currentdomainid) {
995: print $client "not_right_domain\n";
996: } else {
997: my $result=&make_passwd_file($uname, $umode,$npass,
998: $passfilename);
999: print $client $result;
1000: }
1001: } else {
1002: print $client "refused\n";
1003: }
1004: # ------------------------------------------------------------------------ home
1005: } elsif ($userinput =~ /^home/) {
1006: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1007: chomp($uname);
1008: my $proname=propath($udom,$uname);
1009: if (-e $proname) {
1010: print $client "found\n";
1011: } else {
1012: print $client "not_found\n";
1013: }
1014: # ---------------------------------------------------------------------- update
1015: } elsif ($userinput =~ /^update/) {
1016: my ($cmd,$fname)=split(/:/,$userinput);
1017: my $ownership=ishome($fname);
1018: if ($ownership eq 'not_owner') {
1019: if (-e $fname) {
1020: my ($dev,$ino,$mode,$nlink,
1021: $uid,$gid,$rdev,$size,
1022: $atime,$mtime,$ctime,
1023: $blksize,$blocks)=stat($fname);
1024: my $now=time;
1025: my $since=$now-$atime;
1026: if ($since>$perlvar{'lonExpire'}) {
1027: my $reply=
1028: &reply("unsub:$fname","$hostid{$clientip}");
1029: unlink("$fname");
1030: } else {
1031: my $transname="$fname.in.transfer";
1032: my $remoteurl=
1033: reply("sub:$fname","$hostid{$clientip}");
1034: my $response;
1035: {
1036: my $ua=new LWP::UserAgent;
1037: my $request=new HTTP::Request('GET',"$remoteurl");
1038: $response=$ua->request($request,$transname);
1039: }
1040: if ($response->is_error()) {
1041: unlink($transname);
1042: my $message=$response->status_line;
1043: &logthis(
1044: "LWP GET: $message for $fname ($remoteurl)");
1045: } else {
1046: if ($remoteurl!~/\.meta$/) {
1047: my $ua=new LWP::UserAgent;
1048: my $mrequest=
1049: new HTTP::Request('GET',$remoteurl.'.meta');
1050: my $mresponse=
1051: $ua->request($mrequest,$fname.'.meta');
1052: if ($mresponse->is_error()) {
1053: unlink($fname.'.meta');
1054: }
1055: }
1056: rename($transname,$fname);
1057: }
1058: }
1059: print $client "ok\n";
1060: } else {
1061: print $client "not_found\n";
1062: }
1063: } else {
1064: print $client "rejected\n";
1065: }
1066: # -------------------------------------- fetch a user file from a remote server
1067: } elsif ($userinput =~ /^fetchuserfile/) {
1068: my ($cmd,$fname)=split(/:/,$userinput);
1069: my ($udom,$uname,$ufile)=split(/\//,$fname);
1070: my $udir=propath($udom,$uname).'/userfiles';
1071: unless (-e $udir) { mkdir($udir,0770); }
1072: if (-e $udir) {
1073: $ufile=~s/^[\.\~]+//;
1074: $ufile=~s/\///g;
1075: my $transname=$udir.'/'.$ufile;
1076: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
1077: my $response;
1078: {
1079: my $ua=new LWP::UserAgent;
1080: my $request=new HTTP::Request('GET',"$remoteurl");
1081: $response=$ua->request($request,$transname);
1082: }
1083: if ($response->is_error()) {
1084: unlink($transname);
1085: my $message=$response->status_line;
1086: &logthis(
1087: "LWP GET: $message for $fname ($remoteurl)");
1088: print $client "failed\n";
1089: } else {
1090: print $client "ok\n";
1091: }
1092: } else {
1093: print $client "not_home\n";
1094: }
1095: # ------------------------------------------ authenticate access to a user file
1096: } elsif ($userinput =~ /^tokenauthuserfile/) {
1097: my ($cmd,$fname,$session)=split(/:/,$userinput);
1098: chomp($session);
1099: my $reply='non_auth';
1100: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
1101: $session.'.id')) {
1102: while (my $line=<ENVIN>) {
1103: if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
1104: }
1105: close(ENVIN);
1106: print $client $reply."\n";
1107: } else {
1108: print $client "invalid_token\n";
1109: }
1110: # ----------------------------------------------------------------- unsubscribe
1111: } elsif ($userinput =~ /^unsub/) {
1112: my ($cmd,$fname)=split(/:/,$userinput);
1113: if (-e $fname) {
1114: print $client &unsub($client,$fname,$clientip);
1115: } else {
1116: print $client "not_found\n";
1117: }
1118: # ------------------------------------------------------------------- subscribe
1119: } elsif ($userinput =~ /^sub/) {
1120: print $client &subscribe($userinput,$clientip);
1121: # ------------------------------------------------------------- current version
1122: } elsif ($userinput =~ /^currentversion/) {
1123: my ($cmd,$fname)=split(/:/,$userinput);
1124: print $client ¤tversion($fname)."\n";
1125: # ------------------------------------------------------------------------- log
1126: } elsif ($userinput =~ /^log/) {
1127: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
1128: chomp($what);
1129: my $proname=propath($udom,$uname);
1130: my $now=time;
1131: {
1132: my $hfh;
1133: if ($hfh=IO::File->new(">>$proname/activity.log")) {
1134: print $hfh "$now:$hostid{$clientip}:$what\n";
1135: print $client "ok\n";
1136: } else {
1137: print $client "error: ".($!+0)
1138: ." IO::File->new Failed "
1139: ."while attempting log\n";
1140: }
1141: }
1142: # ------------------------------------------------------------------------- put
1143: } elsif ($userinput =~ /^put/) {
1144: my ($cmd,$udom,$uname,$namespace,$what)
1145: =split(/:/,$userinput);
1146: $namespace=~s/\//\_/g;
1147: $namespace=~s/\W//g;
1148: if ($namespace ne 'roles') {
1149: chomp($what);
1150: my $proname=propath($udom,$uname);
1151: my $now=time;
1152: unless ($namespace=~/^nohist\_/) {
1153: my $hfh;
1154: if (
1155: $hfh=IO::File->new(">>$proname/$namespace.hist")
1156: ) { print $hfh "P:$now:$what\n"; }
1157: }
1158: my @pairs=split(/\&/,$what);
1159: my %hash;
1160: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1161: foreach my $pair (@pairs) {
1162: my ($key,$value)=split(/=/,$pair);
1163: $hash{$key}=$value;
1164: }
1165: if (untie(%hash)) {
1166: print $client "ok\n";
1167: } else {
1168: print $client "error: ".($!+0)
1169: ." untie(GDBM) failed ".
1170: "while attempting put\n";
1171: }
1172: } else {
1173: print $client "error: ".($!)
1174: ." tie(GDBM) Failed ".
1175: "while attempting put\n";
1176: }
1177: } else {
1178: print $client "refused\n";
1179: }
1180: # -------------------------------------------------------------------- rolesput
1181: } elsif ($userinput =~ /^rolesput/) {
1182: &Debug("rolesput");
1183: if ($wasenc==1) {
1184: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1185: =split(/:/,$userinput);
1186: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1187: "user = ".$exeuser." udom=".$udom.
1188: "what = ".$what);
1189: my $namespace='roles';
1190: chomp($what);
1191: my $proname=propath($udom,$uname);
1192: my $now=time;
1193: {
1194: my $hfh;
1195: if (
1196: $hfh=IO::File->new(">>$proname/$namespace.hist")
1197: ) {
1198: print $hfh "P:$now:$exedom:$exeuser:$what\n";
1199: }
1200: }
1201: my @pairs=split(/\&/,$what);
1202: my %hash;
1203: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1204: foreach my $pair (@pairs) {
1205: my ($key,$value)=split(/=/,$pair);
1206: &ManagePermissions($key, $udom, $uname,
1207: &GetAuthType( $udom,
1208: $uname));
1209: $hash{$key}=$value;
1210: }
1211: if (untie(%hash)) {
1212: print $client "ok\n";
1213: } else {
1214: print $client "error: ".($!+0)
1215: ." untie(GDBM) Failed ".
1216: "while attempting rolesput\n";
1217: }
1218: } else {
1219: print $client "error: ".($!+0)
1220: ." tie(GDBM) Failed ".
1221: "while attempting rolesput\n";
1222: }
1223: } else {
1224: print $client "refused\n";
1225: }
1226: # -------------------------------------------------------------------- rolesdel
1227: } elsif ($userinput =~ /^rolesdel/) {
1228: &Debug("rolesdel");
1229: if ($wasenc==1) {
1230: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1231: =split(/:/,$userinput);
1232: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1233: "user = ".$exeuser." udom=".$udom.
1234: "what = ".$what);
1235: my $namespace='roles';
1236: chomp($what);
1237: my $proname=propath($udom,$uname);
1238: my $now=time;
1239: {
1240: my $hfh;
1241: if (
1242: $hfh=IO::File->new(">>$proname/$namespace.hist")
1243: ) {
1244: print $hfh "D:$now:$exedom:$exeuser:$what\n";
1245: }
1246: }
1247: my @rolekeys=split(/\&/,$what);
1248: my %hash;
1249: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1250: foreach my $key (@rolekeys) {
1251: delete $hash{$key};
1252: }
1253: if (untie(%hash)) {
1254: print $client "ok\n";
1255: } else {
1256: print $client "error: ".($!+0)
1257: ." untie(GDBM) Failed ".
1258: "while attempting rolesdel\n";
1259: }
1260: } else {
1261: print $client "error: ".($!+0)
1262: ." tie(GDBM) Failed ".
1263: "while attempting rolesdel\n";
1264: }
1265: } else {
1266: print $client "refused\n";
1267: }
1268: # ------------------------------------------------------------------------- get
1269: } elsif ($userinput =~ /^get/) {
1270: my ($cmd,$udom,$uname,$namespace,$what)
1271: =split(/:/,$userinput);
1272: $namespace=~s/\//\_/g;
1273: $namespace=~s/\W//g;
1274: chomp($what);
1275: my @queries=split(/\&/,$what);
1276: my $proname=propath($udom,$uname);
1277: my $qresult='';
1278: my %hash;
1279: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1280: for (my $i=0;$i<=$#queries;$i++) {
1281: $qresult.="$hash{$queries[$i]}&";
1282: }
1283: if (untie(%hash)) {
1284: $qresult=~s/\&$//;
1285: print $client "$qresult\n";
1286: } else {
1287: print $client "error: ".($!+0)
1288: ." untie(GDBM) Failed ".
1289: "while attempting get\n";
1290: }
1291: } else {
1292: if ($!+0 == 2) {
1293: print $client "error:No such file or ".
1294: "GDBM reported bad block error\n";
1295: } else {
1296: print $client "error: ".($!+0)
1297: ." tie(GDBM) Failed ".
1298: "while attempting get\n";
1299: }
1300: }
1301: # ------------------------------------------------------------------------ eget
1302: } elsif ($userinput =~ /^eget/) {
1303: my ($cmd,$udom,$uname,$namespace,$what)
1304: =split(/:/,$userinput);
1305: $namespace=~s/\//\_/g;
1306: $namespace=~s/\W//g;
1307: chomp($what);
1308: my @queries=split(/\&/,$what);
1309: my $proname=propath($udom,$uname);
1310: my $qresult='';
1311: my %hash;
1312: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1313: for (my $i=0;$i<=$#queries;$i++) {
1314: $qresult.="$hash{$queries[$i]}&";
1315: }
1316: if (untie(%hash)) {
1317: $qresult=~s/\&$//;
1318: if ($cipher) {
1319: my $cmdlength=length($qresult);
1320: $qresult.=" ";
1321: my $encqresult='';
1322: for
1323: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1324: $encqresult.=
1325: unpack("H16",
1326: $cipher->encrypt(substr($qresult,$encidx,8)));
1327: }
1328: print $client "enc:$cmdlength:$encqresult\n";
1329: } else {
1330: print $client "error:no_key\n";
1331: }
1332: } else {
1333: print $client "error: ".($!+0)
1334: ." untie(GDBM) Failed ".
1335: "while attempting eget\n";
1336: }
1337: } else {
1338: print $client "error: ".($!+0)
1339: ." tie(GDBM) Failed ".
1340: "while attempting eget\n";
1341: }
1342: # ------------------------------------------------------------------------- del
1343: } elsif ($userinput =~ /^del/) {
1344: my ($cmd,$udom,$uname,$namespace,$what)
1345: =split(/:/,$userinput);
1346: $namespace=~s/\//\_/g;
1347: $namespace=~s/\W//g;
1348: chomp($what);
1349: my $proname=propath($udom,$uname);
1350: my $now=time;
1351: unless ($namespace=~/^nohist\_/) {
1352: my $hfh;
1353: if (
1354: $hfh=IO::File->new(">>$proname/$namespace.hist")
1355: ) { print $hfh "D:$now:$what\n"; }
1356: }
1357: my @keys=split(/\&/,$what);
1358: my %hash;
1359: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1360: foreach my $key (@keys) {
1361: delete($hash{$key});
1362: }
1363: if (untie(%hash)) {
1364: print $client "ok\n";
1365: } else {
1366: print $client "error: ".($!+0)
1367: ." untie(GDBM) Failed ".
1368: "while attempting del\n";
1369: }
1370: } else {
1371: print $client "error: ".($!+0)
1372: ." tie(GDBM) Failed ".
1373: "while attempting del\n";
1374: }
1375: # ------------------------------------------------------------------------ keys
1376: } elsif ($userinput =~ /^keys/) {
1377: my ($cmd,$udom,$uname,$namespace)
1378: =split(/:/,$userinput);
1379: $namespace=~s/\//\_/g;
1380: $namespace=~s/\W//g;
1381: my $proname=propath($udom,$uname);
1382: my $qresult='';
1383: my %hash;
1384: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1385: foreach my $key (keys %hash) {
1386: $qresult.="$key&";
1387: }
1388: if (untie(%hash)) {
1389: $qresult=~s/\&$//;
1390: print $client "$qresult\n";
1391: } else {
1392: print $client "error: ".($!+0)
1393: ." untie(GDBM) Failed ".
1394: "while attempting keys\n";
1395: }
1396: } else {
1397: print $client "error: ".($!+0)
1398: ." tie(GDBM) Failed ".
1399: "while attempting keys\n";
1400: }
1401: # ----------------------------------------------------------------- dumpcurrent
1402: } elsif ($userinput =~ /^currentdump/) {
1403: my ($cmd,$udom,$uname,$namespace)
1404: =split(/:/,$userinput);
1405: $namespace=~s/\//\_/g;
1406: $namespace=~s/\W//g;
1407: my $qresult='';
1408: my $proname=propath($udom,$uname);
1409: my %hash;
1410: if (tie(%hash,'GDBM_File',
1411: "$proname/$namespace.db",
1412: &GDBM_READER(),0640)) {
1413: # Structure of %data:
1414: # $data{$symb}->{$parameter}=$value;
1415: # $data{$symb}->{'v.'.$parameter}=$version;
1416: # since $parameter will be unescaped, we do not
1417: # have to worry about silly parameter names...
1418: my %data = ();
1419: while (my ($key,$value) = each(%hash)) {
1420: my ($v,$symb,$param) = split(/:/,$key);
1421: next if ($v eq 'version' || $symb eq 'keys');
1422: next if (exists($data{$symb}) &&
1423: exists($data{$symb}->{$param}) &&
1424: $data{$symb}->{'v.'.$param} > $v);
1425: $data{$symb}->{$param}=$value;
1426: $data{$symb}->{'v.'.$param}=$v;
1427: }
1428: if (untie(%hash)) {
1429: while (my ($symb,$param_hash) = each(%data)) {
1430: while(my ($param,$value) = each (%$param_hash)){
1431: next if ($param =~ /^v\./);
1432: $qresult.=$symb.':'.$param.'='.$value.'&';
1433: }
1434: }
1435: chop($qresult);
1436: print $client "$qresult\n";
1437: } else {
1438: print $client "error: ".($!+0)
1439: ." untie(GDBM) Failed ".
1440: "while attempting currentdump\n";
1441: }
1442: } else {
1443: print $client "error: ".($!+0)
1444: ." tie(GDBM) Failed ".
1445: "while attempting currentdump\n";
1446: }
1447: # ------------------------------------------------------------------------ dump
1448: } elsif ($userinput =~ /^dump/) {
1449: my ($cmd,$udom,$uname,$namespace,$regexp)
1450: =split(/:/,$userinput);
1451: $namespace=~s/\//\_/g;
1452: $namespace=~s/\W//g;
1453: if (defined($regexp)) {
1454: $regexp=&unescape($regexp);
1455: } else {
1456: $regexp='.';
1457: }
1458: my $qresult='';
1459: my $proname=propath($udom,$uname);
1460: my %hash;
1461: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1462: study($regexp);
1463: while (my ($key,$value) = each(%hash)) {
1464: if ($regexp eq '.') {
1465: $qresult.=$key.'='.$value.'&';
1466: } else {
1467: my $unescapeKey = &unescape($key);
1468: if (eval('$unescapeKey=~/$regexp/')) {
1469: $qresult.="$key=$value&";
1470: }
1471: }
1472: }
1473: if (untie(%hash)) {
1474: chop($qresult);
1475: print $client "$qresult\n";
1476: } else {
1477: print $client "error: ".($!+0)
1478: ." untie(GDBM) Failed ".
1479: "while attempting dump\n";
1480: }
1481: } else {
1482: print $client "error: ".($!+0)
1483: ." tie(GDBM) Failed ".
1484: "while attempting dump\n";
1485: }
1486: # ----------------------------------------------------------------------- store
1487: } elsif ($userinput =~ /^store/) {
1488: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1489: =split(/:/,$userinput);
1490: $namespace=~s/\//\_/g;
1491: $namespace=~s/\W//g;
1492: if ($namespace ne 'roles') {
1493: chomp($what);
1494: my $proname=propath($udom,$uname);
1495: my $now=time;
1496: unless ($namespace=~/^nohist\_/) {
1497: my $hfh;
1498: if (
1499: $hfh=IO::File->new(">>$proname/$namespace.hist")
1500: ) { print $hfh "P:$now:$rid:$what\n"; }
1501: }
1502: my @pairs=split(/\&/,$what);
1503: my %hash;
1504: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1505: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1506: my $key;
1507: $hash{"version:$rid"}++;
1508: my $version=$hash{"version:$rid"};
1509: my $allkeys='';
1510: foreach my $pair (@pairs) {
1511: my ($key,$value)=split(/=/,$pair);
1512: $allkeys.=$key.':';
1513: $hash{"$version:$rid:$key"}=$value;
1514: }
1515: $hash{"$version:$rid:timestamp"}=$now;
1516: $allkeys.='timestamp';
1517: $hash{"$version:keys:$rid"}=$allkeys;
1518: if (untie(%hash)) {
1519: print $client "ok\n";
1520: } else {
1521: print $client "error: ".($!+0)
1522: ." untie(GDBM) Failed ".
1523: "while attempting store\n";
1524: }
1525: } else {
1526: print $client "error: ".($!+0)
1527: ." tie(GDBM) Failed ".
1528: "while attempting store\n";
1529: }
1530: } else {
1531: print $client "refused\n";
1532: }
1533: # --------------------------------------------------------------------- restore
1534: } elsif ($userinput =~ /^restore/) {
1535: my ($cmd,$udom,$uname,$namespace,$rid)
1536: =split(/:/,$userinput);
1537: $namespace=~s/\//\_/g;
1538: $namespace=~s/\W//g;
1539: chomp($rid);
1540: my $proname=propath($udom,$uname);
1541: my $qresult='';
1542: my %hash;
1543: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1544: my $version=$hash{"version:$rid"};
1545: $qresult.="version=$version&";
1546: my $scope;
1547: for ($scope=1;$scope<=$version;$scope++) {
1548: my $vkeys=$hash{"$scope:keys:$rid"};
1549: my @keys=split(/:/,$vkeys);
1550: my $key;
1551: $qresult.="$scope:keys=$vkeys&";
1552: foreach $key (@keys) {
1553: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1554: }
1555: }
1556: if (untie(%hash)) {
1557: $qresult=~s/\&$//;
1558: print $client "$qresult\n";
1559: } else {
1560: print $client "error: ".($!+0)
1561: ." untie(GDBM) Failed ".
1562: "while attempting restore\n";
1563: }
1564: } else {
1565: print $client "error: ".($!+0)
1566: ." tie(GDBM) Failed ".
1567: "while attempting restore\n";
1568: }
1569: # -------------------------------------------------------------------- chatsend
1570: } elsif ($userinput =~ /^chatsend/) {
1571: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
1572: &chatadd($cdom,$cnum,$newpost);
1573: print $client "ok\n";
1574: # -------------------------------------------------------------------- chatretr
1575: } elsif ($userinput =~ /^chatretr/) {
1576: my
1577: ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
1578: my $reply='';
1579: foreach (&getchat($cdom,$cnum,$udom,$uname)) {
1580: $reply.=&escape($_).':';
1581: }
1582: $reply=~s/\:$//;
1583: print $client $reply."\n";
1584: # ------------------------------------------------------------------- querysend
1585: } elsif ($userinput =~ /^querysend/) {
1586: my ($cmd,$query,
1587: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
1588: $query=~s/\n*$//g;
1589: print $client "".
1590: sqlreply("$hostid{$clientip}\&$query".
1591: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
1592: # ------------------------------------------------------------------ queryreply
1593: } elsif ($userinput =~ /^queryreply/) {
1594: my ($cmd,$id,$reply)=split(/:/,$userinput);
1595: my $store;
1596: my $execdir=$perlvar{'lonDaemons'};
1597: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1598: $reply=~s/\&/\n/g;
1599: print $store $reply;
1600: close $store;
1601: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1602: print $store2 "done\n";
1603: close $store2;
1604: print $client "ok\n";
1605: }
1606: else {
1607: print $client "error: ".($!+0)
1608: ." IO::File->new Failed ".
1609: "while attempting queryreply\n";
1610: }
1611: # ----------------------------------------------------------------- courseidput
1612: } elsif ($userinput =~ /^courseidput/) {
1613: my ($cmd,$udom,$what)=split(/:/,$userinput);
1614: chomp($what);
1615: $udom=~s/\W//g;
1616: my $proname=
1617: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
1618: my $now=time;
1619: my @pairs=split(/\&/,$what);
1620: my %hash;
1621: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1622: foreach my $pair (@pairs) {
1623: my ($key,$value)=split(/=/,$pair);
1624: $hash{$key}=$value.':'.$now;
1625: }
1626: if (untie(%hash)) {
1627: print $client "ok\n";
1628: } else {
1629: print $client "error: ".($!+0)
1630: ." untie(GDBM) Failed ".
1631: "while attempting courseidput\n";
1632: }
1633: } else {
1634: print $client "error: ".($!+0)
1635: ." tie(GDBM) Failed ".
1636: "while attempting courseidput\n";
1637: }
1638: # ---------------------------------------------------------------- courseiddump
1639: } elsif ($userinput =~ /^courseiddump/) {
1640: my ($cmd,$udom,$since,$description)
1641: =split(/:/,$userinput);
1642: if (defined($description)) {
1643: $description=&unescape($description);
1644: } else {
1645: $description='.';
1646: }
1647: unless (defined($since)) { $since=0; }
1648: my $qresult='';
1649: my $proname=
1650: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
1651: my %hash;
1652: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1653: while (my ($key,$value) = each(%hash)) {
1654: my ($descr,$lasttime)=split(/\:/,$value);
1655: if ($lasttime<$since) { next; }
1656: if ($description eq '.') {
1657: $qresult.=$key.'='.$descr.'&';
1658: } else {
1659: my $unescapeVal = &unescape($descr);
1660: if (eval('$unescapeVal=~/$description/i')) {
1661: $qresult.="$key=$descr&";
1662: }
1663: }
1664: }
1665: if (untie(%hash)) {
1666: chop($qresult);
1667: print $client "$qresult\n";
1668: } else {
1669: print $client "error: ".($!+0)
1670: ." untie(GDBM) Failed ".
1671: "while attempting courseiddump\n";
1672: }
1673: } else {
1674: print $client "error: ".($!+0)
1675: ." tie(GDBM) Failed ".
1676: "while attempting courseiddump\n";
1677: }
1678: # ----------------------------------------------------------------------- idput
1679: } elsif ($userinput =~ /^idput/) {
1680: my ($cmd,$udom,$what)=split(/:/,$userinput);
1681: chomp($what);
1682: $udom=~s/\W//g;
1683: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1684: my $now=time;
1685: {
1686: my $hfh;
1687: if (
1688: $hfh=IO::File->new(">>$proname.hist")
1689: ) { print $hfh "P:$now:$what\n"; }
1690: }
1691: my @pairs=split(/\&/,$what);
1692: my %hash;
1693: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1694: foreach my $pair (@pairs) {
1695: my ($key,$value)=split(/=/,$pair);
1696: $hash{$key}=$value;
1697: }
1698: if (untie(%hash)) {
1699: print $client "ok\n";
1700: } else {
1701: print $client "error: ".($!+0)
1702: ." untie(GDBM) Failed ".
1703: "while attempting idput\n";
1704: }
1705: } else {
1706: print $client "error: ".($!+0)
1707: ." tie(GDBM) Failed ".
1708: "while attempting idput\n";
1709: }
1710: # ----------------------------------------------------------------------- idget
1711: } elsif ($userinput =~ /^idget/) {
1712: my ($cmd,$udom,$what)=split(/:/,$userinput);
1713: chomp($what);
1714: $udom=~s/\W//g;
1715: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1716: my @queries=split(/\&/,$what);
1717: my $qresult='';
1718: my %hash;
1719: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1720: for (my $i=0;$i<=$#queries;$i++) {
1721: $qresult.="$hash{$queries[$i]}&";
1722: }
1723: if (untie(%hash)) {
1724: $qresult=~s/\&$//;
1725: print $client "$qresult\n";
1726: } else {
1727: print $client "error: ".($!+0)
1728: ." untie(GDBM) Failed ".
1729: "while attempting idget\n";
1730: }
1731: } else {
1732: print $client "error: ".($!+0)
1733: ." tie(GDBM) Failed ".
1734: "while attempting idget\n";
1735: }
1736: # ---------------------------------------------------------------------- tmpput
1737: } elsif ($userinput =~ /^tmpput/) {
1738: my ($cmd,$what)=split(/:/,$userinput);
1739: my $store;
1740: $tmpsnum++;
1741: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1742: $id=~s/\W/\_/g;
1743: $what=~s/\n//g;
1744: my $execdir=$perlvar{'lonDaemons'};
1745: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1746: print $store $what;
1747: close $store;
1748: print $client "$id\n";
1749: }
1750: else {
1751: print $client "error: ".($!+0)
1752: ."IO::File->new Failed ".
1753: "while attempting tmpput\n";
1754: }
1755:
1756: # ---------------------------------------------------------------------- tmpget
1757: } elsif ($userinput =~ /^tmpget/) {
1758: my ($cmd,$id)=split(/:/,$userinput);
1759: chomp($id);
1760: $id=~s/\W/\_/g;
1761: my $store;
1762: my $execdir=$perlvar{'lonDaemons'};
1763: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
1764: my $reply=<$store>;
1765: print $client "$reply\n";
1766: close $store;
1767: }
1768: else {
1769: print $client "error: ".($!+0)
1770: ."IO::File->new Failed ".
1771: "while attempting tmpget\n";
1772: }
1773:
1774: # ---------------------------------------------------------------------- tmpdel
1775: } elsif ($userinput =~ /^tmpdel/) {
1776: my ($cmd,$id)=split(/:/,$userinput);
1777: chomp($id);
1778: $id=~s/\W/\_/g;
1779: my $execdir=$perlvar{'lonDaemons'};
1780: if (unlink("$execdir/tmp/$id.tmp")) {
1781: print $client "ok\n";
1782: } else {
1783: print $client "error: ".($!+0)
1784: ."Unlink tmp Failed ".
1785: "while attempting tmpdel\n";
1786: }
1787: # -------------------------------------------------------------------------- ls
1788: } elsif ($userinput =~ /^ls/) {
1789: my ($cmd,$ulsdir)=split(/:/,$userinput);
1790: my $ulsout='';
1791: my $ulsfn;
1792: if (-e $ulsdir) {
1793: if(-d $ulsdir) {
1794: if (opendir(LSDIR,$ulsdir)) {
1795: while ($ulsfn=readdir(LSDIR)) {
1796: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1797: $ulsout.=$ulsfn.'&'.
1798: join('&',@ulsstats).':';
1799: }
1800: closedir(LSDIR);
1801: }
1802: } else {
1803: my @ulsstats=stat($ulsdir);
1804: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1805: }
1806: } else {
1807: $ulsout='no_such_dir';
1808: }
1809: if ($ulsout eq '') { $ulsout='empty'; }
1810: print $client "$ulsout\n";
1811: # ----------------------------------------------------------------- setannounce
1812: } elsif ($userinput =~ /^setannounce/) {
1813: my ($cmd,$announcement)=split(/:/,$userinput);
1814: chomp($announcement);
1815: $announcement=&unescape($announcement);
1816: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
1817: '/announcement.txt')) {
1818: print $store $announcement;
1819: close $store;
1820: print $client "ok\n";
1821: } else {
1822: print $client "error: ".($!+0)."\n";
1823: }
1824: # ------------------------------------------------------------------ Hanging up
1825: } elsif (($userinput =~ /^exit/) ||
1826: ($userinput =~ /^init/)) {
1827: &logthis(
1828: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1829: print $client "bye\n";
1830: $client->close();
1831: last;
1832: # ------------------------------------------------------------- unknown command
1833: } elsif ($userinput =~ /^sethost:/) {
1834: print $client &sethost($userinput)."\n";
1835: } elsif ($userinput =~/^version:/) {
1836: print $client &version($userinput)."\n";
1837: } else {
1838: # unknown command
1839: print $client "unknown_cmd\n";
1840: }
1841: # -------------------------------------------------------------------- complete
1842: alarm(0);
1843: &status('Listening to '.$hostid{$clientip});
1844: }
1845: # --------------------------------------------- client unknown or fishy, refuse
1846: } else {
1847: print $client "refused\n";
1848: $client->close();
1849: &logthis("<font color=blue>WARNING: "
1850: ."Rejected client $clientip, closing connection</font>");
1851: }
1852: }
1853:
1854: # =============================================================================
1855:
1856: &logthis("<font color=red>CRITICAL: "
1857: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1858:
1859:
1860: # this exit is VERY important, otherwise the child will become
1861: # a producer of more and more children, forking yourself into
1862: # process death.
1863: exit;
1864:
1865: }
1866:
1867:
1868: #
1869: # Checks to see if the input roleput request was to set
1870: # an author role. If so, invokes the lchtmldir script to set
1871: # up a correct public_html
1872: # Parameters:
1873: # request - The request sent to the rolesput subchunk.
1874: # We're looking for /domain/_au
1875: # domain - The domain in which the user is having roles doctored.
1876: # user - Name of the user for which the role is being put.
1877: # authtype - The authentication type associated with the user.
1878: #
1879: sub ManagePermissions
1880: {
1881: my $request = shift;
1882: my $domain = shift;
1883: my $user = shift;
1884: my $authtype= shift;
1885:
1886: # See if the request is of the form /$domain/_au
1887: &logthis("ruequest is $request");
1888: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
1889: my $execdir = $perlvar{'lonDaemons'};
1890: my $userhome= "/home/$user" ;
1891: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1892: system("$execdir/lchtmldir $userhome $user $authtype");
1893: }
1894: }
1895: #
1896: # GetAuthType - Determines the authorization type of a user in a domain.
1897:
1898: # Returns the authorization type or nouser if there is no such user.
1899: #
1900: sub GetAuthType
1901: {
1902: my $domain = shift;
1903: my $user = shift;
1904:
1905: Debug("GetAuthType( $domain, $user ) \n");
1906: my $proname = &propath($domain, $user);
1907: my $passwdfile = "$proname/passwd";
1908: if( -e $passwdfile ) {
1909: my $pf = IO::File->new($passwdfile);
1910: my $realpassword = <$pf>;
1911: chomp($realpassword);
1912: Debug("Password info = $realpassword\n");
1913: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1914: Debug("Authtype = $authtype, content = $contentpwd\n");
1915: my $availinfo = '';
1916: if($authtype eq 'krb4' or $authtype eq 'krb5') {
1917: $availinfo = $contentpwd;
1918: }
1919:
1920: return "$authtype:$availinfo";
1921: }
1922: else {
1923: Debug("Returning nouser");
1924: return "nouser";
1925: }
1926: }
1927:
1928: sub addline {
1929: my ($fname,$hostid,$ip,$newline)=@_;
1930: my $contents;
1931: my $found=0;
1932: my $expr='^'.$hostid.':'.$ip.':';
1933: $expr =~ s/\./\\\./g;
1934: my $sh;
1935: if ($sh=IO::File->new("$fname.subscription")) {
1936: while (my $subline=<$sh>) {
1937: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
1938: }
1939: $sh->close();
1940: }
1941: $sh=IO::File->new(">$fname.subscription");
1942: if ($contents) { print $sh $contents; }
1943: if ($newline) { print $sh $newline; }
1944: $sh->close();
1945: return $found;
1946: }
1947:
1948: sub getchat {
1949: my ($cdom,$cname,$udom,$uname)=@_;
1950: my %hash;
1951: my $proname=&propath($cdom,$cname);
1952: my @entries=();
1953: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1954: &GDBM_READER(),0640)) {
1955: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1956: untie %hash;
1957: }
1958: my @participants=();
1959: my $cutoff=time-60;
1960: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1961: &GDBM_WRCREAT(),0640)) {
1962: $hash{$uname.':'.$udom}=time;
1963: foreach (sort keys %hash) {
1964: if ($hash{$_}>$cutoff) {
1965: $participants[$#participants+1]='active_participant:'.$_;
1966: }
1967: }
1968: untie %hash;
1969: }
1970: return (@participants,@entries);
1971: }
1972:
1973: sub chatadd {
1974: my ($cdom,$cname,$newchat)=@_;
1975: my %hash;
1976: my $proname=&propath($cdom,$cname);
1977: my @entries=();
1978: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1979: &GDBM_WRCREAT(),0640)) {
1980: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1981: my $time=time;
1982: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
1983: my ($thentime,$idnum)=split(/\_/,$lastid);
1984: my $newid=$time.'_000000';
1985: if ($thentime==$time) {
1986: $idnum=~s/^0+//;
1987: $idnum++;
1988: $idnum=substr('000000'.$idnum,-6,6);
1989: $newid=$time.'_'.$idnum;
1990: }
1991: $hash{$newid}=$newchat;
1992: my $expired=$time-3600;
1993: foreach (keys %hash) {
1994: my ($thistime)=($_=~/(\d+)\_/);
1995: if ($thistime<$expired) {
1996: delete $hash{$_};
1997: }
1998: }
1999: untie %hash;
2000: }
2001: }
2002:
2003: sub unsub {
2004: my ($fname,$clientip)=@_;
2005: my $result;
2006: if (unlink("$fname.$hostid{$clientip}")) {
2007: $result="ok\n";
2008: } else {
2009: $result="not_subscribed\n";
2010: }
2011: if (-e "$fname.subscription") {
2012: my $found=&addline($fname,$hostid{$clientip},$clientip,'');
2013: if ($found) { $result="ok\n"; }
2014: } else {
2015: if ($result != "ok\n") { $result="not_subscribed\n"; }
2016: }
2017: return $result;
2018: }
2019:
2020: sub currentversion {
2021: my $fname=shift;
2022: my $version=-1;
2023: my $ulsdir='';
2024: if ($fname=~/^(.+)\/[^\/]+$/) {
2025: $ulsdir=$1;
2026: }
2027: my ($fnamere1,$fnamere2);
2028: # remove version if already specified
2029: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
2030: # get the bits that go before and after the version number
2031: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
2032: $fnamere1=$1;
2033: $fnamere2='.'.$2;
2034: }
2035: if (-e $fname) { $version=1; }
2036: if (-e $ulsdir) {
2037: if(-d $ulsdir) {
2038: if (opendir(LSDIR,$ulsdir)) {
2039: my $ulsfn;
2040: while ($ulsfn=readdir(LSDIR)) {
2041: # see if this is a regular file (ignore links produced earlier)
2042: my $thisfile=$ulsdir.'/'.$ulsfn;
2043: unless (-l $thisfile) {
2044: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
2045: if ($1>$version) { $version=$1; }
2046: }
2047: }
2048: }
2049: closedir(LSDIR);
2050: $version++;
2051: }
2052: }
2053: }
2054: return $version;
2055: }
2056:
2057: sub thisversion {
2058: my $fname=shift;
2059: my $version=-1;
2060: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
2061: $version=$1;
2062: }
2063: return $version;
2064: }
2065:
2066: sub subscribe {
2067: my ($userinput,$clientip)=@_;
2068: my $result;
2069: my ($cmd,$fname)=split(/:/,$userinput);
2070: my $ownership=&ishome($fname);
2071: if ($ownership eq 'owner') {
2072: # explitly asking for the current version?
2073: unless (-e $fname) {
2074: my $currentversion=¤tversion($fname);
2075: if (&thisversion($fname)==$currentversion) {
2076: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
2077: my $root=$1;
2078: my $extension=$2;
2079: symlink($root.'.'.$extension,
2080: $root.'.'.$currentversion.'.'.$extension);
2081: unless ($extension=~/\.meta$/) {
2082: symlink($root.'.'.$extension.'.meta',
2083: $root.'.'.$currentversion.'.'.$extension.'.meta');
2084: }
2085: }
2086: }
2087: }
2088: if (-e $fname) {
2089: if (-d $fname) {
2090: $result="directory\n";
2091: } else {
2092: if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
2093: my $now=time;
2094: my $found=&addline($fname,$hostid{$clientip},$clientip,
2095: "$hostid{$clientip}:$clientip:$now\n");
2096: if ($found) { $result="$fname\n"; }
2097: # if they were subscribed to only meta data, delete that
2098: # subscription, when you subscribe to a file you also get
2099: # the metadata
2100: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
2101: $fname=~s/\/home\/httpd\/html\/res/raw/;
2102: $fname="http://$thisserver/".$fname;
2103: $result="$fname\n";
2104: }
2105: } else {
2106: $result="not_found\n";
2107: }
2108: } else {
2109: $result="rejected\n";
2110: }
2111: return $result;
2112: }
2113:
2114: sub make_passwd_file {
2115: my ($uname, $umode,$npass,$passfilename)=@_;
2116: my $result="ok\n";
2117: if ($umode eq 'krb4' or $umode eq 'krb5') {
2118: {
2119: my $pf = IO::File->new(">$passfilename");
2120: print $pf "$umode:$npass\n";
2121: }
2122: } elsif ($umode eq 'internal') {
2123: my $salt=time;
2124: $salt=substr($salt,6,2);
2125: my $ncpass=crypt($npass,$salt);
2126: {
2127: &Debug("Creating internal auth");
2128: my $pf = IO::File->new(">$passfilename");
2129: print $pf "internal:$ncpass\n";
2130: }
2131: } elsif ($umode eq 'localauth') {
2132: {
2133: my $pf = IO::File->new(">$passfilename");
2134: print $pf "localauth:$npass\n";
2135: }
2136: } elsif ($umode eq 'unix') {
2137: {
2138: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
2139: {
2140: &Debug("Executing external: ".$execpath);
2141: &Debug("user = ".$uname.", Password =". $npass);
2142: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
2143: print $se "$uname\n";
2144: print $se "$npass\n";
2145: print $se "$npass\n";
2146: }
2147: my $useraddok = $?;
2148: if($useraddok > 0) {
2149: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
2150: }
2151: my $pf = IO::File->new(">$passfilename");
2152: print $pf "unix:\n";
2153: }
2154: } elsif ($umode eq 'none') {
2155: {
2156: my $pf = IO::File->new(">$passfilename");
2157: print $pf "none:\n";
2158: }
2159: } else {
2160: $result="auth_mode_error\n";
2161: }
2162: return $result;
2163: }
2164:
2165: sub sethost {
2166: my ($remotereq) = @_;
2167: my (undef,$hostid)=split(/:/,$remotereq);
2168: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
2169: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
2170: $currenthostid=$hostid;
2171: $currentdomainid=$hostdom{$hostid};
2172: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
2173: } else {
2174: &logthis("Requested host id $hostid not an alias of ".
2175: $perlvar{'lonHostID'}." refusing connection");
2176: return 'unable_to_set';
2177: }
2178: return 'ok';
2179: }
2180:
2181: sub version {
2182: my ($userinput)=@_;
2183: $remoteVERSION=(split(/:/,$userinput))[1];
2184: return "version:$VERSION";
2185: }
2186:
2187: #There is a copy of this in lonnet.pm
2188: sub userload {
2189: my $numusers=0;
2190: {
2191: opendir(LONIDS,$perlvar{'lonIDsDir'});
2192: my $filename;
2193: my $curtime=time;
2194: while ($filename=readdir(LONIDS)) {
2195: if ($filename eq '.' || $filename eq '..') {next;}
2196: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
2197: if ($curtime-$mtime < 3600) { $numusers++; }
2198: }
2199: closedir(LONIDS);
2200: }
2201: my $userloadpercent=0;
2202: my $maxuserload=$perlvar{'lonUserLoadLim'};
2203: if ($maxuserload) {
2204: $userloadpercent=100*$numusers/$maxuserload;
2205: }
2206: $userloadpercent=sprintf("%.2f",$userloadpercent);
2207: return $userloadpercent;
2208: }
2209:
2210: # ----------------------------------- POD (plain old documentation, CPAN style)
2211:
2212: =head1 NAME
2213:
2214: lond - "LON Daemon" Server (port "LOND" 5663)
2215:
2216: =head1 SYNOPSIS
2217:
2218: Usage: B<lond>
2219:
2220: Should only be run as user=www. This is a command-line script which
2221: is invoked by B<loncron>. There is no expectation that a typical user
2222: will manually start B<lond> from the command-line. (In other words,
2223: DO NOT START B<lond> YOURSELF.)
2224:
2225: =head1 DESCRIPTION
2226:
2227: There are two characteristics associated with the running of B<lond>,
2228: PROCESS MANAGEMENT (starting, stopping, handling child processes)
2229: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
2230: subscriptions, etc). These are described in two large
2231: sections below.
2232:
2233: B<PROCESS MANAGEMENT>
2234:
2235: Preforker - server who forks first. Runs as a daemon. HUPs.
2236: Uses IDEA encryption
2237:
2238: B<lond> forks off children processes that correspond to the other servers
2239: in the network. Management of these processes can be done at the
2240: parent process level or the child process level.
2241:
2242: B<logs/lond.log> is the location of log messages.
2243:
2244: The process management is now explained in terms of linux shell commands,
2245: subroutines internal to this code, and signal assignments:
2246:
2247: =over 4
2248:
2249: =item *
2250:
2251: PID is stored in B<logs/lond.pid>
2252:
2253: This is the process id number of the parent B<lond> process.
2254:
2255: =item *
2256:
2257: SIGTERM and SIGINT
2258:
2259: Parent signal assignment:
2260: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
2261:
2262: Child signal assignment:
2263: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
2264: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
2265: to restart a new child.)
2266:
2267: Command-line invocations:
2268: B<kill> B<-s> SIGTERM I<PID>
2269: B<kill> B<-s> SIGINT I<PID>
2270:
2271: Subroutine B<HUNTSMAN>:
2272: This is only invoked for the B<lond> parent I<PID>.
2273: This kills all the children, and then the parent.
2274: The B<lonc.pid> file is cleared.
2275:
2276: =item *
2277:
2278: SIGHUP
2279:
2280: Current bug:
2281: This signal can only be processed the first time
2282: on the parent process. Subsequent SIGHUP signals
2283: have no effect.
2284:
2285: Parent signal assignment:
2286: $SIG{HUP} = \&HUPSMAN;
2287:
2288: Child signal assignment:
2289: none (nothing happens)
2290:
2291: Command-line invocations:
2292: B<kill> B<-s> SIGHUP I<PID>
2293:
2294: Subroutine B<HUPSMAN>:
2295: This is only invoked for the B<lond> parent I<PID>,
2296: This kills all the children, and then the parent.
2297: The B<lond.pid> file is cleared.
2298:
2299: =item *
2300:
2301: SIGUSR1
2302:
2303: Parent signal assignment:
2304: $SIG{USR1} = \&USRMAN;
2305:
2306: Child signal assignment:
2307: $SIG{USR1}= \&logstatus;
2308:
2309: Command-line invocations:
2310: B<kill> B<-s> SIGUSR1 I<PID>
2311:
2312: Subroutine B<USRMAN>:
2313: When invoked for the B<lond> parent I<PID>,
2314: SIGUSR1 is sent to all the children, and the status of
2315: each connection is logged.
2316:
2317: =item *
2318:
2319: SIGCHLD
2320:
2321: Parent signal assignment:
2322: $SIG{CHLD} = \&REAPER;
2323:
2324: Child signal assignment:
2325: none
2326:
2327: Command-line invocations:
2328: B<kill> B<-s> SIGCHLD I<PID>
2329:
2330: Subroutine B<REAPER>:
2331: This is only invoked for the B<lond> parent I<PID>.
2332: Information pertaining to the child is removed.
2333: The socket port is cleaned up.
2334:
2335: =back
2336:
2337: B<SERVER-SIDE ACTIVITIES>
2338:
2339: Server-side information can be accepted in an encrypted or non-encrypted
2340: method.
2341:
2342: =over 4
2343:
2344: =item ping
2345:
2346: Query a client in the hosts.tab table; "Are you there?"
2347:
2348: =item pong
2349:
2350: Respond to a ping query.
2351:
2352: =item ekey
2353:
2354: Read in encrypted key, make cipher. Respond with a buildkey.
2355:
2356: =item load
2357:
2358: Respond with CPU load based on a computation upon /proc/loadavg.
2359:
2360: =item currentauth
2361:
2362: Reply with current authentication information (only over an
2363: encrypted channel).
2364:
2365: =item auth
2366:
2367: Only over an encrypted channel, reply as to whether a user's
2368: authentication information can be validated.
2369:
2370: =item passwd
2371:
2372: Allow for a password to be set.
2373:
2374: =item makeuser
2375:
2376: Make a user.
2377:
2378: =item passwd
2379:
2380: Allow for authentication mechanism and password to be changed.
2381:
2382: =item home
2383:
2384: Respond to a question "are you the home for a given user?"
2385:
2386: =item update
2387:
2388: Update contents of a subscribed resource.
2389:
2390: =item unsubscribe
2391:
2392: The server is unsubscribing from a resource.
2393:
2394: =item subscribe
2395:
2396: The server is subscribing to a resource.
2397:
2398: =item log
2399:
2400: Place in B<logs/lond.log>
2401:
2402: =item put
2403:
2404: stores hash in namespace
2405:
2406: =item rolesput
2407:
2408: put a role into a user's environment
2409:
2410: =item get
2411:
2412: returns hash with keys from array
2413: reference filled in from namespace
2414:
2415: =item eget
2416:
2417: returns hash with keys from array
2418: reference filled in from namesp (encrypts the return communication)
2419:
2420: =item rolesget
2421:
2422: get a role from a user's environment
2423:
2424: =item del
2425:
2426: deletes keys out of array from namespace
2427:
2428: =item keys
2429:
2430: returns namespace keys
2431:
2432: =item dump
2433:
2434: dumps the complete (or key matching regexp) namespace into a hash
2435:
2436: =item store
2437:
2438: stores hash permanently
2439: for this url; hashref needs to be given and should be a \%hashname; the
2440: remaining args aren't required and if they aren't passed or are '' they will
2441: be derived from the ENV
2442:
2443: =item restore
2444:
2445: returns a hash for a given url
2446:
2447: =item querysend
2448:
2449: Tells client about the lonsql process that has been launched in response
2450: to a sent query.
2451:
2452: =item queryreply
2453:
2454: Accept information from lonsql and make appropriate storage in temporary
2455: file space.
2456:
2457: =item idput
2458:
2459: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
2460: for each student, defined perhaps by the institutional Registrar.)
2461:
2462: =item idget
2463:
2464: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
2465: for each student, defined perhaps by the institutional Registrar.)
2466:
2467: =item tmpput
2468:
2469: Accept and store information in temporary space.
2470:
2471: =item tmpget
2472:
2473: Send along temporarily stored information.
2474:
2475: =item ls
2476:
2477: List part of a user's directory.
2478:
2479: =item pushtable
2480:
2481: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
2482: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
2483: must be restored manually in case of a problem with the new table file.
2484: pushtable requires that the request be encrypted and validated via
2485: ValidateManager. The form of the command is:
2486: enc:pushtable tablename <tablecontents> \n
2487: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
2488: cleartext newline.
2489:
2490: =item Hanging up (exit or init)
2491:
2492: What to do when a client tells the server that they (the client)
2493: are leaving the network.
2494:
2495: =item unknown command
2496:
2497: If B<lond> is sent an unknown command (not in the list above),
2498: it replys to the client "unknown_cmd".
2499:
2500:
2501: =item UNKNOWN CLIENT
2502:
2503: If the anti-spoofing algorithm cannot verify the client,
2504: the client is rejected (with a "refused" message sent
2505: to the client, and the connection is closed.
2506:
2507: =back
2508:
2509: =head1 PREREQUISITES
2510:
2511: IO::Socket
2512: IO::File
2513: Apache::File
2514: Symbol
2515: POSIX
2516: Crypt::IDEA
2517: LWP::UserAgent()
2518: GDBM_File
2519: Authen::Krb4
2520: Authen::Krb5
2521:
2522: =head1 COREQUISITES
2523:
2524: =head1 OSNAMES
2525:
2526: linux
2527:
2528: =head1 SCRIPT CATEGORIES
2529:
2530: Server/Process
2531:
2532: =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