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