1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
4: #
5: # $Id: lond,v 1.138 2003/08/22 16:07:11 albertel Exp $
6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27: # http://www.lon-capa.org/
28: #
29: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
30: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
31: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
32: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
33: # 03/07,05/31 Gerd Kortemeyer
34: # 06/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.138 $'; #' 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 ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
2132: if ($curtime-$mtime < 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