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