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