1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
4: #
5: # $Id: lond,v 1.135 2003/08/12 09:39:23 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.135 $'; #' 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: # ----------------------------------------------------------------- currentauth
687: } elsif ($userinput =~ /^currentauth/) {
688: if ($wasenc==1) {
689: my ($cmd,$udom,$uname)=split(/:/,$userinput);
690: my $result = GetAuthType($udom, $uname);
691: if($result eq "nouser") {
692: print $client "unknown_user\n";
693: }
694: else {
695: print $client "$result\n"
696: }
697: } else {
698: print $client "refused\n";
699: }
700: # ------------------------------------------------------------------------ auth
701: } elsif ($userinput =~ /^auth/) {
702: if ($wasenc==1) {
703: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
704: chomp($upass);
705: $upass=unescape($upass);
706: my $proname=propath($udom,$uname);
707: my $passfilename="$proname/passwd";
708: if (-e $passfilename) {
709: my $pf = IO::File->new($passfilename);
710: my $realpasswd=<$pf>;
711: chomp($realpasswd);
712: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
713: my $pwdcorrect=0;
714: if ($howpwd eq 'internal') {
715: &Debug("Internal auth");
716: $pwdcorrect=
717: (crypt($upass,$contentpwd) eq $contentpwd);
718: } elsif ($howpwd eq 'unix') {
719: &Debug("Unix auth");
720: if((getpwnam($uname))[1] eq "") { #no such user!
721: $pwdcorrect = 0;
722: } else {
723: $contentpwd=(getpwnam($uname))[1];
724: my $pwauth_path="/usr/local/sbin/pwauth";
725: unless ($contentpwd eq 'x') {
726: $pwdcorrect=
727: (crypt($upass,$contentpwd) eq
728: $contentpwd);
729: }
730:
731: elsif (-e $pwauth_path) {
732: open PWAUTH, "|$pwauth_path" or
733: die "Cannot invoke authentication";
734: print PWAUTH "$uname\n$upass\n";
735: close PWAUTH;
736: $pwdcorrect=!$?;
737: }
738: }
739: } elsif ($howpwd eq 'krb4') {
740: my $null=pack("C",0);
741: unless ($upass=~/$null/) {
742: my $krb4_error = &Authen::Krb4::get_pw_in_tkt
743: ($uname,"",$contentpwd,'krbtgt',
744: $contentpwd,1,$upass);
745: if (!$krb4_error) {
746: $pwdcorrect = 1;
747: } else {
748: $pwdcorrect=0;
749: # log error if it is not a bad password
750: if ($krb4_error != 62) {
751: &logthis('krb4:'.$uname.','.$contentpwd.','.
752: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
753: }
754: }
755: }
756: } elsif ($howpwd eq 'krb5') {
757: my $null=pack("C",0);
758: unless ($upass=~/$null/) {
759: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
760: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
761: my $krbserver=&Authen::Krb5::parse_name($krbservice);
762: my $credentials=&Authen::Krb5::cc_default();
763: $credentials->initialize($krbclient);
764: my $krbreturn =
765: &Authen::Krb5::get_in_tkt_with_password(
766: $krbclient,$krbserver,$upass,$credentials);
767: # unless ($krbreturn) {
768: # &logthis("Krb5 Error: ".
769: # &Authen::Krb5::error());
770: # }
771: $pwdcorrect = ($krbreturn == 1);
772: } else { $pwdcorrect=0; }
773: } elsif ($howpwd eq 'localauth') {
774: $pwdcorrect=&localauth::localauth($uname,$upass,
775: $contentpwd);
776: }
777: if ($pwdcorrect) {
778: print $client "authorized\n";
779: } else {
780: print $client "non_authorized\n";
781: }
782: } else {
783: print $client "unknown_user\n";
784: }
785: } else {
786: print $client "refused\n";
787: }
788: # ---------------------------------------------------------------------- passwd
789: } elsif ($userinput =~ /^passwd/) {
790: if ($wasenc==1) {
791: my
792: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
793: chomp($npass);
794: $upass=&unescape($upass);
795: $npass=&unescape($npass);
796: &Debug("Trying to change password for $uname");
797: my $proname=propath($udom,$uname);
798: my $passfilename="$proname/passwd";
799: if (-e $passfilename) {
800: my $realpasswd;
801: { my $pf = IO::File->new($passfilename);
802: $realpasswd=<$pf>; }
803: chomp($realpasswd);
804: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
805: if ($howpwd eq 'internal') {
806: &Debug("internal auth");
807: if (crypt($upass,$contentpwd) eq $contentpwd) {
808: my $salt=time;
809: $salt=substr($salt,6,2);
810: my $ncpass=crypt($npass,$salt);
811: { my $pf = IO::File->new(">$passfilename");
812: print $pf "internal:$ncpass\n"; }
813: &logthis("Result of password change for $uname: pwchange_success");
814: print $client "ok\n";
815: } else {
816: print $client "non_authorized\n";
817: }
818: } elsif ($howpwd eq 'unix') {
819: # Unix means we have to access /etc/password
820: # one way or another.
821: # First: Make sure the current password is
822: # correct
823: &Debug("auth is unix");
824: $contentpwd=(getpwnam($uname))[1];
825: my $pwdcorrect = "0";
826: my $pwauth_path="/usr/local/sbin/pwauth";
827: unless ($contentpwd eq 'x') {
828: $pwdcorrect=
829: (crypt($upass,$contentpwd) eq $contentpwd);
830: } elsif (-e $pwauth_path) {
831: open PWAUTH, "|$pwauth_path" or
832: die "Cannot invoke authentication";
833: print PWAUTH "$uname\n$upass\n";
834: close PWAUTH;
835: &Debug("exited pwauth with $? ($uname,$upass) ");
836: $pwdcorrect=($? == 0);
837: }
838: if ($pwdcorrect) {
839: my $execdir=$perlvar{'lonDaemons'};
840: &Debug("Opening lcpasswd pipeline");
841: my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
842: print $pf "$uname\n$npass\n$npass\n";
843: close $pf;
844: my $err = $?;
845: my $result = ($err>0 ? 'pwchange_failure'
846: : 'ok');
847: &logthis("Result of password change for $uname: ".
848: &lcpasswdstrerror($?));
849: print $client "$result\n";
850: } else {
851: print $client "non_authorized\n";
852: }
853: } else {
854: print $client "auth_mode_error\n";
855: }
856: } else {
857: print $client "unknown_user\n";
858: }
859: } else {
860: print $client "refused\n";
861: }
862: # -------------------------------------------------------------------- makeuser
863: } elsif ($userinput =~ /^makeuser/) {
864: &Debug("Make user received");
865: my $oldumask=umask(0077);
866: if ($wasenc==1) {
867: my
868: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
869: &Debug("cmd =".$cmd." $udom =".$udom.
870: " uname=".$uname);
871: chomp($npass);
872: $npass=&unescape($npass);
873: my $proname=propath($udom,$uname);
874: my $passfilename="$proname/passwd";
875: &Debug("Password file created will be:".
876: $passfilename);
877: if (-e $passfilename) {
878: print $client "already_exists\n";
879: } elsif ($udom ne $currentdomainid) {
880: print $client "not_right_domain\n";
881: } else {
882: my @fpparts=split(/\//,$proname);
883: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
884: my $fperror='';
885: for (my $i=3;$i<=$#fpparts;$i++) {
886: $fpnow.='/'.$fpparts[$i];
887: unless (-e $fpnow) {
888: unless (mkdir($fpnow,0777)) {
889: $fperror="error: ".($!+0)
890: ." mkdir failed while attempting "
891: ."makeuser\n";
892: }
893: }
894: }
895: unless ($fperror) {
896: my $result=&make_passwd_file($uname, $umode,$npass,
897: $passfilename);
898: print $client $result;
899: } else {
900: print $client "$fperror\n";
901: }
902: }
903: } else {
904: print $client "refused\n";
905: }
906: umask($oldumask);
907: # -------------------------------------------------------------- changeuserauth
908: } elsif ($userinput =~ /^changeuserauth/) {
909: &Debug("Changing authorization");
910: if ($wasenc==1) {
911: my
912: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
913: chomp($npass);
914: &Debug("cmd = ".$cmd." domain= ".$udom.
915: "uname =".$uname." umode= ".$umode);
916: $npass=&unescape($npass);
917: my $proname=&propath($udom,$uname);
918: my $passfilename="$proname/passwd";
919: if ($udom ne $currentdomainid) {
920: print $client "not_right_domain\n";
921: } else {
922: my $result=&make_passwd_file($uname, $umode,$npass,
923: $passfilename);
924: print $client $result;
925: }
926: } else {
927: print $client "refused\n";
928: }
929: # ------------------------------------------------------------------------ home
930: } elsif ($userinput =~ /^home/) {
931: my ($cmd,$udom,$uname)=split(/:/,$userinput);
932: chomp($uname);
933: my $proname=propath($udom,$uname);
934: if (-e $proname) {
935: print $client "found\n";
936: } else {
937: print $client "not_found\n";
938: }
939: # ---------------------------------------------------------------------- update
940: } elsif ($userinput =~ /^update/) {
941: my ($cmd,$fname)=split(/:/,$userinput);
942: my $ownership=ishome($fname);
943: if ($ownership eq 'not_owner') {
944: if (-e $fname) {
945: my ($dev,$ino,$mode,$nlink,
946: $uid,$gid,$rdev,$size,
947: $atime,$mtime,$ctime,
948: $blksize,$blocks)=stat($fname);
949: my $now=time;
950: my $since=$now-$atime;
951: if ($since>$perlvar{'lonExpire'}) {
952: my $reply=
953: &reply("unsub:$fname","$hostid{$clientip}");
954: unlink("$fname");
955: } else {
956: my $transname="$fname.in.transfer";
957: my $remoteurl=
958: reply("sub:$fname","$hostid{$clientip}");
959: my $response;
960: {
961: my $ua=new LWP::UserAgent;
962: my $request=new HTTP::Request('GET',"$remoteurl");
963: $response=$ua->request($request,$transname);
964: }
965: if ($response->is_error()) {
966: unlink($transname);
967: my $message=$response->status_line;
968: &logthis(
969: "LWP GET: $message for $fname ($remoteurl)");
970: } else {
971: if ($remoteurl!~/\.meta$/) {
972: my $ua=new LWP::UserAgent;
973: my $mrequest=
974: new HTTP::Request('GET',$remoteurl.'.meta');
975: my $mresponse=
976: $ua->request($mrequest,$fname.'.meta');
977: if ($mresponse->is_error()) {
978: unlink($fname.'.meta');
979: }
980: }
981: rename($transname,$fname);
982: }
983: }
984: print $client "ok\n";
985: } else {
986: print $client "not_found\n";
987: }
988: } else {
989: print $client "rejected\n";
990: }
991: # -------------------------------------- fetch a user file from a remote server
992: } elsif ($userinput =~ /^fetchuserfile/) {
993: my ($cmd,$fname)=split(/:/,$userinput);
994: my ($udom,$uname,$ufile)=split(/\//,$fname);
995: my $udir=propath($udom,$uname).'/userfiles';
996: unless (-e $udir) { mkdir($udir,0770); }
997: if (-e $udir) {
998: $ufile=~s/^[\.\~]+//;
999: $ufile=~s/\///g;
1000: my $transname=$udir.'/'.$ufile;
1001: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
1002: my $response;
1003: {
1004: my $ua=new LWP::UserAgent;
1005: my $request=new HTTP::Request('GET',"$remoteurl");
1006: $response=$ua->request($request,$transname);
1007: }
1008: if ($response->is_error()) {
1009: unlink($transname);
1010: my $message=$response->status_line;
1011: &logthis(
1012: "LWP GET: $message for $fname ($remoteurl)");
1013: print $client "failed\n";
1014: } else {
1015: print $client "ok\n";
1016: }
1017: } else {
1018: print $client "not_home\n";
1019: }
1020: # ------------------------------------------ authenticate access to a user file
1021: } elsif ($userinput =~ /^tokenauthuserfile/) {
1022: my ($cmd,$fname,$session)=split(/:/,$userinput);
1023: chomp($session);
1024: my $reply='non_auth';
1025: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
1026: $session.'.id')) {
1027: while (my $line=<ENVIN>) {
1028: if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
1029: }
1030: close(ENVIN);
1031: print $client $reply."\n";
1032: } else {
1033: print $client "invalid_token\n";
1034: }
1035: # ----------------------------------------------------------------- unsubscribe
1036: } elsif ($userinput =~ /^unsub/) {
1037: my ($cmd,$fname)=split(/:/,$userinput);
1038: if (-e $fname) {
1039: print $client &unsub($client,$fname,$clientip);
1040: } else {
1041: print $client "not_found\n";
1042: }
1043: # ------------------------------------------------------------------- subscribe
1044: } elsif ($userinput =~ /^sub/) {
1045: print $client &subscribe($userinput,$clientip);
1046: # ------------------------------------------------------------- current version
1047: } elsif ($userinput =~ /^currentversion/) {
1048: my ($cmd,$fname)=split(/:/,$userinput);
1049: print $client ¤tversion($fname)."\n";
1050: # ------------------------------------------------------------------------- log
1051: } elsif ($userinput =~ /^log/) {
1052: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
1053: chomp($what);
1054: my $proname=propath($udom,$uname);
1055: my $now=time;
1056: {
1057: my $hfh;
1058: if ($hfh=IO::File->new(">>$proname/activity.log")) {
1059: print $hfh "$now:$hostid{$clientip}:$what\n";
1060: print $client "ok\n";
1061: } else {
1062: print $client "error: ".($!+0)
1063: ." IO::File->new Failed "
1064: ."while attempting log\n";
1065: }
1066: }
1067: # ------------------------------------------------------------------------- put
1068: } elsif ($userinput =~ /^put/) {
1069: my ($cmd,$udom,$uname,$namespace,$what)
1070: =split(/:/,$userinput);
1071: $namespace=~s/\//\_/g;
1072: $namespace=~s/\W//g;
1073: if ($namespace ne 'roles') {
1074: chomp($what);
1075: my $proname=propath($udom,$uname);
1076: my $now=time;
1077: unless ($namespace=~/^nohist\_/) {
1078: my $hfh;
1079: if (
1080: $hfh=IO::File->new(">>$proname/$namespace.hist")
1081: ) { print $hfh "P:$now:$what\n"; }
1082: }
1083: my @pairs=split(/\&/,$what);
1084: my %hash;
1085: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1086: foreach my $pair (@pairs) {
1087: my ($key,$value)=split(/=/,$pair);
1088: $hash{$key}=$value;
1089: }
1090: if (untie(%hash)) {
1091: print $client "ok\n";
1092: } else {
1093: print $client "error: ".($!+0)
1094: ." untie(GDBM) failed ".
1095: "while attempting put\n";
1096: }
1097: } else {
1098: print $client "error: ".($!)
1099: ." tie(GDBM) Failed ".
1100: "while attempting put\n";
1101: }
1102: } else {
1103: print $client "refused\n";
1104: }
1105: # -------------------------------------------------------------------- rolesput
1106: } elsif ($userinput =~ /^rolesput/) {
1107: &Debug("rolesput");
1108: if ($wasenc==1) {
1109: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1110: =split(/:/,$userinput);
1111: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1112: "user = ".$exeuser." udom=".$udom.
1113: "what = ".$what);
1114: my $namespace='roles';
1115: chomp($what);
1116: my $proname=propath($udom,$uname);
1117: my $now=time;
1118: {
1119: my $hfh;
1120: if (
1121: $hfh=IO::File->new(">>$proname/$namespace.hist")
1122: ) {
1123: print $hfh "P:$now:$exedom:$exeuser:$what\n";
1124: }
1125: }
1126: my @pairs=split(/\&/,$what);
1127: my %hash;
1128: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1129: foreach my $pair (@pairs) {
1130: my ($key,$value)=split(/=/,$pair);
1131: &ManagePermissions($key, $udom, $uname,
1132: &GetAuthType( $udom,
1133: $uname));
1134: $hash{$key}=$value;
1135: }
1136: if (untie(%hash)) {
1137: print $client "ok\n";
1138: } else {
1139: print $client "error: ".($!+0)
1140: ." untie(GDBM) Failed ".
1141: "while attempting rolesput\n";
1142: }
1143: } else {
1144: print $client "error: ".($!+0)
1145: ." tie(GDBM) Failed ".
1146: "while attempting rolesput\n";
1147: }
1148: } else {
1149: print $client "refused\n";
1150: }
1151: # -------------------------------------------------------------------- rolesdel
1152: } elsif ($userinput =~ /^rolesdel/) {
1153: &Debug("rolesdel");
1154: if ($wasenc==1) {
1155: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1156: =split(/:/,$userinput);
1157: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1158: "user = ".$exeuser." udom=".$udom.
1159: "what = ".$what);
1160: my $namespace='roles';
1161: chomp($what);
1162: my $proname=propath($udom,$uname);
1163: my $now=time;
1164: {
1165: my $hfh;
1166: if (
1167: $hfh=IO::File->new(">>$proname/$namespace.hist")
1168: ) {
1169: print $hfh "D:$now:$exedom:$exeuser:$what\n";
1170: }
1171: }
1172: my @rolekeys=split(/\&/,$what);
1173: my %hash;
1174: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1175: foreach my $key (@rolekeys) {
1176: delete $hash{$key};
1177: }
1178: if (untie(%hash)) {
1179: print $client "ok\n";
1180: } else {
1181: print $client "error: ".($!+0)
1182: ." untie(GDBM) Failed ".
1183: "while attempting rolesdel\n";
1184: }
1185: } else {
1186: print $client "error: ".($!+0)
1187: ." tie(GDBM) Failed ".
1188: "while attempting rolesdel\n";
1189: }
1190: } else {
1191: print $client "refused\n";
1192: }
1193: # ------------------------------------------------------------------------- get
1194: } elsif ($userinput =~ /^get/) {
1195: my ($cmd,$udom,$uname,$namespace,$what)
1196: =split(/:/,$userinput);
1197: $namespace=~s/\//\_/g;
1198: $namespace=~s/\W//g;
1199: chomp($what);
1200: my @queries=split(/\&/,$what);
1201: my $proname=propath($udom,$uname);
1202: my $qresult='';
1203: my %hash;
1204: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1205: for (my $i=0;$i<=$#queries;$i++) {
1206: $qresult.="$hash{$queries[$i]}&";
1207: }
1208: if (untie(%hash)) {
1209: $qresult=~s/\&$//;
1210: print $client "$qresult\n";
1211: } else {
1212: print $client "error: ".($!+0)
1213: ." untie(GDBM) Failed ".
1214: "while attempting get\n";
1215: }
1216: } else {
1217: if ($!+0 == 2) {
1218: print $client "error:No such file or ".
1219: "GDBM reported bad block error\n";
1220: } else {
1221: print $client "error: ".($!+0)
1222: ." tie(GDBM) Failed ".
1223: "while attempting get\n";
1224: }
1225: }
1226: # ------------------------------------------------------------------------ eget
1227: } elsif ($userinput =~ /^eget/) {
1228: my ($cmd,$udom,$uname,$namespace,$what)
1229: =split(/:/,$userinput);
1230: $namespace=~s/\//\_/g;
1231: $namespace=~s/\W//g;
1232: chomp($what);
1233: my @queries=split(/\&/,$what);
1234: my $proname=propath($udom,$uname);
1235: my $qresult='';
1236: my %hash;
1237: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1238: for (my $i=0;$i<=$#queries;$i++) {
1239: $qresult.="$hash{$queries[$i]}&";
1240: }
1241: if (untie(%hash)) {
1242: $qresult=~s/\&$//;
1243: if ($cipher) {
1244: my $cmdlength=length($qresult);
1245: $qresult.=" ";
1246: my $encqresult='';
1247: for
1248: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1249: $encqresult.=
1250: unpack("H16",
1251: $cipher->encrypt(substr($qresult,$encidx,8)));
1252: }
1253: print $client "enc:$cmdlength:$encqresult\n";
1254: } else {
1255: print $client "error:no_key\n";
1256: }
1257: } else {
1258: print $client "error: ".($!+0)
1259: ." untie(GDBM) Failed ".
1260: "while attempting eget\n";
1261: }
1262: } else {
1263: print $client "error: ".($!+0)
1264: ." tie(GDBM) Failed ".
1265: "while attempting eget\n";
1266: }
1267: # ------------------------------------------------------------------------- del
1268: } elsif ($userinput =~ /^del/) {
1269: my ($cmd,$udom,$uname,$namespace,$what)
1270: =split(/:/,$userinput);
1271: $namespace=~s/\//\_/g;
1272: $namespace=~s/\W//g;
1273: chomp($what);
1274: my $proname=propath($udom,$uname);
1275: my $now=time;
1276: unless ($namespace=~/^nohist\_/) {
1277: my $hfh;
1278: if (
1279: $hfh=IO::File->new(">>$proname/$namespace.hist")
1280: ) { print $hfh "D:$now:$what\n"; }
1281: }
1282: my @keys=split(/\&/,$what);
1283: my %hash;
1284: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1285: foreach my $key (@keys) {
1286: delete($hash{$key});
1287: }
1288: if (untie(%hash)) {
1289: print $client "ok\n";
1290: } else {
1291: print $client "error: ".($!+0)
1292: ." untie(GDBM) Failed ".
1293: "while attempting del\n";
1294: }
1295: } else {
1296: print $client "error: ".($!+0)
1297: ." tie(GDBM) Failed ".
1298: "while attempting del\n";
1299: }
1300: # ------------------------------------------------------------------------ keys
1301: } elsif ($userinput =~ /^keys/) {
1302: my ($cmd,$udom,$uname,$namespace)
1303: =split(/:/,$userinput);
1304: $namespace=~s/\//\_/g;
1305: $namespace=~s/\W//g;
1306: my $proname=propath($udom,$uname);
1307: my $qresult='';
1308: my %hash;
1309: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1310: foreach my $key (keys %hash) {
1311: $qresult.="$key&";
1312: }
1313: if (untie(%hash)) {
1314: $qresult=~s/\&$//;
1315: print $client "$qresult\n";
1316: } else {
1317: print $client "error: ".($!+0)
1318: ." untie(GDBM) Failed ".
1319: "while attempting keys\n";
1320: }
1321: } else {
1322: print $client "error: ".($!+0)
1323: ." tie(GDBM) Failed ".
1324: "while attempting keys\n";
1325: }
1326: # ----------------------------------------------------------------- dumpcurrent
1327: } elsif ($userinput =~ /^currentdump/) {
1328: my ($cmd,$udom,$uname,$namespace)
1329: =split(/:/,$userinput);
1330: $namespace=~s/\//\_/g;
1331: $namespace=~s/\W//g;
1332: my $qresult='';
1333: my $proname=propath($udom,$uname);
1334: my %hash;
1335: if (tie(%hash,'GDBM_File',
1336: "$proname/$namespace.db",
1337: &GDBM_READER(),0640)) {
1338: # Structure of %data:
1339: # $data{$symb}->{$parameter}=$value;
1340: # $data{$symb}->{'v.'.$parameter}=$version;
1341: # since $parameter will be unescaped, we do not
1342: # have to worry about silly parameter names...
1343: my %data = ();
1344: while (my ($key,$value) = each(%hash)) {
1345: my ($v,$symb,$param) = split(/:/,$key);
1346: next if ($v eq 'version' || $symb eq 'keys');
1347: next if (exists($data{$symb}) &&
1348: exists($data{$symb}->{$param}) &&
1349: $data{$symb}->{'v.'.$param} > $v);
1350: $data{$symb}->{$param}=$value;
1351: $data{$symb}->{'v.'.$param}=$v;
1352: }
1353: if (untie(%hash)) {
1354: while (my ($symb,$param_hash) = each(%data)) {
1355: while(my ($param,$value) = each (%$param_hash)){
1356: next if ($param =~ /^v\./);
1357: $qresult.=$symb.':'.$param.'='.$value.'&';
1358: }
1359: }
1360: chop($qresult);
1361: print $client "$qresult\n";
1362: } else {
1363: print $client "error: ".($!+0)
1364: ." untie(GDBM) Failed ".
1365: "while attempting currentdump\n";
1366: }
1367: } else {
1368: print $client "error: ".($!+0)
1369: ." tie(GDBM) Failed ".
1370: "while attempting currentdump\n";
1371: }
1372: # ------------------------------------------------------------------------ dump
1373: } elsif ($userinput =~ /^dump/) {
1374: my ($cmd,$udom,$uname,$namespace,$regexp)
1375: =split(/:/,$userinput);
1376: $namespace=~s/\//\_/g;
1377: $namespace=~s/\W//g;
1378: if (defined($regexp)) {
1379: $regexp=&unescape($regexp);
1380: } else {
1381: $regexp='.';
1382: }
1383: my $qresult='';
1384: my $proname=propath($udom,$uname);
1385: my %hash;
1386: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1387: study($regexp);
1388: while (my ($key,$value) = each(%hash)) {
1389: if ($regexp eq '.') {
1390: $qresult.=$key.'='.$value.'&';
1391: } else {
1392: my $unescapeKey = &unescape($key);
1393: if (eval('$unescapeKey=~/$regexp/')) {
1394: $qresult.="$key=$value&";
1395: }
1396: }
1397: }
1398: if (untie(%hash)) {
1399: chop($qresult);
1400: print $client "$qresult\n";
1401: } else {
1402: print $client "error: ".($!+0)
1403: ." untie(GDBM) Failed ".
1404: "while attempting dump\n";
1405: }
1406: } else {
1407: print $client "error: ".($!+0)
1408: ." tie(GDBM) Failed ".
1409: "while attempting dump\n";
1410: }
1411: # ----------------------------------------------------------------------- store
1412: } elsif ($userinput =~ /^store/) {
1413: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1414: =split(/:/,$userinput);
1415: $namespace=~s/\//\_/g;
1416: $namespace=~s/\W//g;
1417: if ($namespace ne 'roles') {
1418: chomp($what);
1419: my $proname=propath($udom,$uname);
1420: my $now=time;
1421: unless ($namespace=~/^nohist\_/) {
1422: my $hfh;
1423: if (
1424: $hfh=IO::File->new(">>$proname/$namespace.hist")
1425: ) { print $hfh "P:$now:$rid:$what\n"; }
1426: }
1427: my @pairs=split(/\&/,$what);
1428: my %hash;
1429: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1430: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1431: my $key;
1432: $hash{"version:$rid"}++;
1433: my $version=$hash{"version:$rid"};
1434: my $allkeys='';
1435: foreach my $pair (@pairs) {
1436: my ($key,$value)=split(/=/,$pair);
1437: $allkeys.=$key.':';
1438: $hash{"$version:$rid:$key"}=$value;
1439: }
1440: $hash{"$version:$rid:timestamp"}=$now;
1441: $allkeys.='timestamp';
1442: $hash{"$version:keys:$rid"}=$allkeys;
1443: if (untie(%hash)) {
1444: print $client "ok\n";
1445: } else {
1446: print $client "error: ".($!+0)
1447: ." untie(GDBM) Failed ".
1448: "while attempting store\n";
1449: }
1450: } else {
1451: print $client "error: ".($!+0)
1452: ." tie(GDBM) Failed ".
1453: "while attempting store\n";
1454: }
1455: } else {
1456: print $client "refused\n";
1457: }
1458: # --------------------------------------------------------------------- restore
1459: } elsif ($userinput =~ /^restore/) {
1460: my ($cmd,$udom,$uname,$namespace,$rid)
1461: =split(/:/,$userinput);
1462: $namespace=~s/\//\_/g;
1463: $namespace=~s/\W//g;
1464: chomp($rid);
1465: my $proname=propath($udom,$uname);
1466: my $qresult='';
1467: my %hash;
1468: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1469: my $version=$hash{"version:$rid"};
1470: $qresult.="version=$version&";
1471: my $scope;
1472: for ($scope=1;$scope<=$version;$scope++) {
1473: my $vkeys=$hash{"$scope:keys:$rid"};
1474: my @keys=split(/:/,$vkeys);
1475: my $key;
1476: $qresult.="$scope:keys=$vkeys&";
1477: foreach $key (@keys) {
1478: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1479: }
1480: }
1481: if (untie(%hash)) {
1482: $qresult=~s/\&$//;
1483: print $client "$qresult\n";
1484: } else {
1485: print $client "error: ".($!+0)
1486: ." untie(GDBM) Failed ".
1487: "while attempting restore\n";
1488: }
1489: } else {
1490: print $client "error: ".($!+0)
1491: ." tie(GDBM) Failed ".
1492: "while attempting restore\n";
1493: }
1494: # -------------------------------------------------------------------- chatsend
1495: } elsif ($userinput =~ /^chatsend/) {
1496: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
1497: &chatadd($cdom,$cnum,$newpost);
1498: print $client "ok\n";
1499: # -------------------------------------------------------------------- chatretr
1500: } elsif ($userinput =~ /^chatretr/) {
1501: my
1502: ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
1503: my $reply='';
1504: foreach (&getchat($cdom,$cnum,$udom,$uname)) {
1505: $reply.=&escape($_).':';
1506: }
1507: $reply=~s/\:$//;
1508: print $client $reply."\n";
1509: # ------------------------------------------------------------------- querysend
1510: } elsif ($userinput =~ /^querysend/) {
1511: my ($cmd,$query,
1512: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
1513: $query=~s/\n*$//g;
1514: print $client "".
1515: sqlreply("$hostid{$clientip}\&$query".
1516: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
1517: # ------------------------------------------------------------------ queryreply
1518: } elsif ($userinput =~ /^queryreply/) {
1519: my ($cmd,$id,$reply)=split(/:/,$userinput);
1520: my $store;
1521: my $execdir=$perlvar{'lonDaemons'};
1522: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1523: $reply=~s/\&/\n/g;
1524: print $store $reply;
1525: close $store;
1526: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1527: print $store2 "done\n";
1528: close $store2;
1529: print $client "ok\n";
1530: }
1531: else {
1532: print $client "error: ".($!+0)
1533: ." IO::File->new Failed ".
1534: "while attempting queryreply\n";
1535: }
1536: # ----------------------------------------------------------------- courseidput
1537: } elsif ($userinput =~ /^courseidput/) {
1538: my ($cmd,$udom,$what)=split(/:/,$userinput);
1539: chomp($what);
1540: $udom=~s/\W//g;
1541: my $proname=
1542: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
1543: my $now=time;
1544: my @pairs=split(/\&/,$what);
1545: my %hash;
1546: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1547: foreach my $pair (@pairs) {
1548: my ($key,$value)=split(/=/,$pair);
1549: $hash{$key}=$value.':'.$now;
1550: }
1551: if (untie(%hash)) {
1552: print $client "ok\n";
1553: } else {
1554: print $client "error: ".($!+0)
1555: ." untie(GDBM) Failed ".
1556: "while attempting courseidput\n";
1557: }
1558: } else {
1559: print $client "error: ".($!+0)
1560: ." tie(GDBM) Failed ".
1561: "while attempting courseidput\n";
1562: }
1563: # ---------------------------------------------------------------- courseiddump
1564: } elsif ($userinput =~ /^courseiddump/) {
1565: my ($cmd,$udom,$since,$description)
1566: =split(/:/,$userinput);
1567: if (defined($description)) {
1568: $description=&unescape($description);
1569: } else {
1570: $description='.';
1571: }
1572: unless (defined($since)) { $since=0; }
1573: my $qresult='';
1574: my $proname=
1575: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
1576: my %hash;
1577: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1578: while (my ($key,$value) = each(%hash)) {
1579: my ($descr,$lasttime)=split(/\:/,$value);
1580: if ($lasttime<$since) { next; }
1581: if ($description eq '.') {
1582: $qresult.=$key.'='.$descr.'&';
1583: } else {
1584: my $unescapeVal = &unescape($descr);
1585: if (eval('$unescapeVal=~/$description/i')) {
1586: $qresult.="$key=$descr&";
1587: }
1588: }
1589: }
1590: if (untie(%hash)) {
1591: chop($qresult);
1592: print $client "$qresult\n";
1593: } else {
1594: print $client "error: ".($!+0)
1595: ." untie(GDBM) Failed ".
1596: "while attempting courseiddump\n";
1597: }
1598: } else {
1599: print $client "error: ".($!+0)
1600: ." tie(GDBM) Failed ".
1601: "while attempting courseiddump\n";
1602: }
1603: # ----------------------------------------------------------------------- idput
1604: } elsif ($userinput =~ /^idput/) {
1605: my ($cmd,$udom,$what)=split(/:/,$userinput);
1606: chomp($what);
1607: $udom=~s/\W//g;
1608: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1609: my $now=time;
1610: {
1611: my $hfh;
1612: if (
1613: $hfh=IO::File->new(">>$proname.hist")
1614: ) { print $hfh "P:$now:$what\n"; }
1615: }
1616: my @pairs=split(/\&/,$what);
1617: my %hash;
1618: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1619: foreach my $pair (@pairs) {
1620: my ($key,$value)=split(/=/,$pair);
1621: $hash{$key}=$value;
1622: }
1623: if (untie(%hash)) {
1624: print $client "ok\n";
1625: } else {
1626: print $client "error: ".($!+0)
1627: ." untie(GDBM) Failed ".
1628: "while attempting idput\n";
1629: }
1630: } else {
1631: print $client "error: ".($!+0)
1632: ." tie(GDBM) Failed ".
1633: "while attempting idput\n";
1634: }
1635: # ----------------------------------------------------------------------- idget
1636: } elsif ($userinput =~ /^idget/) {
1637: my ($cmd,$udom,$what)=split(/:/,$userinput);
1638: chomp($what);
1639: $udom=~s/\W//g;
1640: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1641: my @queries=split(/\&/,$what);
1642: my $qresult='';
1643: my %hash;
1644: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1645: for (my $i=0;$i<=$#queries;$i++) {
1646: $qresult.="$hash{$queries[$i]}&";
1647: }
1648: if (untie(%hash)) {
1649: $qresult=~s/\&$//;
1650: print $client "$qresult\n";
1651: } else {
1652: print $client "error: ".($!+0)
1653: ." untie(GDBM) Failed ".
1654: "while attempting idget\n";
1655: }
1656: } else {
1657: print $client "error: ".($!+0)
1658: ." tie(GDBM) Failed ".
1659: "while attempting idget\n";
1660: }
1661: # ---------------------------------------------------------------------- tmpput
1662: } elsif ($userinput =~ /^tmpput/) {
1663: my ($cmd,$what)=split(/:/,$userinput);
1664: my $store;
1665: $tmpsnum++;
1666: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1667: $id=~s/\W/\_/g;
1668: $what=~s/\n//g;
1669: my $execdir=$perlvar{'lonDaemons'};
1670: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1671: print $store $what;
1672: close $store;
1673: print $client "$id\n";
1674: }
1675: else {
1676: print $client "error: ".($!+0)
1677: ."IO::File->new Failed ".
1678: "while attempting tmpput\n";
1679: }
1680:
1681: # ---------------------------------------------------------------------- tmpget
1682: } elsif ($userinput =~ /^tmpget/) {
1683: my ($cmd,$id)=split(/:/,$userinput);
1684: chomp($id);
1685: $id=~s/\W/\_/g;
1686: my $store;
1687: my $execdir=$perlvar{'lonDaemons'};
1688: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
1689: my $reply=<$store>;
1690: print $client "$reply\n";
1691: close $store;
1692: }
1693: else {
1694: print $client "error: ".($!+0)
1695: ."IO::File->new Failed ".
1696: "while attempting tmpget\n";
1697: }
1698:
1699: # ---------------------------------------------------------------------- tmpdel
1700: } elsif ($userinput =~ /^tmpdel/) {
1701: my ($cmd,$id)=split(/:/,$userinput);
1702: chomp($id);
1703: $id=~s/\W/\_/g;
1704: my $execdir=$perlvar{'lonDaemons'};
1705: if (unlink("$execdir/tmp/$id.tmp")) {
1706: print $client "ok\n";
1707: } else {
1708: print $client "error: ".($!+0)
1709: ."Unlink tmp Failed ".
1710: "while attempting tmpdel\n";
1711: }
1712: # -------------------------------------------------------------------------- ls
1713: } elsif ($userinput =~ /^ls/) {
1714: my ($cmd,$ulsdir)=split(/:/,$userinput);
1715: my $ulsout='';
1716: my $ulsfn;
1717: if (-e $ulsdir) {
1718: if(-d $ulsdir) {
1719: if (opendir(LSDIR,$ulsdir)) {
1720: while ($ulsfn=readdir(LSDIR)) {
1721: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1722: $ulsout.=$ulsfn.'&'.
1723: join('&',@ulsstats).':';
1724: }
1725: closedir(LSDIR);
1726: }
1727: } else {
1728: my @ulsstats=stat($ulsdir);
1729: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1730: }
1731: } else {
1732: $ulsout='no_such_dir';
1733: }
1734: if ($ulsout eq '') { $ulsout='empty'; }
1735: print $client "$ulsout\n";
1736: # ------------------------------------------------------------------ Hanging up
1737: } elsif (($userinput =~ /^exit/) ||
1738: ($userinput =~ /^init/)) {
1739: &logthis(
1740: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1741: print $client "bye\n";
1742: $client->close();
1743: last;
1744: # ------------------------------------------------------------- unknown command
1745: } elsif ($userinput =~ /^sethost:/) {
1746: print $client &sethost($userinput)."\n";
1747: } elsif ($userinput =~/^version:/) {
1748: print $client &version($userinput)."\n";
1749: } else {
1750: # unknown command
1751: print $client "unknown_cmd\n";
1752: }
1753: # -------------------------------------------------------------------- complete
1754: alarm(0);
1755: &status('Listening to '.$hostid{$clientip});
1756: }
1757: # --------------------------------------------- client unknown or fishy, refuse
1758: } else {
1759: print $client "refused\n";
1760: $client->close();
1761: &logthis("<font color=blue>WARNING: "
1762: ."Rejected client $clientip, closing connection</font>");
1763: }
1764: }
1765:
1766: # =============================================================================
1767:
1768: &logthis("<font color=red>CRITICAL: "
1769: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1770:
1771:
1772: # this exit is VERY important, otherwise the child will become
1773: # a producer of more and more children, forking yourself into
1774: # process death.
1775: exit;
1776:
1777: }
1778:
1779:
1780: #
1781: # Checks to see if the input roleput request was to set
1782: # an author role. If so, invokes the lchtmldir script to set
1783: # up a correct public_html
1784: # Parameters:
1785: # request - The request sent to the rolesput subchunk.
1786: # We're looking for /domain/_au
1787: # domain - The domain in which the user is having roles doctored.
1788: # user - Name of the user for which the role is being put.
1789: # authtype - The authentication type associated with the user.
1790: #
1791: sub ManagePermissions
1792: {
1793: my $request = shift;
1794: my $domain = shift;
1795: my $user = shift;
1796: my $authtype= shift;
1797:
1798: # See if the request is of the form /$domain/_au
1799: &logthis("ruequest is $request");
1800: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
1801: my $execdir = $perlvar{'lonDaemons'};
1802: my $userhome= "/home/$user" ;
1803: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1804: system("$execdir/lchtmldir $userhome $user $authtype");
1805: }
1806: }
1807: #
1808: # GetAuthType - Determines the authorization type of a user in a domain.
1809:
1810: # Returns the authorization type or nouser if there is no such user.
1811: #
1812: sub GetAuthType
1813: {
1814: my $domain = shift;
1815: my $user = shift;
1816:
1817: Debug("GetAuthType( $domain, $user ) \n");
1818: my $proname = &propath($domain, $user);
1819: my $passwdfile = "$proname/passwd";
1820: if( -e $passwdfile ) {
1821: my $pf = IO::File->new($passwdfile);
1822: my $realpassword = <$pf>;
1823: chomp($realpassword);
1824: Debug("Password info = $realpassword\n");
1825: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1826: Debug("Authtype = $authtype, content = $contentpwd\n");
1827: my $availinfo = '';
1828: if($authtype eq 'krb4' or $authtype eq 'krb5') {
1829: $availinfo = $contentpwd;
1830: }
1831:
1832: return "$authtype:$availinfo";
1833: }
1834: else {
1835: Debug("Returning nouser");
1836: return "nouser";
1837: }
1838: }
1839:
1840: sub addline {
1841: my ($fname,$hostid,$ip,$newline)=@_;
1842: my $contents;
1843: my $found=0;
1844: my $expr='^'.$hostid.':'.$ip.':';
1845: $expr =~ s/\./\\\./g;
1846: my $sh;
1847: if ($sh=IO::File->new("$fname.subscription")) {
1848: while (my $subline=<$sh>) {
1849: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
1850: }
1851: $sh->close();
1852: }
1853: $sh=IO::File->new(">$fname.subscription");
1854: if ($contents) { print $sh $contents; }
1855: if ($newline) { print $sh $newline; }
1856: $sh->close();
1857: return $found;
1858: }
1859:
1860: sub getchat {
1861: my ($cdom,$cname,$udom,$uname)=@_;
1862: my %hash;
1863: my $proname=&propath($cdom,$cname);
1864: my @entries=();
1865: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1866: &GDBM_READER(),0640)) {
1867: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1868: untie %hash;
1869: }
1870: my @participants=();
1871: my $cutoff=time-60;
1872: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1873: &GDBM_WRCREAT(),0640)) {
1874: $hash{$uname.':'.$udom}=time;
1875: foreach (sort keys %hash) {
1876: if ($hash{$_}>$cutoff) {
1877: $participants[$#participants+1]='active_participant:'.$_;
1878: }
1879: }
1880: untie %hash;
1881: }
1882: return (@participants,@entries);
1883: }
1884:
1885: sub chatadd {
1886: my ($cdom,$cname,$newchat)=@_;
1887: my %hash;
1888: my $proname=&propath($cdom,$cname);
1889: my @entries=();
1890: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1891: &GDBM_WRCREAT(),0640)) {
1892: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1893: my $time=time;
1894: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
1895: my ($thentime,$idnum)=split(/\_/,$lastid);
1896: my $newid=$time.'_000000';
1897: if ($thentime==$time) {
1898: $idnum=~s/^0+//;
1899: $idnum++;
1900: $idnum=substr('000000'.$idnum,-6,6);
1901: $newid=$time.'_'.$idnum;
1902: }
1903: $hash{$newid}=$newchat;
1904: my $expired=$time-3600;
1905: foreach (keys %hash) {
1906: my ($thistime)=($_=~/(\d+)\_/);
1907: if ($thistime<$expired) {
1908: delete $hash{$_};
1909: }
1910: }
1911: untie %hash;
1912: }
1913: }
1914:
1915: sub unsub {
1916: my ($fname,$clientip)=@_;
1917: my $result;
1918: if (unlink("$fname.$hostid{$clientip}")) {
1919: $result="ok\n";
1920: } else {
1921: $result="not_subscribed\n";
1922: }
1923: if (-e "$fname.subscription") {
1924: my $found=&addline($fname,$hostid{$clientip},$clientip,'');
1925: if ($found) { $result="ok\n"; }
1926: } else {
1927: if ($result != "ok\n") { $result="not_subscribed\n"; }
1928: }
1929: return $result;
1930: }
1931:
1932: sub currentversion {
1933: my $fname=shift;
1934: my $version=-1;
1935: my $ulsdir='';
1936: if ($fname=~/^(.+)\/[^\/]+$/) {
1937: $ulsdir=$1;
1938: }
1939: my ($fnamere1,$fnamere2);
1940: # remove version if already specified
1941: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1942: # get the bits that go before and after the version number
1943: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
1944: $fnamere1=$1;
1945: $fnamere2='.'.$2;
1946: }
1947: if (-e $fname) { $version=1; }
1948: if (-e $ulsdir) {
1949: if(-d $ulsdir) {
1950: if (opendir(LSDIR,$ulsdir)) {
1951: my $ulsfn;
1952: while ($ulsfn=readdir(LSDIR)) {
1953: # see if this is a regular file (ignore links produced earlier)
1954: my $thisfile=$ulsdir.'/'.$ulsfn;
1955: unless (-l $thisfile) {
1956: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
1957: if ($1>$version) { $version=$1; }
1958: }
1959: }
1960: }
1961: closedir(LSDIR);
1962: $version++;
1963: }
1964: }
1965: }
1966: return $version;
1967: }
1968:
1969: sub thisversion {
1970: my $fname=shift;
1971: my $version=-1;
1972: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
1973: $version=$1;
1974: }
1975: return $version;
1976: }
1977:
1978: sub subscribe {
1979: my ($userinput,$clientip)=@_;
1980: my $result;
1981: my ($cmd,$fname)=split(/:/,$userinput);
1982: my $ownership=&ishome($fname);
1983: if ($ownership eq 'owner') {
1984: # explitly asking for the current version?
1985: unless (-e $fname) {
1986: my $currentversion=¤tversion($fname);
1987: if (&thisversion($fname)==$currentversion) {
1988: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
1989: my $root=$1;
1990: my $extension=$2;
1991: symlink($root.'.'.$extension,
1992: $root.'.'.$currentversion.'.'.$extension);
1993: unless ($extension=~/\.meta$/) {
1994: symlink($root.'.'.$extension.'.meta',
1995: $root.'.'.$currentversion.'.'.$extension.'.meta');
1996: }
1997: }
1998: }
1999: }
2000: if (-e $fname) {
2001: if (-d $fname) {
2002: $result="directory\n";
2003: } else {
2004: if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
2005: my $now=time;
2006: my $found=&addline($fname,$hostid{$clientip},$clientip,
2007: "$hostid{$clientip}:$clientip:$now\n");
2008: if ($found) { $result="$fname\n"; }
2009: # if they were subscribed to only meta data, delete that
2010: # subscription, when you subscribe to a file you also get
2011: # the metadata
2012: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
2013: $fname=~s/\/home\/httpd\/html\/res/raw/;
2014: $fname="http://$thisserver/".$fname;
2015: $result="$fname\n";
2016: }
2017: } else {
2018: $result="not_found\n";
2019: }
2020: } else {
2021: $result="rejected\n";
2022: }
2023: return $result;
2024: }
2025:
2026: sub make_passwd_file {
2027: my ($uname, $umode,$npass,$passfilename)=@_;
2028: my $result="ok\n";
2029: if ($umode eq 'krb4' or $umode eq 'krb5') {
2030: {
2031: my $pf = IO::File->new(">$passfilename");
2032: print $pf "$umode:$npass\n";
2033: }
2034: } elsif ($umode eq 'internal') {
2035: my $salt=time;
2036: $salt=substr($salt,6,2);
2037: my $ncpass=crypt($npass,$salt);
2038: {
2039: &Debug("Creating internal auth");
2040: my $pf = IO::File->new(">$passfilename");
2041: print $pf "internal:$ncpass\n";
2042: }
2043: } elsif ($umode eq 'localauth') {
2044: {
2045: my $pf = IO::File->new(">$passfilename");
2046: print $pf "localauth:$npass\n";
2047: }
2048: } elsif ($umode eq 'unix') {
2049: {
2050: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
2051: {
2052: &Debug("Executing external: ".$execpath);
2053: &Debug("user = ".$uname.", Password =". $npass);
2054: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
2055: print $se "$uname\n";
2056: print $se "$npass\n";
2057: print $se "$npass\n";
2058: }
2059: my $useraddok = $?;
2060: if($useraddok > 0) {
2061: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
2062: }
2063: my $pf = IO::File->new(">$passfilename");
2064: print $pf "unix:\n";
2065: }
2066: } elsif ($umode eq 'none') {
2067: {
2068: my $pf = IO::File->new(">$passfilename");
2069: print $pf "none:\n";
2070: }
2071: } else {
2072: $result="auth_mode_error\n";
2073: }
2074: return $result;
2075: }
2076:
2077: sub sethost {
2078: my ($remotereq) = @_;
2079: my (undef,$hostid)=split(/:/,$remotereq);
2080: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
2081: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
2082: $currenthostid=$hostid;
2083: $currentdomainid=$hostdom{$hostid};
2084: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
2085: } else {
2086: &logthis("Requested host id $hostid not an alias of ".
2087: $perlvar{'lonHostID'}." refusing connection");
2088: return 'unable_to_set';
2089: }
2090: return 'ok';
2091: }
2092:
2093: sub version {
2094: my ($userinput)=@_;
2095: $remoteVERSION=(split(/:/,$userinput))[1];
2096: return "version:$VERSION";
2097: }
2098:
2099: #There is a copy of this in lonnet.pm
2100: sub userload {
2101: my $numusers=0;
2102: {
2103: opendir(LONIDS,$perlvar{'lonIDsDir'});
2104: my $filename;
2105: my $curtime=time;
2106: while ($filename=readdir(LONIDS)) {
2107: if ($filename eq '.' || $filename eq '..') {next;}
2108: my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
2109: if ($curtime-$atime < 3600) { $numusers++; }
2110: }
2111: closedir(LONIDS);
2112: }
2113: my $userloadpercent=0;
2114: my $maxuserload=$perlvar{'lonUserLoadLim'};
2115: if ($maxuserload) {
2116: $userloadpercent=100*$numusers/$maxuserload;
2117: }
2118: $userloadpercent=sprintf("%.2f",$userloadpercent);
2119: return $userloadpercent;
2120: }
2121:
2122: # ----------------------------------- POD (plain old documentation, CPAN style)
2123:
2124: =head1 NAME
2125:
2126: lond - "LON Daemon" Server (port "LOND" 5663)
2127:
2128: =head1 SYNOPSIS
2129:
2130: Usage: B<lond>
2131:
2132: Should only be run as user=www. This is a command-line script which
2133: is invoked by B<loncron>. There is no expectation that a typical user
2134: will manually start B<lond> from the command-line. (In other words,
2135: DO NOT START B<lond> YOURSELF.)
2136:
2137: =head1 DESCRIPTION
2138:
2139: There are two characteristics associated with the running of B<lond>,
2140: PROCESS MANAGEMENT (starting, stopping, handling child processes)
2141: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
2142: subscriptions, etc). These are described in two large
2143: sections below.
2144:
2145: B<PROCESS MANAGEMENT>
2146:
2147: Preforker - server who forks first. Runs as a daemon. HUPs.
2148: Uses IDEA encryption
2149:
2150: B<lond> forks off children processes that correspond to the other servers
2151: in the network. Management of these processes can be done at the
2152: parent process level or the child process level.
2153:
2154: B<logs/lond.log> is the location of log messages.
2155:
2156: The process management is now explained in terms of linux shell commands,
2157: subroutines internal to this code, and signal assignments:
2158:
2159: =over 4
2160:
2161: =item *
2162:
2163: PID is stored in B<logs/lond.pid>
2164:
2165: This is the process id number of the parent B<lond> process.
2166:
2167: =item *
2168:
2169: SIGTERM and SIGINT
2170:
2171: Parent signal assignment:
2172: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
2173:
2174: Child signal assignment:
2175: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
2176: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
2177: to restart a new child.)
2178:
2179: Command-line invocations:
2180: B<kill> B<-s> SIGTERM I<PID>
2181: B<kill> B<-s> SIGINT I<PID>
2182:
2183: Subroutine B<HUNTSMAN>:
2184: This is only invoked for the B<lond> parent I<PID>.
2185: This kills all the children, and then the parent.
2186: The B<lonc.pid> file is cleared.
2187:
2188: =item *
2189:
2190: SIGHUP
2191:
2192: Current bug:
2193: This signal can only be processed the first time
2194: on the parent process. Subsequent SIGHUP signals
2195: have no effect.
2196:
2197: Parent signal assignment:
2198: $SIG{HUP} = \&HUPSMAN;
2199:
2200: Child signal assignment:
2201: none (nothing happens)
2202:
2203: Command-line invocations:
2204: B<kill> B<-s> SIGHUP I<PID>
2205:
2206: Subroutine B<HUPSMAN>:
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<lond.pid> file is cleared.
2210:
2211: =item *
2212:
2213: SIGUSR1
2214:
2215: Parent signal assignment:
2216: $SIG{USR1} = \&USRMAN;
2217:
2218: Child signal assignment:
2219: $SIG{USR1}= \&logstatus;
2220:
2221: Command-line invocations:
2222: B<kill> B<-s> SIGUSR1 I<PID>
2223:
2224: Subroutine B<USRMAN>:
2225: When invoked for the B<lond> parent I<PID>,
2226: SIGUSR1 is sent to all the children, and the status of
2227: each connection is logged.
2228:
2229: =item *
2230:
2231: SIGCHLD
2232:
2233: Parent signal assignment:
2234: $SIG{CHLD} = \&REAPER;
2235:
2236: Child signal assignment:
2237: none
2238:
2239: Command-line invocations:
2240: B<kill> B<-s> SIGCHLD I<PID>
2241:
2242: Subroutine B<REAPER>:
2243: This is only invoked for the B<lond> parent I<PID>.
2244: Information pertaining to the child is removed.
2245: The socket port is cleaned up.
2246:
2247: =back
2248:
2249: B<SERVER-SIDE ACTIVITIES>
2250:
2251: Server-side information can be accepted in an encrypted or non-encrypted
2252: method.
2253:
2254: =over 4
2255:
2256: =item ping
2257:
2258: Query a client in the hosts.tab table; "Are you there?"
2259:
2260: =item pong
2261:
2262: Respond to a ping query.
2263:
2264: =item ekey
2265:
2266: Read in encrypted key, make cipher. Respond with a buildkey.
2267:
2268: =item load
2269:
2270: Respond with CPU load based on a computation upon /proc/loadavg.
2271:
2272: =item currentauth
2273:
2274: Reply with current authentication information (only over an
2275: encrypted channel).
2276:
2277: =item auth
2278:
2279: Only over an encrypted channel, reply as to whether a user's
2280: authentication information can be validated.
2281:
2282: =item passwd
2283:
2284: Allow for a password to be set.
2285:
2286: =item makeuser
2287:
2288: Make a user.
2289:
2290: =item passwd
2291:
2292: Allow for authentication mechanism and password to be changed.
2293:
2294: =item home
2295:
2296: Respond to a question "are you the home for a given user?"
2297:
2298: =item update
2299:
2300: Update contents of a subscribed resource.
2301:
2302: =item unsubscribe
2303:
2304: The server is unsubscribing from a resource.
2305:
2306: =item subscribe
2307:
2308: The server is subscribing to a resource.
2309:
2310: =item log
2311:
2312: Place in B<logs/lond.log>
2313:
2314: =item put
2315:
2316: stores hash in namespace
2317:
2318: =item rolesput
2319:
2320: put a role into a user's environment
2321:
2322: =item get
2323:
2324: returns hash with keys from array
2325: reference filled in from namespace
2326:
2327: =item eget
2328:
2329: returns hash with keys from array
2330: reference filled in from namesp (encrypts the return communication)
2331:
2332: =item rolesget
2333:
2334: get a role from a user's environment
2335:
2336: =item del
2337:
2338: deletes keys out of array from namespace
2339:
2340: =item keys
2341:
2342: returns namespace keys
2343:
2344: =item dump
2345:
2346: dumps the complete (or key matching regexp) namespace into a hash
2347:
2348: =item store
2349:
2350: stores hash permanently
2351: for this url; hashref needs to be given and should be a \%hashname; the
2352: remaining args aren't required and if they aren't passed or are '' they will
2353: be derived from the ENV
2354:
2355: =item restore
2356:
2357: returns a hash for a given url
2358:
2359: =item querysend
2360:
2361: Tells client about the lonsql process that has been launched in response
2362: to a sent query.
2363:
2364: =item queryreply
2365:
2366: Accept information from lonsql and make appropriate storage in temporary
2367: file space.
2368:
2369: =item idput
2370:
2371: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
2372: for each student, defined perhaps by the institutional Registrar.)
2373:
2374: =item idget
2375:
2376: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
2377: for each student, defined perhaps by the institutional Registrar.)
2378:
2379: =item tmpput
2380:
2381: Accept and store information in temporary space.
2382:
2383: =item tmpget
2384:
2385: Send along temporarily stored information.
2386:
2387: =item ls
2388:
2389: List part of a user's directory.
2390:
2391: =item pushtable
2392:
2393: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
2394: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
2395: must be restored manually in case of a problem with the new table file.
2396: pushtable requires that the request be encrypted and validated via
2397: ValidateManager. The form of the command is:
2398: enc:pushtable tablename <tablecontents> \n
2399: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
2400: cleartext newline.
2401:
2402: =item Hanging up (exit or init)
2403:
2404: What to do when a client tells the server that they (the client)
2405: are leaving the network.
2406:
2407: =item unknown command
2408:
2409: If B<lond> is sent an unknown command (not in the list above),
2410: it replys to the client "unknown_cmd".
2411:
2412:
2413: =item UNKNOWN CLIENT
2414:
2415: If the anti-spoofing algorithm cannot verify the client,
2416: the client is rejected (with a "refused" message sent
2417: to the client, and the connection is closed.
2418:
2419: =back
2420:
2421: =head1 PREREQUISITES
2422:
2423: IO::Socket
2424: IO::File
2425: Apache::File
2426: Symbol
2427: POSIX
2428: Crypt::IDEA
2429: LWP::UserAgent()
2430: GDBM_File
2431: Authen::Krb4
2432: Authen::Krb5
2433:
2434: =head1 COREQUISITES
2435:
2436: =head1 OSNAMES
2437:
2438: linux
2439:
2440: =head1 SCRIPT CATEGORIES
2441:
2442: Server/Process
2443:
2444: =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