Annotation of loncom/lond, revision 1.136
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.136 ! www 5: # $Id: lond,v 1.135 2003/08/12 09:39:23 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.135 foxr 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
1.54 harris41 60: ###
61:
1.134 albertel 62: use strict;
1.80 harris41 63: use lib '/home/httpd/lib/perl/';
64: use LONCAPA::Configuration;
65:
1.1 albertel 66: use IO::Socket;
67: use IO::File;
1.126 albertel 68: #use Apache::File;
1.1 albertel 69: use Symbol;
70: use POSIX;
71: use Crypt::IDEA;
72: use LWP::UserAgent();
1.3 www 73: use GDBM_File;
74: use Authen::Krb4;
1.91 albertel 75: use Authen::Krb5;
1.49 albertel 76: use lib '/home/httpd/lib/perl/';
77: use localauth;
1.1 albertel 78:
1.77 foxr 79: my $DEBUG = 0; # Non zero to enable debug log entries.
80:
1.57 www 81: my $status='';
82: my $lastlog='';
83:
1.136 ! www 84: my $VERSION='$Revision: 1.135 $'; #' stupid emacs
1.121 albertel 85: my $remoteVERSION;
1.115 albertel 86: my $currenthostid;
87: my $currentdomainid;
1.134 albertel 88:
89: my $client;
90: my $server;
91: my $thisserver;
92:
93: my %hostid;
94: my %hostdom;
95: my %hostip;
96:
1.96 foxr 97: #
98: # The array below are password error strings."
99: #
1.97 foxr 100: my $lastpwderror = 13; # Largest error number from lcpasswd.
1.96 foxr 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",
1.97 foxr 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:
1.96 foxr 134:
135: #
136: # Convert an error return code from lcpasswd to a string value.
137: #
138: sub lcpasswdstrerror {
139: my $ErrorCode = shift;
1.97 foxr 140: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96 foxr 141: return "lcpasswd Unrecognized error return value ".$ErrorCode;
142: } else {
1.98 foxr 143: return $passwderrors[$ErrorCode];
1.96 foxr 144: }
145: }
146:
1.97 foxr 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 {
1.98 foxr 155: return $adderrors[$ErrorCode];
1.97 foxr 156: }
157: }
158:
1.23 harris41 159: # grabs exception and records it to log before exiting
160: sub catchexception {
1.27 albertel 161: my ($error)=@_;
1.25 www 162: $SIG{'QUIT'}='DEFAULT';
163: $SIG{__DIE__}='DEFAULT';
1.23 harris41 164: &logthis("<font color=red>CRITICAL: "
1.134 albertel 165: ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
1.27 albertel 166: ."a crash with this error msg->[$error]</font>");
1.57 www 167: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 168: if ($client) { print $client "error: $error\n"; }
1.59 www 169: $server->close();
1.27 albertel 170: die($error);
1.23 harris41 171: }
172:
1.63 www 173: sub timeout {
174: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
175: &catchexception('Timeout');
176: }
1.22 harris41 177: # -------------------------------- Set signal handlers to record abnormal exits
178:
179: $SIG{'QUIT'}=\&catchexception;
180: $SIG{__DIE__}=\&catchexception;
181:
1.81 matthew 182: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95 harris41 183: &status("Read loncapa.conf and loncapa_apache.conf");
184: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.80 harris41 185: my %perlvar=%{$perlvarref};
186: undef $perlvarref;
1.19 www 187:
1.35 harris41 188: # ----------------------------- Make sure this process is running from user=www
189: my $wwwid=getpwnam('www');
190: if ($wwwid!=$<) {
1.134 albertel 191: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
192: my $subj="LON: $currenthostid User ID mismatch";
1.37 harris41 193: system("echo 'User ID mismatch. lond must be run as user www.' |\
1.35 harris41 194: mailto $emailto -s '$subj' > /dev/null");
195: exit 1;
196: }
197:
1.19 www 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);
1.29 harris41 206: if (kill 0 => $pide) { die "already running"; }
1.19 www 207: }
1.1 albertel 208:
209: # ------------------------------------------------------------- Read hosts file
210:
1.29 harris41 211: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.1 albertel 212:
1.134 albertel 213: while (my $configline=<CONFIG>) {
1.1 albertel 214: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1.70 harris41 215: chomp($ip); $ip=~s/\D+$//;
1.1 albertel 216: $hostid{$ip}=$id;
1.115 albertel 217: $hostdom{$id}=$domain;
218: $hostip{$id}=$ip;
1.116 albertel 219: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
1.1 albertel 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 )
1.29 harris41 229: or die "making socket: $@\n";
1.1 albertel 230:
231: # --------------------------------------------------------- Do global variables
232:
233: # global variables
234:
1.134 albertel 235: my %children = (); # keys are current child process IDs
236: my $children = 0; # current number of children
1.1 albertel 237:
238: sub REAPER { # takes care of dead children
239: $SIG{CHLD} = \&REAPER;
240: my $pid = wait;
1.67 albertel 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: }
1.1 albertel 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;
1.59 www 253: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 254: my $execdir=$perlvar{'lonDaemons'};
255: unlink("$execdir/logs/lond.pid");
1.9 www 256: &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.1 albertel 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;
1.59 www 263: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.9 www 264: &logthis("<font color=red>CRITICAL: Restarting</font>");
1.134 albertel 265: my $execdir=$perlvar{'lonDaemons'};
1.30 harris41 266: unlink("$execdir/logs/lond.pid");
1.1 albertel 267: exec("$execdir/lond"); # here we go again
268: }
269:
1.57 www 270: sub checkchildren {
271: &initnewstatus();
272: &logstatus();
273: &logthis('Going to check on the children');
1.134 albertel 274: my $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 275: foreach (sort keys %children) {
1.57 www 276: sleep 1;
277: unless (kill 'USR1' => $_) {
278: &logthis ('Child '.$_.' is dead');
279: &logstatus($$.' is dead');
280: }
1.61 harris41 281: }
1.63 www 282: sleep 5;
1.113 albertel 283: $SIG{ALRM} = sub { die "timeout" };
284: $SIG{__DIE__} = 'DEFAULT';
1.63 www 285: foreach (sort keys %children) {
286: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.113 albertel 287: eval {
288: alarm(300);
1.63 www 289: &logthis('Child '.$_.' did not respond');
1.67 albertel 290: kill 9 => $_;
1.131 albertel 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.$_`;
1.113 albertel 296: alarm(0);
297: }
1.63 www 298: }
299: }
1.113 albertel 300: $SIG{ALRM} = 'DEFAULT';
301: $SIG{__DIE__} = \&cathcexception;
1.57 www 302: }
303:
1.1 albertel 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);
1.58 www 312: $lastlog=$local.': '.$message;
1.1 albertel 313: print $fh "$local ($$): $message\n";
314: }
315:
1.77 foxr 316: # ------------------------- Conditional log if $DEBUG true.
317: sub Debug {
318: my $message = shift;
319: if($DEBUG) {
320: &logthis($message);
321: }
322: }
1.57 www 323: # ------------------------------------------------------------------ Log status
324:
325: sub logstatus {
326: my $docdir=$perlvar{'lonDocRoot'};
1.63 www 327: {
1.57 www 328: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
1.115 albertel 329: print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
1.63 www 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: }
1.57 www 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";
1.64 www 345: opendir(DIR,"$docdir/lon-status/londchld");
1.134 albertel 346: while (my $filename=readdir(DIR)) {
1.64 www 347: unlink("$docdir/lon-status/londchld/$filename");
348: }
349: closedir(DIR);
1.57 www 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;
1.103 www 359: $0='lond: '.$what.' '.$local;
1.57 www 360: }
1.11 www 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:
1.1 albertel 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 {
1.9 www 391: &logthis(
392: "<font color=red>CRITICAL: "
393: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 394: }
395: } else {
1.9 www 396: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
1.1 albertel 397: }
398: }
399:
400: # -------------------------------------------------- Non-critical communication
1.11 www 401:
1.1 albertel 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;
1.115 albertel 419: if ($server ne $currenthostid) {
1.1 albertel 420: $answer=subreply($cmd,$server);
421: if ($answer eq 'con_lost') {
422: $answer=subreply("ping",$server);
423: if ($answer ne $server) {
1.115 albertel 424: &logthis("sub reply: answer != server answer is $answer, server is $server");
1.1 albertel 425: &reconlonc("$perlvar{'lonSockDir'}/$server");
426: }
427: $answer=subreply($cmd,$server);
428: }
429: } else {
430: $answer='self_reply';
431: }
432: return $answer;
433: }
434:
1.13 www 435: # -------------------------------------------------------------- Talk to lonsql
436:
1.12 harris41 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:
1.1 albertel 459: # -------------------------------------------- Return path to profile directory
1.11 www 460:
1.1 albertel 461: sub propath {
462: my ($udom,$uname)=@_;
463: $udom=~s/\W//g;
464: $uname=~s/\W//g;
1.16 www 465: my $subdir=$uname.'__';
1.1 albertel 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?
1.11 www 472:
1.1 albertel 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:
1.134 albertel 488: my $fpid=fork;
1.1 albertel 489: exit if $fpid;
1.29 harris41 490: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 491:
1.29 harris41 492: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 493:
494: # ------------------------------------------------------- Write our PID on disk
495:
1.134 albertel 496: my $execdir=$perlvar{'lonDaemons'};
1.1 albertel 497: open (PIDSAVE,">$execdir/logs/lond.pid");
498: print PIDSAVE "$$\n";
499: close(PIDSAVE);
1.9 www 500: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.57 www 501: &status('Starting');
1.1 albertel 502:
1.106 foxr 503:
1.1 albertel 504:
505: # ----------------------------------------------------- Install signal handlers
506:
1.57 www 507:
1.1 albertel 508: $SIG{CHLD} = \&REAPER;
509: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
510: $SIG{HUP} = \&HUPSMAN;
1.57 www 511: $SIG{USR1} = \&checkchildren;
1.1 albertel 512:
1.106 foxr 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:
1.1 albertel 520: while (1) {
1.106 foxr 521: $client = $server->accept() or next;
522: make_new_child($client);
1.1 albertel 523: }
524:
525: sub make_new_child {
526: my $pid;
527: my $cipher;
528: my $sigset;
1.106 foxr 529:
530: $client = shift;
1.1 albertel 531: &logthis("Attempting to start child");
532: # block signal for fork
533: $sigset = POSIX::SigSet->new(SIGINT);
534: sigprocmask(SIG_BLOCK, $sigset)
1.29 harris41 535: or die "Can't block SIGINT for fork: $!\n";
1.134 albertel 536:
537: my $clientip;
1.29 harris41 538: die "fork: $!" unless defined ($pid = fork);
1.1 albertel 539:
540: if ($pid) {
541: # Parent records the child's birth and returns.
542: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 543: or die "Can't unblock SIGINT for fork: $!\n";
1.1 albertel 544: $children{$pid} = 1;
545: $children++;
1.57 www 546: &status('Started child '.$pid);
1.1 albertel 547: return;
548: } else {
549: # Child can *not* return from this subroutine.
550: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.126 albertel 551: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
552: #don't get intercepted
1.57 www 553: $SIG{USR1}= \&logstatus;
1.63 www 554: $SIG{ALRM}= \&timeout;
1.57 www 555: $lastlog='Forked ';
556: $status='Forked';
557:
1.1 albertel 558: # unblock signals
559: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 560: or die "Can't unblock SIGINT for fork: $!\n";
1.13 www 561:
1.134 albertel 562: my $tmpsnum=0;
1.91 albertel 563: #---------------------------------------------------- kerberos 5 initialization
564: &Authen::Krb5::init_context();
565: &Authen::Krb5::init_ets();
566:
1.57 www 567: &status('Accepted connection');
1.1 albertel 568: # =============================================================================
569: # do something with the connection
570: # -----------------------------------------------------------------------------
1.94 albertel 571: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
572: # connection liveness.
1.2 www 573: # see if we know client and check for spoof IP by challenge
1.106 foxr 574: my $caller = getpeername($client);
1.1 albertel 575: my ($port,$iaddr)=unpack_sockaddr_in($caller);
1.134 albertel 576: $clientip=inet_ntoa($iaddr);
1.1 albertel 577: my $clientrec=($hostid{$clientip} ne undef);
1.9 www 578: &logthis(
1.115 albertel 579: "<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
1.51 www 580: );
1.57 www 581: &status("Connecting $clientip ($hostid{$clientip})");
1.2 www 582: my $clientok;
1.1 albertel 583: if ($clientrec) {
1.57 www 584: &status("Waiting for init from $clientip ($hostid{$clientip})");
1.2 www 585: my $remotereq=<$client>;
1.115 albertel 586: $remotereq=~s/[^\w:]//g;
587: if ($remotereq =~ /^init/) {
1.121 albertel 588: &sethost("sethost:$perlvar{'lonHostID'}");
1.2 www 589: my $challenge="$$".time;
590: print $client "$challenge\n";
1.57 www 591: &status(
592: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
1.2 www 593: $remotereq=<$client>;
594: $remotereq=~s/\W//g;
595: if ($challenge eq $remotereq) {
596: $clientok=1;
597: print $client "ok\n";
598: } else {
1.9 www 599: &logthis(
600: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
1.57 www 601: &status('No challenge reply '.$clientip);
1.2 www 602: }
603: } else {
1.9 www 604: &logthis(
605: "<font color=blue>WARNING: "
606: ."$clientip failed to initialize: >$remotereq< </font>");
1.57 www 607: &status('No init '.$clientip);
1.2 www 608: }
609: } else {
1.9 www 610: &logthis(
611: "<font color=blue>WARNING: Unknown client $clientip</font>");
1.57 www 612: &status('Hung up on '.$clientip);
1.2 www 613: }
614: if ($clientok) {
1.1 albertel 615: # ---------------- New known client connecting, could mean machine online again
1.75 foxr 616:
1.115 albertel 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>");
1.58 www 626: &status('Will listen to '.$hostid{$clientip});
1.1 albertel 627: # ------------------------------------------------------------ Process requests
628: while (my $userinput=<$client>) {
629: chomp($userinput);
1.79 foxr 630: Debug("Request = $userinput\n");
1.57 www 631: &status('Processing '.$hostid{$clientip}.': '.$userinput);
1.1 albertel 632: my $wasenc=0;
1.63 www 633: alarm(120);
1.1 albertel 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: }
1.75 foxr 648: }
649:
1.1 albertel 650: # ------------------------------------------------------------- Normal commands
651: # ------------------------------------------------------------------------ ping
652: if ($userinput =~ /^ping/) {
1.115 albertel 653: print $client "$currenthostid\n";
1.1 albertel 654: # ------------------------------------------------------------------------ pong
655: } elsif ($userinput =~ /^pong/) {
1.134 albertel 656: my $reply=&reply("ping",$hostid{$clientip});
1.115 albertel 657: print $client "$currenthostid:$reply\n";
1.1 albertel 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);
1.115 albertel 663: my $key=$currenthostid.$hostid{$clientip};
1.1 albertel 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;
1.127 albertel 680: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1.1 albertel 681: print $client "$loadpercent\n";
1.127 albertel 682: # -------------------------------------------------------------------- userload
683: } elsif ($userinput =~ /^userload/) {
684: my $userloadpercent=&userload();
685: print $client "$userloadpercent\n";
1.54 harris41 686: # ----------------------------------------------------------------- currentauth
687: } elsif ($userinput =~ /^currentauth/) {
688: if ($wasenc==1) {
689: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1.79 foxr 690: my $result = GetAuthType($udom, $uname);
1.78 foxr 691: if($result eq "nouser") {
692: print $client "unknown_user\n";
693: }
694: else {
695: print $client "$result\n"
696: }
1.54 harris41 697: } else {
698: print $client "refused\n";
699: }
1.1 albertel 700: # ------------------------------------------------------------------------ auth
701: } elsif ($userinput =~ /^auth/) {
702: if ($wasenc==1) {
703: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
704: chomp($upass);
1.11 www 705: $upass=unescape($upass);
1.1 albertel 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);
1.2 www 712: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
713: my $pwdcorrect=0;
714: if ($howpwd eq 'internal') {
1.99 foxr 715: &Debug("Internal auth");
1.2 www 716: $pwdcorrect=
717: (crypt($upass,$contentpwd) eq $contentpwd);
718: } elsif ($howpwd eq 'unix') {
1.99 foxr 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:
1.52 harris41 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=!$?;
1.99 foxr 737: }
1.52 harris41 738: }
1.3 www 739: } elsif ($howpwd eq 'krb4') {
1.134 albertel 740: my $null=pack("C",0);
1.104 matthew 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: }
1.91 albertel 756: } elsif ($howpwd eq 'krb5') {
1.134 albertel 757: my $null=pack("C",0);
1.91 albertel 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);
1.92 albertel 767: # unless ($krbreturn) {
768: # &logthis("Krb5 Error: ".
769: # &Authen::Krb5::error());
770: # }
1.91 albertel 771: $pwdcorrect = ($krbreturn == 1);
772: } else { $pwdcorrect=0; }
1.50 albertel 773: } elsif ($howpwd eq 'localauth') {
1.49 albertel 774: $pwdcorrect=&localauth::localauth($uname,$upass,
775: $contentpwd);
776: }
1.2 www 777: if ($pwdcorrect) {
1.1 albertel 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);
1.32 www 794: $upass=&unescape($upass);
795: $npass=&unescape($npass);
1.98 foxr 796: &Debug("Trying to change password for $uname");
1.72 matthew 797: my $proname=propath($udom,$uname);
1.1 albertel 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);
1.2 www 804: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
805: if ($howpwd eq 'internal') {
1.98 foxr 806: &Debug("internal auth");
1.2 www 807: if (crypt($upass,$contentpwd) eq $contentpwd) {
808: my $salt=time;
809: $salt=substr($salt,6,2);
810: my $ncpass=crypt($npass,$salt);
1.1 albertel 811: { my $pf = IO::File->new(">$passfilename");
1.31 www 812: print $pf "internal:$ncpass\n"; }
1.72 matthew 813: &logthis("Result of password change for $uname: pwchange_success");
1.1 albertel 814: print $client "ok\n";
1.2 www 815: } else {
816: print $client "non_authorized\n";
817: }
1.72 matthew 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
1.98 foxr 823: &Debug("auth is unix");
1.72 matthew 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;
1.98 foxr 835: &Debug("exited pwauth with $? ($uname,$upass) ");
836: $pwdcorrect=($? == 0);
1.72 matthew 837: }
838: if ($pwdcorrect) {
839: my $execdir=$perlvar{'lonDaemons'};
1.98 foxr 840: &Debug("Opening lcpasswd pipeline");
1.132 matthew 841: my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
1.72 matthew 842: print $pf "$uname\n$npass\n$npass\n";
843: close $pf;
1.97 foxr 844: my $err = $?;
845: my $result = ($err>0 ? 'pwchange_failure'
1.72 matthew 846: : 'ok');
1.96 foxr 847: &logthis("Result of password change for $uname: ".
848: &lcpasswdstrerror($?));
1.72 matthew 849: print $client "$result\n";
850: } else {
851: print $client "non_authorized\n";
852: }
853: } else {
1.2 www 854: print $client "auth_mode_error\n";
1.1 albertel 855: }
856: } else {
857: print $client "unknown_user\n";
1.31 www 858: }
859: } else {
860: print $client "refused\n";
861: }
862: # -------------------------------------------------------------------- makeuser
863: } elsif ($userinput =~ /^makeuser/) {
1.91 albertel 864: &Debug("Make user received");
1.56 harris41 865: my $oldumask=umask(0077);
1.31 www 866: if ($wasenc==1) {
867: my
868: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
1.77 foxr 869: &Debug("cmd =".$cmd." $udom =".$udom.
870: " uname=".$uname);
1.31 www 871: chomp($npass);
1.32 www 872: $npass=&unescape($npass);
1.31 www 873: my $proname=propath($udom,$uname);
874: my $passfilename="$proname/passwd";
1.77 foxr 875: &Debug("Password file created will be:".
876: $passfilename);
1.31 www 877: if (-e $passfilename) {
878: print $client "already_exists\n";
1.115 albertel 879: } elsif ($udom ne $currentdomainid) {
1.31 www 880: print $client "not_right_domain\n";
881: } else {
1.134 albertel 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++) {
1.31 www 886: $fpnow.='/'.$fpparts[$i];
887: unless (-e $fpnow) {
888: unless (mkdir($fpnow,0777)) {
1.109 foxr 889: $fperror="error: ".($!+0)
1.111 matthew 890: ." mkdir failed while attempting "
891: ."makeuser\n";
1.31 www 892: }
893: }
894: }
895: unless ($fperror) {
1.98 foxr 896: my $result=&make_passwd_file($uname, $umode,$npass,
1.91 albertel 897: $passfilename);
898: print $client $result;
1.31 www 899: } else {
900: print $client "$fperror\n";
901: }
1.55 harris41 902: }
903: } else {
904: print $client "refused\n";
905: }
1.56 harris41 906: umask($oldumask);
1.55 harris41 907: # -------------------------------------------------------------- changeuserauth
908: } elsif ($userinput =~ /^changeuserauth/) {
1.77 foxr 909: &Debug("Changing authorization");
910: if ($wasenc==1) {
1.55 harris41 911: my
1.91 albertel 912: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
1.55 harris41 913: chomp($npass);
1.77 foxr 914: &Debug("cmd = ".$cmd." domain= ".$udom.
915: "uname =".$uname." umode= ".$umode);
1.55 harris41 916: $npass=&unescape($npass);
1.91 albertel 917: my $proname=&propath($udom,$uname);
1.55 harris41 918: my $passfilename="$proname/passwd";
1.115 albertel 919: if ($udom ne $currentdomainid) {
1.55 harris41 920: print $client "not_right_domain\n";
921: } else {
1.98 foxr 922: my $result=&make_passwd_file($uname, $umode,$npass,
1.93 albertel 923: $passfilename);
1.91 albertel 924: print $client $result;
1.1 albertel 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);
1.134 albertel 949: my $now=time;
950: my $since=$now-$atime;
1.1 albertel 951: if ($since>$perlvar{'lonExpire'}) {
1.134 albertel 952: my $reply=
953: &reply("unsub:$fname","$hostid{$clientip}");
1.1 albertel 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()) {
1.24 albertel 966: unlink($transname);
1.1 albertel 967: my $message=$response->status_line;
968: &logthis(
969: "LWP GET: $message for $fname ($remoteurl)");
970: } else {
1.14 www 971: if ($remoteurl!~/\.meta$/) {
1.28 www 972: my $ua=new LWP::UserAgent;
1.14 www 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: }
1.1 albertel 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: }
1.85 www 991: # -------------------------------------- fetch a user file from a remote server
992: } elsif ($userinput =~ /^fetchuserfile/) {
1.86 www 993: my ($cmd,$fname)=split(/:/,$userinput);
994: my ($udom,$uname,$ufile)=split(/\//,$fname);
995: my $udir=propath($udom,$uname).'/userfiles';
1.88 albertel 996: unless (-e $udir) { mkdir($udir,0770); }
1.86 www 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: }
1.85 www 1020: # ------------------------------------------ authenticate access to a user file
1.86 www 1021: } elsif ($userinput =~ /^tokenauthuserfile/) {
1.85 www 1022: my ($cmd,$fname,$session)=split(/:/,$userinput);
1.86 www 1023: chomp($session);
1.134 albertel 1024: my $reply='non_auth';
1.86 www 1025: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
1.134 albertel 1026: $session.'.id')) {
1027: while (my $line=<ENVIN>) {
1028: if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
1029: }
1030: close(ENVIN);
1031: print $client $reply."\n";
1.86 www 1032: } else {
1.134 albertel 1033: print $client "invalid_token\n";
1.86 www 1034: }
1.1 albertel 1035: # ----------------------------------------------------------------- unsubscribe
1036: } elsif ($userinput =~ /^unsub/) {
1037: my ($cmd,$fname)=split(/:/,$userinput);
1038: if (-e $fname) {
1.84 albertel 1039: print $client &unsub($client,$fname,$clientip);
1.1 albertel 1040: } else {
1041: print $client "not_found\n";
1042: }
1043: # ------------------------------------------------------------------- subscribe
1044: } elsif ($userinput =~ /^sub/) {
1.84 albertel 1045: print $client &subscribe($userinput,$clientip);
1.102 www 1046: # ------------------------------------------------------------- current version
1047: } elsif ($userinput =~ /^currentversion/) {
1048: my ($cmd,$fname)=split(/:/,$userinput);
1049: print $client ¤tversion($fname)."\n";
1.12 harris41 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 {
1.109 foxr 1062: print $client "error: ".($!+0)
1.111 matthew 1063: ." IO::File->new Failed "
1064: ."while attempting log\n";
1.12 harris41 1065: }
1066: }
1.1 albertel 1067: # ------------------------------------------------------------------------- put
1068: } elsif ($userinput =~ /^put/) {
1.6 www 1069: my ($cmd,$udom,$uname,$namespace,$what)
1.1 albertel 1070: =split(/:/,$userinput);
1.8 www 1071: $namespace=~s/\//\_/g;
1.6 www 1072: $namespace=~s/\W//g;
1073: if ($namespace ne 'roles') {
1.1 albertel 1074: chomp($what);
1075: my $proname=propath($udom,$uname);
1076: my $now=time;
1.48 www 1077: unless ($namespace=~/^nohist\_/) {
1.1 albertel 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);
1.134 albertel 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);
1.1 albertel 1088: $hash{$key}=$value;
1089: }
1.4 www 1090: if (untie(%hash)) {
1.1 albertel 1091: print $client "ok\n";
1092: } else {
1.109 foxr 1093: print $client "error: ".($!+0)
1.111 matthew 1094: ." untie(GDBM) failed ".
1095: "while attempting put\n";
1.1 albertel 1096: }
1097: } else {
1.109 foxr 1098: print $client "error: ".($!)
1.111 matthew 1099: ." tie(GDBM) Failed ".
1100: "while attempting put\n";
1.1 albertel 1101: }
1.6 www 1102: } else {
1103: print $client "refused\n";
1104: }
1105: # -------------------------------------------------------------------- rolesput
1106: } elsif ($userinput =~ /^rolesput/) {
1.77 foxr 1107: &Debug("rolesput");
1.6 www 1108: if ($wasenc==1) {
1109: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1110: =split(/:/,$userinput);
1.77 foxr 1111: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1112: "user = ".$exeuser." udom=".$udom.
1113: "what = ".$what);
1.6 www 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);
1.134 albertel 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);
1.78 foxr 1131: &ManagePermissions($key, $udom, $uname,
1132: &GetAuthType( $udom,
1133: $uname));
1.6 www 1134: $hash{$key}=$value;
1135: }
1136: if (untie(%hash)) {
1137: print $client "ok\n";
1138: } else {
1.109 foxr 1139: print $client "error: ".($!+0)
1.111 matthew 1140: ." untie(GDBM) Failed ".
1141: "while attempting rolesput\n";
1.6 www 1142: }
1143: } else {
1.109 foxr 1144: print $client "error: ".($!+0)
1.111 matthew 1145: ." tie(GDBM) Failed ".
1146: "while attempting rolesput\n";
1.117 www 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);
1.134 albertel 1173: my %hash;
1174: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1175: foreach my $key (@rolekeys) {
1.117 www 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";
1.6 www 1189: }
1190: } else {
1191: print $client "refused\n";
1192: }
1.1 albertel 1193: # ------------------------------------------------------------------------- get
1194: } elsif ($userinput =~ /^get/) {
1195: my ($cmd,$udom,$uname,$namespace,$what)
1196: =split(/:/,$userinput);
1.8 www 1197: $namespace=~s/\//\_/g;
1.1 albertel 1198: $namespace=~s/\W//g;
1199: chomp($what);
1200: my @queries=split(/\&/,$what);
1201: my $proname=propath($udom,$uname);
1202: my $qresult='';
1.134 albertel 1203: my %hash;
1204: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1205: for (my $i=0;$i<=$#queries;$i++) {
1.1 albertel 1206: $qresult.="$hash{$queries[$i]}&";
1207: }
1.4 www 1208: if (untie(%hash)) {
1.1 albertel 1209: $qresult=~s/\&$//;
1210: print $client "$qresult\n";
1211: } else {
1.109 foxr 1212: print $client "error: ".($!+0)
1.111 matthew 1213: ." untie(GDBM) Failed ".
1214: "while attempting get\n";
1.1 albertel 1215: }
1216: } else {
1.112 matthew 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: }
1.1 albertel 1225: }
1226: # ------------------------------------------------------------------------ eget
1227: } elsif ($userinput =~ /^eget/) {
1228: my ($cmd,$udom,$uname,$namespace,$what)
1229: =split(/:/,$userinput);
1.8 www 1230: $namespace=~s/\//\_/g;
1.1 albertel 1231: $namespace=~s/\W//g;
1232: chomp($what);
1233: my @queries=split(/\&/,$what);
1234: my $proname=propath($udom,$uname);
1235: my $qresult='';
1.134 albertel 1236: my %hash;
1237: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1238: for (my $i=0;$i<=$#queries;$i++) {
1.1 albertel 1239: $qresult.="$hash{$queries[$i]}&";
1240: }
1.4 www 1241: if (untie(%hash)) {
1.1 albertel 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 {
1.109 foxr 1258: print $client "error: ".($!+0)
1.111 matthew 1259: ." untie(GDBM) Failed ".
1260: "while attempting eget\n";
1.1 albertel 1261: }
1262: } else {
1.109 foxr 1263: print $client "error: ".($!+0)
1.111 matthew 1264: ." tie(GDBM) Failed ".
1265: "while attempting eget\n";
1.1 albertel 1266: }
1267: # ------------------------------------------------------------------------- del
1268: } elsif ($userinput =~ /^del/) {
1269: my ($cmd,$udom,$uname,$namespace,$what)
1270: =split(/:/,$userinput);
1.8 www 1271: $namespace=~s/\//\_/g;
1.1 albertel 1272: $namespace=~s/\W//g;
1273: chomp($what);
1274: my $proname=propath($udom,$uname);
1275: my $now=time;
1.48 www 1276: unless ($namespace=~/^nohist\_/) {
1.1 albertel 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);
1.134 albertel 1283: my %hash;
1284: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1285: foreach my $key (@keys) {
1.1 albertel 1286: delete($hash{$key});
1287: }
1.4 www 1288: if (untie(%hash)) {
1.1 albertel 1289: print $client "ok\n";
1290: } else {
1.109 foxr 1291: print $client "error: ".($!+0)
1.111 matthew 1292: ." untie(GDBM) Failed ".
1293: "while attempting del\n";
1.1 albertel 1294: }
1295: } else {
1.109 foxr 1296: print $client "error: ".($!+0)
1.111 matthew 1297: ." tie(GDBM) Failed ".
1298: "while attempting del\n";
1.1 albertel 1299: }
1300: # ------------------------------------------------------------------------ keys
1301: } elsif ($userinput =~ /^keys/) {
1302: my ($cmd,$udom,$uname,$namespace)
1303: =split(/:/,$userinput);
1.8 www 1304: $namespace=~s/\//\_/g;
1.1 albertel 1305: $namespace=~s/\W//g;
1306: my $proname=propath($udom,$uname);
1307: my $qresult='';
1.134 albertel 1308: my %hash;
1309: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1310: foreach my $key (keys %hash) {
1.1 albertel 1311: $qresult.="$key&";
1312: }
1.4 www 1313: if (untie(%hash)) {
1.1 albertel 1314: $qresult=~s/\&$//;
1315: print $client "$qresult\n";
1316: } else {
1.109 foxr 1317: print $client "error: ".($!+0)
1.111 matthew 1318: ." untie(GDBM) Failed ".
1319: "while attempting keys\n";
1.105 matthew 1320: }
1321: } else {
1.109 foxr 1322: print $client "error: ".($!+0)
1.111 matthew 1323: ." tie(GDBM) Failed ".
1324: "while attempting keys\n";
1.105 matthew 1325: }
1326: # ----------------------------------------------------------------- dumpcurrent
1.107 matthew 1327: } elsif ($userinput =~ /^currentdump/) {
1.105 matthew 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);
1.134 albertel 1334: my %hash;
1.105 matthew 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;
1.107 matthew 1351: $data{$symb}->{'v.'.$param}=$v;
1.105 matthew 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 {
1.109 foxr 1363: print $client "error: ".($!+0)
1.111 matthew 1364: ." untie(GDBM) Failed ".
1365: "while attempting currentdump\n";
1.1 albertel 1366: }
1367: } else {
1.109 foxr 1368: print $client "error: ".($!+0)
1.111 matthew 1369: ." tie(GDBM) Failed ".
1370: "while attempting currentdump\n";
1.1 albertel 1371: }
1372: # ------------------------------------------------------------------------ dump
1373: } elsif ($userinput =~ /^dump/) {
1.62 www 1374: my ($cmd,$udom,$uname,$namespace,$regexp)
1.1 albertel 1375: =split(/:/,$userinput);
1.8 www 1376: $namespace=~s/\//\_/g;
1.1 albertel 1377: $namespace=~s/\W//g;
1.62 www 1378: if (defined($regexp)) {
1379: $regexp=&unescape($regexp);
1380: } else {
1381: $regexp='.';
1382: }
1.100 matthew 1383: my $qresult='';
1.1 albertel 1384: my $proname=propath($udom,$uname);
1.134 albertel 1385: my %hash;
1386: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1.90 stredwic 1387: study($regexp);
1.134 albertel 1388: while (my ($key,$value) = each(%hash)) {
1.100 matthew 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: }
1.7 www 1397: }
1.100 matthew 1398: if (untie(%hash)) {
1399: chop($qresult);
1400: print $client "$qresult\n";
1.7 www 1401: } else {
1.109 foxr 1402: print $client "error: ".($!+0)
1.111 matthew 1403: ." untie(GDBM) Failed ".
1404: "while attempting dump\n";
1.7 www 1405: }
1406: } else {
1.109 foxr 1407: print $client "error: ".($!+0)
1.111 matthew 1408: ." tie(GDBM) Failed ".
1409: "while attempting dump\n";
1.7 www 1410: }
1411: # ----------------------------------------------------------------------- store
1412: } elsif ($userinput =~ /^store/) {
1413: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1414: =split(/:/,$userinput);
1.8 www 1415: $namespace=~s/\//\_/g;
1.7 www 1416: $namespace=~s/\W//g;
1417: if ($namespace ne 'roles') {
1418: chomp($what);
1419: my $proname=propath($udom,$uname);
1420: my $now=time;
1.48 www 1421: unless ($namespace=~/^nohist\_/) {
1.7 www 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);
1.134 albertel 1428: my %hash;
1429: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1.7 www 1430: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1431: my $key;
1432: $hash{"version:$rid"}++;
1433: my $version=$hash{"version:$rid"};
1434: my $allkeys='';
1.134 albertel 1435: foreach my $pair (@pairs) {
1436: my ($key,$value)=split(/=/,$pair);
1.7 www 1437: $allkeys.=$key.':';
1438: $hash{"$version:$rid:$key"}=$value;
1439: }
1.36 www 1440: $hash{"$version:$rid:timestamp"}=$now;
1441: $allkeys.='timestamp';
1.7 www 1442: $hash{"$version:keys:$rid"}=$allkeys;
1443: if (untie(%hash)) {
1444: print $client "ok\n";
1445: } else {
1.109 foxr 1446: print $client "error: ".($!+0)
1.111 matthew 1447: ." untie(GDBM) Failed ".
1448: "while attempting store\n";
1.7 www 1449: }
1450: } else {
1.109 foxr 1451: print $client "error: ".($!+0)
1.111 matthew 1452: ." tie(GDBM) Failed ".
1453: "while attempting store\n";
1.7 www 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);
1.8 www 1462: $namespace=~s/\//\_/g;
1.7 www 1463: $namespace=~s/\W//g;
1464: chomp($rid);
1465: my $proname=propath($udom,$uname);
1466: my $qresult='';
1.134 albertel 1467: my %hash;
1468: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1.7 www 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) {
1.21 www 1478: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1.7 www 1479: }
1.1 albertel 1480: }
1.4 www 1481: if (untie(%hash)) {
1.1 albertel 1482: $qresult=~s/\&$//;
1483: print $client "$qresult\n";
1484: } else {
1.109 foxr 1485: print $client "error: ".($!+0)
1.111 matthew 1486: ." untie(GDBM) Failed ".
1487: "while attempting restore\n";
1.1 albertel 1488: }
1489: } else {
1.109 foxr 1490: print $client "error: ".($!+0)
1.111 matthew 1491: ." tie(GDBM) Failed ".
1492: "while attempting restore\n";
1.1 albertel 1493: }
1.86 www 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/) {
1.122 www 1501: my
1502: ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
1.86 www 1503: my $reply='';
1.122 www 1504: foreach (&getchat($cdom,$cnum,$udom,$uname)) {
1.86 www 1505: $reply.=&escape($_).':';
1506: }
1507: $reply=~s/\:$//;
1508: print $client $reply."\n";
1.12 harris41 1509: # ------------------------------------------------------------------- querysend
1510: } elsif ($userinput =~ /^querysend/) {
1.44 harris41 1511: my ($cmd,$query,
1.82 www 1512: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
1.12 harris41 1513: $query=~s/\n*$//g;
1.82 www 1514: print $client "".
1.40 harris41 1515: sqlreply("$hostid{$clientip}\&$query".
1.82 www 1516: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
1.12 harris41 1517: # ------------------------------------------------------------------ queryreply
1518: } elsif ($userinput =~ /^queryreply/) {
1519: my ($cmd,$id,$reply)=split(/:/,$userinput);
1520: my $store;
1.13 www 1521: my $execdir=$perlvar{'lonDaemons'};
1522: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1.43 harris41 1523: $reply=~s/\&/\n/g;
1.12 harris41 1524: print $store $reply;
1525: close $store;
1.46 harris41 1526: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1527: print $store2 "done\n";
1528: close $store2;
1.12 harris41 1529: print $client "ok\n";
1530: }
1531: else {
1.109 foxr 1532: print $client "error: ".($!+0)
1.111 matthew 1533: ." IO::File->new Failed ".
1534: "while attempting queryreply\n";
1.12 harris41 1535: }
1.118 www 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);
1.134 albertel 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);
1.118 www 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";
1.134 albertel 1576: my %hash;
1577: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1578: while (my ($key,$value) = each(%hash)) {
1.118 www 1579: my ($descr,$lasttime)=split(/\:/,$value);
1580: if ($lasttime<$since) { next; }
1.133 www 1581: if ($description eq '.') {
1.118 www 1582: $qresult.=$key.'='.$descr.'&';
1583: } else {
1584: my $unescapeVal = &unescape($descr);
1.120 www 1585: if (eval('$unescapeVal=~/$description/i')) {
1.118 www 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: }
1.1 albertel 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);
1.134 albertel 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);
1.1 albertel 1621: $hash{$key}=$value;
1622: }
1.4 www 1623: if (untie(%hash)) {
1.1 albertel 1624: print $client "ok\n";
1625: } else {
1.109 foxr 1626: print $client "error: ".($!+0)
1.111 matthew 1627: ." untie(GDBM) Failed ".
1628: "while attempting idput\n";
1.1 albertel 1629: }
1630: } else {
1.109 foxr 1631: print $client "error: ".($!+0)
1.111 matthew 1632: ." tie(GDBM) Failed ".
1633: "while attempting idput\n";
1.1 albertel 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='';
1.134 albertel 1643: my %hash;
1644: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1645: for (my $i=0;$i<=$#queries;$i++) {
1.1 albertel 1646: $qresult.="$hash{$queries[$i]}&";
1647: }
1.4 www 1648: if (untie(%hash)) {
1.134 albertel 1649: $qresult=~s/\&$//;
1650: print $client "$qresult\n";
1.1 albertel 1651: } else {
1.134 albertel 1652: print $client "error: ".($!+0)
1653: ." untie(GDBM) Failed ".
1654: "while attempting idget\n";
1.1 albertel 1655: }
1656: } else {
1.109 foxr 1657: print $client "error: ".($!+0)
1.111 matthew 1658: ." tie(GDBM) Failed ".
1659: "while attempting idget\n";
1.1 albertel 1660: }
1.13 www 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 {
1.109 foxr 1676: print $client "error: ".($!+0)
1.111 matthew 1677: ."IO::File->new Failed ".
1678: "while attempting tmpput\n";
1.13 www 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 {
1.109 foxr 1694: print $client "error: ".($!+0)
1.111 matthew 1695: ."IO::File->new Failed ".
1696: "while attempting tmpget\n";
1.13 www 1697: }
1698:
1.110 www 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)
1.111 matthew 1709: ."Unlink tmp Failed ".
1710: "while attempting tmpdel\n";
1.110 www 1711: }
1.5 www 1712: # -------------------------------------------------------------------------- ls
1713: } elsif ($userinput =~ /^ls/) {
1714: my ($cmd,$ulsdir)=split(/:/,$userinput);
1715: my $ulsout='';
1716: my $ulsfn;
1717: if (-e $ulsdir) {
1.83 stredwic 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 {
1.5 www 1732: $ulsout='no_such_dir';
1733: }
1.17 www 1734: if ($ulsout eq '') { $ulsout='empty'; }
1.5 www 1735: print $client "$ulsout\n";
1.136 ! www 1736: # ----------------------------------------------------------------- setannounce
! 1737: } elsif ($userinput =~ /^setannounce/) {
! 1738: my ($cmd,$announcement)=split(/:/,$userinput);
! 1739: chomp($announcement);
! 1740: $announcement=&unescape($announcement);
! 1741: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
! 1742: '/announcement.txt')) {
! 1743: print $store $announcement;
! 1744: close $store;
! 1745: print $client "ok\n";
! 1746: } else {
! 1747: print $client "error: ".($!+0)."\n";
! 1748: }
1.51 www 1749: # ------------------------------------------------------------------ Hanging up
1750: } elsif (($userinput =~ /^exit/) ||
1751: ($userinput =~ /^init/)) {
1752: &logthis(
1753: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1754: print $client "bye\n";
1.59 www 1755: $client->close();
1.51 www 1756: last;
1.1 albertel 1757: # ------------------------------------------------------------- unknown command
1.121 albertel 1758: } elsif ($userinput =~ /^sethost:/) {
1759: print $client &sethost($userinput)."\n";
1760: } elsif ($userinput =~/^version:/) {
1761: print $client &version($userinput)."\n";
1.1 albertel 1762: } else {
1763: # unknown command
1764: print $client "unknown_cmd\n";
1765: }
1.58 www 1766: # -------------------------------------------------------------------- complete
1.63 www 1767: alarm(0);
1.58 www 1768: &status('Listening to '.$hostid{$clientip});
1769: }
1.59 www 1770: # --------------------------------------------- client unknown or fishy, refuse
1.1 albertel 1771: } else {
1772: print $client "refused\n";
1.59 www 1773: $client->close();
1.9 www 1774: &logthis("<font color=blue>WARNING: "
1775: ."Rejected client $clientip, closing connection</font>");
1.75 foxr 1776: }
1.106 foxr 1777: }
1.75 foxr 1778:
1.1 albertel 1779: # =============================================================================
1.75 foxr 1780:
1781: &logthis("<font color=red>CRITICAL: "
1782: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1.106 foxr 1783:
1.59 www 1784:
1.1 albertel 1785: # this exit is VERY important, otherwise the child will become
1786: # a producer of more and more children, forking yourself into
1787: # process death.
1788: exit;
1.106 foxr 1789:
1.78 foxr 1790: }
1791:
1792:
1793: #
1794: # Checks to see if the input roleput request was to set
1795: # an author role. If so, invokes the lchtmldir script to set
1796: # up a correct public_html
1797: # Parameters:
1798: # request - The request sent to the rolesput subchunk.
1799: # We're looking for /domain/_au
1800: # domain - The domain in which the user is having roles doctored.
1801: # user - Name of the user for which the role is being put.
1802: # authtype - The authentication type associated with the user.
1803: #
1804: sub ManagePermissions
1805: {
1806: my $request = shift;
1807: my $domain = shift;
1808: my $user = shift;
1809: my $authtype= shift;
1810:
1811: # See if the request is of the form /$domain/_au
1.134 albertel 1812: &logthis("ruequest is $request");
1.78 foxr 1813: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
1814: my $execdir = $perlvar{'lonDaemons'};
1815: my $userhome= "/home/$user" ;
1.134 albertel 1816: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1.78 foxr 1817: system("$execdir/lchtmldir $userhome $user $authtype");
1818: }
1819: }
1820: #
1821: # GetAuthType - Determines the authorization type of a user in a domain.
1822:
1823: # Returns the authorization type or nouser if there is no such user.
1824: #
1825: sub GetAuthType
1826: {
1827: my $domain = shift;
1828: my $user = shift;
1829:
1.79 foxr 1830: Debug("GetAuthType( $domain, $user ) \n");
1.78 foxr 1831: my $proname = &propath($domain, $user);
1832: my $passwdfile = "$proname/passwd";
1833: if( -e $passwdfile ) {
1834: my $pf = IO::File->new($passwdfile);
1835: my $realpassword = <$pf>;
1836: chomp($realpassword);
1.79 foxr 1837: Debug("Password info = $realpassword\n");
1.78 foxr 1838: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1.79 foxr 1839: Debug("Authtype = $authtype, content = $contentpwd\n");
1.78 foxr 1840: my $availinfo = '';
1.91 albertel 1841: if($authtype eq 'krb4' or $authtype eq 'krb5') {
1.78 foxr 1842: $availinfo = $contentpwd;
1843: }
1.79 foxr 1844:
1.78 foxr 1845: return "$authtype:$availinfo";
1846: }
1847: else {
1.79 foxr 1848: Debug("Returning nouser");
1.78 foxr 1849: return "nouser";
1850: }
1.1 albertel 1851: }
1852:
1.84 albertel 1853: sub addline {
1854: my ($fname,$hostid,$ip,$newline)=@_;
1855: my $contents;
1856: my $found=0;
1857: my $expr='^'.$hostid.':'.$ip.':';
1858: $expr =~ s/\./\\\./g;
1.134 albertel 1859: my $sh;
1.84 albertel 1860: if ($sh=IO::File->new("$fname.subscription")) {
1861: while (my $subline=<$sh>) {
1862: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
1863: }
1864: $sh->close();
1865: }
1866: $sh=IO::File->new(">$fname.subscription");
1867: if ($contents) { print $sh $contents; }
1868: if ($newline) { print $sh $newline; }
1869: $sh->close();
1870: return $found;
1.86 www 1871: }
1872:
1873: sub getchat {
1.122 www 1874: my ($cdom,$cname,$udom,$uname)=@_;
1.87 www 1875: my %hash;
1876: my $proname=&propath($cdom,$cname);
1877: my @entries=();
1.88 albertel 1878: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1879: &GDBM_READER(),0640)) {
1880: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1881: untie %hash;
1.123 www 1882: }
1.124 www 1883: my @participants=();
1.134 albertel 1884: my $cutoff=time-60;
1.123 www 1885: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1.124 www 1886: &GDBM_WRCREAT(),0640)) {
1887: $hash{$uname.':'.$udom}=time;
1.123 www 1888: foreach (sort keys %hash) {
1889: if ($hash{$_}>$cutoff) {
1.124 www 1890: $participants[$#participants+1]='active_participant:'.$_;
1.123 www 1891: }
1892: }
1893: untie %hash;
1.86 www 1894: }
1.124 www 1895: return (@participants,@entries);
1.86 www 1896: }
1897:
1898: sub chatadd {
1.88 albertel 1899: my ($cdom,$cname,$newchat)=@_;
1900: my %hash;
1901: my $proname=&propath($cdom,$cname);
1902: my @entries=();
1903: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
1904: &GDBM_WRCREAT(),0640)) {
1905: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
1906: my $time=time;
1907: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
1908: my ($thentime,$idnum)=split(/\_/,$lastid);
1909: my $newid=$time.'_000000';
1910: if ($thentime==$time) {
1911: $idnum=~s/^0+//;
1912: $idnum++;
1913: $idnum=substr('000000'.$idnum,-6,6);
1914: $newid=$time.'_'.$idnum;
1915: }
1916: $hash{$newid}=$newchat;
1917: my $expired=$time-3600;
1918: foreach (keys %hash) {
1919: my ($thistime)=($_=~/(\d+)\_/);
1920: if ($thistime<$expired) {
1.89 www 1921: delete $hash{$_};
1.88 albertel 1922: }
1923: }
1924: untie %hash;
1.86 www 1925: }
1.84 albertel 1926: }
1927:
1928: sub unsub {
1929: my ($fname,$clientip)=@_;
1930: my $result;
1931: if (unlink("$fname.$hostid{$clientip}")) {
1932: $result="ok\n";
1933: } else {
1934: $result="not_subscribed\n";
1935: }
1936: if (-e "$fname.subscription") {
1937: my $found=&addline($fname,$hostid{$clientip},$clientip,'');
1938: if ($found) { $result="ok\n"; }
1939: } else {
1940: if ($result != "ok\n") { $result="not_subscribed\n"; }
1941: }
1942: return $result;
1943: }
1944:
1.101 www 1945: sub currentversion {
1946: my $fname=shift;
1947: my $version=-1;
1948: my $ulsdir='';
1949: if ($fname=~/^(.+)\/[^\/]+$/) {
1950: $ulsdir=$1;
1951: }
1.114 albertel 1952: my ($fnamere1,$fnamere2);
1953: # remove version if already specified
1.101 www 1954: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114 albertel 1955: # get the bits that go before and after the version number
1956: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
1957: $fnamere1=$1;
1958: $fnamere2='.'.$2;
1959: }
1.101 www 1960: if (-e $fname) { $version=1; }
1961: if (-e $ulsdir) {
1.134 albertel 1962: if(-d $ulsdir) {
1963: if (opendir(LSDIR,$ulsdir)) {
1964: my $ulsfn;
1965: while ($ulsfn=readdir(LSDIR)) {
1.101 www 1966: # see if this is a regular file (ignore links produced earlier)
1.134 albertel 1967: my $thisfile=$ulsdir.'/'.$ulsfn;
1968: unless (-l $thisfile) {
1969: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
1970: if ($1>$version) { $version=$1; }
1971: }
1972: }
1973: }
1974: closedir(LSDIR);
1975: $version++;
1976: }
1977: }
1978: }
1979: return $version;
1.101 www 1980: }
1981:
1982: sub thisversion {
1983: my $fname=shift;
1984: my $version=-1;
1985: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
1986: $version=$1;
1987: }
1988: return $version;
1989: }
1990:
1.84 albertel 1991: sub subscribe {
1992: my ($userinput,$clientip)=@_;
1993: my $result;
1994: my ($cmd,$fname)=split(/:/,$userinput);
1995: my $ownership=&ishome($fname);
1996: if ($ownership eq 'owner') {
1.101 www 1997: # explitly asking for the current version?
1998: unless (-e $fname) {
1999: my $currentversion=¤tversion($fname);
2000: if (&thisversion($fname)==$currentversion) {
2001: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
2002: my $root=$1;
2003: my $extension=$2;
2004: symlink($root.'.'.$extension,
2005: $root.'.'.$currentversion.'.'.$extension);
1.102 www 2006: unless ($extension=~/\.meta$/) {
2007: symlink($root.'.'.$extension.'.meta',
2008: $root.'.'.$currentversion.'.'.$extension.'.meta');
2009: }
1.101 www 2010: }
2011: }
2012: }
1.84 albertel 2013: if (-e $fname) {
2014: if (-d $fname) {
2015: $result="directory\n";
2016: } else {
2017: if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
1.134 albertel 2018: my $now=time;
1.84 albertel 2019: my $found=&addline($fname,$hostid{$clientip},$clientip,
2020: "$hostid{$clientip}:$clientip:$now\n");
2021: if ($found) { $result="$fname\n"; }
2022: # if they were subscribed to only meta data, delete that
2023: # subscription, when you subscribe to a file you also get
2024: # the metadata
2025: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
2026: $fname=~s/\/home\/httpd\/html\/res/raw/;
2027: $fname="http://$thisserver/".$fname;
2028: $result="$fname\n";
2029: }
2030: } else {
2031: $result="not_found\n";
2032: }
2033: } else {
2034: $result="rejected\n";
2035: }
2036: return $result;
2037: }
1.91 albertel 2038:
2039: sub make_passwd_file {
1.98 foxr 2040: my ($uname, $umode,$npass,$passfilename)=@_;
1.91 albertel 2041: my $result="ok\n";
2042: if ($umode eq 'krb4' or $umode eq 'krb5') {
2043: {
2044: my $pf = IO::File->new(">$passfilename");
2045: print $pf "$umode:$npass\n";
2046: }
2047: } elsif ($umode eq 'internal') {
2048: my $salt=time;
2049: $salt=substr($salt,6,2);
2050: my $ncpass=crypt($npass,$salt);
2051: {
2052: &Debug("Creating internal auth");
2053: my $pf = IO::File->new(">$passfilename");
2054: print $pf "internal:$ncpass\n";
2055: }
2056: } elsif ($umode eq 'localauth') {
2057: {
2058: my $pf = IO::File->new(">$passfilename");
2059: print $pf "localauth:$npass\n";
2060: }
2061: } elsif ($umode eq 'unix') {
2062: {
2063: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
2064: {
2065: &Debug("Executing external: ".$execpath);
1.98 foxr 2066: &Debug("user = ".$uname.", Password =". $npass);
1.132 matthew 2067: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
1.91 albertel 2068: print $se "$uname\n";
2069: print $se "$npass\n";
2070: print $se "$npass\n";
1.97 foxr 2071: }
2072: my $useraddok = $?;
2073: if($useraddok > 0) {
2074: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
1.91 albertel 2075: }
2076: my $pf = IO::File->new(">$passfilename");
2077: print $pf "unix:\n";
2078: }
2079: } elsif ($umode eq 'none') {
2080: {
2081: my $pf = IO::File->new(">$passfilename");
2082: print $pf "none:\n";
2083: }
2084: } else {
2085: $result="auth_mode_error\n";
2086: }
2087: return $result;
1.121 albertel 2088: }
2089:
2090: sub sethost {
2091: my ($remotereq) = @_;
2092: my (undef,$hostid)=split(/:/,$remotereq);
2093: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
2094: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
2095: $currenthostid=$hostid;
2096: $currentdomainid=$hostdom{$hostid};
2097: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
2098: } else {
2099: &logthis("Requested host id $hostid not an alias of ".
2100: $perlvar{'lonHostID'}." refusing connection");
2101: return 'unable_to_set';
2102: }
2103: return 'ok';
2104: }
2105:
2106: sub version {
2107: my ($userinput)=@_;
2108: $remoteVERSION=(split(/:/,$userinput))[1];
2109: return "version:$VERSION";
1.127 albertel 2110: }
2111:
1.128 albertel 2112: #There is a copy of this in lonnet.pm
1.127 albertel 2113: sub userload {
2114: my $numusers=0;
2115: {
2116: opendir(LONIDS,$perlvar{'lonIDsDir'});
2117: my $filename;
2118: my $curtime=time;
2119: while ($filename=readdir(LONIDS)) {
2120: if ($filename eq '.' || $filename eq '..') {next;}
2121: my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
1.129 albertel 2122: if ($curtime-$atime < 3600) { $numusers++; }
1.127 albertel 2123: }
2124: closedir(LONIDS);
2125: }
2126: my $userloadpercent=0;
2127: my $maxuserload=$perlvar{'lonUserLoadLim'};
2128: if ($maxuserload) {
1.129 albertel 2129: $userloadpercent=100*$numusers/$maxuserload;
1.127 albertel 2130: }
1.130 albertel 2131: $userloadpercent=sprintf("%.2f",$userloadpercent);
1.127 albertel 2132: return $userloadpercent;
1.91 albertel 2133: }
2134:
1.61 harris41 2135: # ----------------------------------- POD (plain old documentation, CPAN style)
2136:
2137: =head1 NAME
2138:
2139: lond - "LON Daemon" Server (port "LOND" 5663)
2140:
2141: =head1 SYNOPSIS
2142:
1.74 harris41 2143: Usage: B<lond>
2144:
2145: Should only be run as user=www. This is a command-line script which
2146: is invoked by B<loncron>. There is no expectation that a typical user
2147: will manually start B<lond> from the command-line. (In other words,
2148: DO NOT START B<lond> YOURSELF.)
1.61 harris41 2149:
2150: =head1 DESCRIPTION
2151:
1.74 harris41 2152: There are two characteristics associated with the running of B<lond>,
2153: PROCESS MANAGEMENT (starting, stopping, handling child processes)
2154: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
2155: subscriptions, etc). These are described in two large
2156: sections below.
2157:
2158: B<PROCESS MANAGEMENT>
2159:
1.61 harris41 2160: Preforker - server who forks first. Runs as a daemon. HUPs.
2161: Uses IDEA encryption
2162:
1.74 harris41 2163: B<lond> forks off children processes that correspond to the other servers
2164: in the network. Management of these processes can be done at the
2165: parent process level or the child process level.
2166:
2167: B<logs/lond.log> is the location of log messages.
2168:
2169: The process management is now explained in terms of linux shell commands,
2170: subroutines internal to this code, and signal assignments:
2171:
2172: =over 4
2173:
2174: =item *
2175:
2176: PID is stored in B<logs/lond.pid>
2177:
2178: This is the process id number of the parent B<lond> process.
2179:
2180: =item *
2181:
2182: SIGTERM and SIGINT
2183:
2184: Parent signal assignment:
2185: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
2186:
2187: Child signal assignment:
2188: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
2189: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
2190: to restart a new child.)
2191:
2192: Command-line invocations:
2193: B<kill> B<-s> SIGTERM I<PID>
2194: B<kill> B<-s> SIGINT I<PID>
2195:
2196: Subroutine B<HUNTSMAN>:
2197: This is only invoked for the B<lond> parent I<PID>.
2198: This kills all the children, and then the parent.
2199: The B<lonc.pid> file is cleared.
2200:
2201: =item *
2202:
2203: SIGHUP
2204:
2205: Current bug:
2206: This signal can only be processed the first time
2207: on the parent process. Subsequent SIGHUP signals
2208: have no effect.
2209:
2210: Parent signal assignment:
2211: $SIG{HUP} = \&HUPSMAN;
2212:
2213: Child signal assignment:
2214: none (nothing happens)
2215:
2216: Command-line invocations:
2217: B<kill> B<-s> SIGHUP I<PID>
2218:
2219: Subroutine B<HUPSMAN>:
2220: This is only invoked for the B<lond> parent I<PID>,
2221: This kills all the children, and then the parent.
2222: The B<lond.pid> file is cleared.
2223:
2224: =item *
2225:
2226: SIGUSR1
2227:
2228: Parent signal assignment:
2229: $SIG{USR1} = \&USRMAN;
2230:
2231: Child signal assignment:
2232: $SIG{USR1}= \&logstatus;
2233:
2234: Command-line invocations:
2235: B<kill> B<-s> SIGUSR1 I<PID>
2236:
2237: Subroutine B<USRMAN>:
2238: When invoked for the B<lond> parent I<PID>,
2239: SIGUSR1 is sent to all the children, and the status of
2240: each connection is logged.
2241:
2242: =item *
2243:
2244: SIGCHLD
2245:
2246: Parent signal assignment:
2247: $SIG{CHLD} = \&REAPER;
2248:
2249: Child signal assignment:
2250: none
2251:
2252: Command-line invocations:
2253: B<kill> B<-s> SIGCHLD I<PID>
2254:
2255: Subroutine B<REAPER>:
2256: This is only invoked for the B<lond> parent I<PID>.
2257: Information pertaining to the child is removed.
2258: The socket port is cleaned up.
2259:
2260: =back
2261:
2262: B<SERVER-SIDE ACTIVITIES>
2263:
2264: Server-side information can be accepted in an encrypted or non-encrypted
2265: method.
2266:
2267: =over 4
2268:
2269: =item ping
2270:
2271: Query a client in the hosts.tab table; "Are you there?"
2272:
2273: =item pong
2274:
2275: Respond to a ping query.
2276:
2277: =item ekey
2278:
2279: Read in encrypted key, make cipher. Respond with a buildkey.
2280:
2281: =item load
2282:
2283: Respond with CPU load based on a computation upon /proc/loadavg.
2284:
2285: =item currentauth
2286:
2287: Reply with current authentication information (only over an
2288: encrypted channel).
2289:
2290: =item auth
2291:
2292: Only over an encrypted channel, reply as to whether a user's
2293: authentication information can be validated.
2294:
2295: =item passwd
2296:
2297: Allow for a password to be set.
2298:
2299: =item makeuser
2300:
2301: Make a user.
2302:
2303: =item passwd
2304:
2305: Allow for authentication mechanism and password to be changed.
2306:
2307: =item home
1.61 harris41 2308:
1.74 harris41 2309: Respond to a question "are you the home for a given user?"
2310:
2311: =item update
2312:
2313: Update contents of a subscribed resource.
2314:
2315: =item unsubscribe
2316:
2317: The server is unsubscribing from a resource.
2318:
2319: =item subscribe
2320:
2321: The server is subscribing to a resource.
2322:
2323: =item log
2324:
2325: Place in B<logs/lond.log>
2326:
2327: =item put
2328:
2329: stores hash in namespace
2330:
2331: =item rolesput
2332:
2333: put a role into a user's environment
2334:
2335: =item get
2336:
2337: returns hash with keys from array
2338: reference filled in from namespace
2339:
2340: =item eget
2341:
2342: returns hash with keys from array
2343: reference filled in from namesp (encrypts the return communication)
2344:
2345: =item rolesget
2346:
2347: get a role from a user's environment
2348:
2349: =item del
2350:
2351: deletes keys out of array from namespace
2352:
2353: =item keys
2354:
2355: returns namespace keys
2356:
2357: =item dump
2358:
2359: dumps the complete (or key matching regexp) namespace into a hash
2360:
2361: =item store
2362:
2363: stores hash permanently
2364: for this url; hashref needs to be given and should be a \%hashname; the
2365: remaining args aren't required and if they aren't passed or are '' they will
2366: be derived from the ENV
2367:
2368: =item restore
2369:
2370: returns a hash for a given url
2371:
2372: =item querysend
2373:
2374: Tells client about the lonsql process that has been launched in response
2375: to a sent query.
2376:
2377: =item queryreply
2378:
2379: Accept information from lonsql and make appropriate storage in temporary
2380: file space.
2381:
2382: =item idput
2383:
2384: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
2385: for each student, defined perhaps by the institutional Registrar.)
2386:
2387: =item idget
2388:
2389: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
2390: for each student, defined perhaps by the institutional Registrar.)
2391:
2392: =item tmpput
2393:
2394: Accept and store information in temporary space.
2395:
2396: =item tmpget
2397:
2398: Send along temporarily stored information.
2399:
2400: =item ls
2401:
2402: List part of a user's directory.
2403:
1.135 foxr 2404: =item pushtable
2405:
2406: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
2407: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
2408: must be restored manually in case of a problem with the new table file.
2409: pushtable requires that the request be encrypted and validated via
2410: ValidateManager. The form of the command is:
2411: enc:pushtable tablename <tablecontents> \n
2412: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
2413: cleartext newline.
2414:
1.74 harris41 2415: =item Hanging up (exit or init)
2416:
2417: What to do when a client tells the server that they (the client)
2418: are leaving the network.
2419:
2420: =item unknown command
2421:
2422: If B<lond> is sent an unknown command (not in the list above),
2423: it replys to the client "unknown_cmd".
1.135 foxr 2424:
1.74 harris41 2425:
2426: =item UNKNOWN CLIENT
2427:
2428: If the anti-spoofing algorithm cannot verify the client,
2429: the client is rejected (with a "refused" message sent
2430: to the client, and the connection is closed.
2431:
2432: =back
1.61 harris41 2433:
2434: =head1 PREREQUISITES
2435:
2436: IO::Socket
2437: IO::File
2438: Apache::File
2439: Symbol
2440: POSIX
2441: Crypt::IDEA
2442: LWP::UserAgent()
2443: GDBM_File
2444: Authen::Krb4
1.91 albertel 2445: Authen::Krb5
1.61 harris41 2446:
2447: =head1 COREQUISITES
2448:
2449: =head1 OSNAMES
2450:
2451: linux
2452:
2453: =head1 SCRIPT CATEGORIES
2454:
2455: Server/Process
2456:
2457: =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