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