Annotation of loncom/lond, revision 1.24
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
4: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
1.2 www 5: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
1.6 www 6: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
1.11 www 7: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
1.12 harris41 8: # 03/07,05/31 Gerd Kortemeyer
1.13 www 9: # 06/26 Scott Harrison
1.20 www 10: # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
1.13 www 11: #
1.1 albertel 12: # based on "Perl Cookbook" ISBN 1-56592-243-3
13: # preforker - server who forks first
14: # runs as a daemon
15: # HUPs
16: # uses IDEA encryption
17:
18: use IO::Socket;
19: use IO::File;
20: use Apache::File;
21: use Symbol;
22: use POSIX;
23: use Crypt::IDEA;
24: use LWP::UserAgent();
1.3 www 25: use GDBM_File;
26: use Authen::Krb4;
1.1 albertel 27:
1.23 harris41 28: # grabs exception and records it to log before exiting
29: sub catchexception {
30: my ($signal)=@_;
31: &logthis("<font color=red>CRITICAL: "
32: ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
33: ."$signal with this parameter->[$@]</font>");
34: die($@);
35: }
36:
37: # grabs exception and records it to log before exiting
38: # NOTE: we must NOT use the regular (non-overrided) die function in
39: # the code because a handler CANNOT be attached to it
40: # (despite what some of the documentation says about SIG{__DIE__}.
41: sub catchdie {
42: my ($message)=@_;
43: &logthis("<font color=red>CRITICAL: "
44: ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
45: ."\_\_DIE\_\_ with this parameter->[$message]</font>");
46: die($message);
47: }
48:
1.22 harris41 49: # -------------------------------- Set signal handlers to record abnormal exits
50:
51: $SIG{'QUIT'}=\&catchexception;
52: $SIG{__DIE__}=\&catchexception;
53:
1.1 albertel 54: # ------------------------------------ Read httpd access.conf and get variables
55:
1.22 harris41 56: open (CONFIG,"/etc/httpd/conf/access.conf")
57: || catchdie "Can't read access.conf";
1.1 albertel 58:
59: while ($configline=<CONFIG>) {
60: if ($configline =~ /PerlSetVar/) {
61: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.7 www 62: chomp($varvalue);
1.1 albertel 63: $perlvar{$varname}=$varvalue;
64: }
65: }
66: close(CONFIG);
1.19 www 67:
68: # --------------------------------------------- Check if other instance running
69:
70: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
71:
72: if (-e $pidfile) {
73: my $lfh=IO::File->new("$pidfile");
74: my $pide=<$lfh>;
75: chomp($pide);
1.22 harris41 76: if (kill 0 => $pide) { catchdie "already running"; }
1.19 www 77: }
1.1 albertel 78:
79: $PREFORK=4; # number of children to maintain, at least four spare
80:
81: # ------------------------------------------------------------- Read hosts file
82:
1.22 harris41 83: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab")
84: || catchdie "Can't read host file";
1.1 albertel 85:
86: while ($configline=<CONFIG>) {
87: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
88: chomp($ip);
89: $hostid{$ip}=$id;
90: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
91: $PREFORK++;
92: }
93: close(CONFIG);
94:
95: # establish SERVER socket, bind and listen.
96: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
97: Type => SOCK_STREAM,
98: Proto => 'tcp',
99: Reuse => 1,
100: Listen => 10 )
1.22 harris41 101: or catchdie "making socket: $@\n";
1.1 albertel 102:
103: # --------------------------------------------------------- Do global variables
104:
105: # global variables
106:
107: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should
108: # process
109: %children = (); # keys are current child process IDs
110: $children = 0; # current number of children
111:
112: sub REAPER { # takes care of dead children
113: $SIG{CHLD} = \&REAPER;
114: my $pid = wait;
115: $children --;
116: &logthis("Child $pid died");
117: delete $children{$pid};
118: }
119:
120: sub HUNTSMAN { # signal handler for SIGINT
121: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
122: kill 'INT' => keys %children;
123: my $execdir=$perlvar{'lonDaemons'};
124: unlink("$execdir/logs/lond.pid");
1.9 www 125: &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.1 albertel 126: exit; # clean up with dignity
127: }
128:
129: sub HUPSMAN { # signal handler for SIGHUP
130: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
131: kill 'INT' => keys %children;
132: close($server); # free up socket
1.9 www 133: &logthis("<font color=red>CRITICAL: Restarting</font>");
1.1 albertel 134: my $execdir=$perlvar{'lonDaemons'};
135: exec("$execdir/lond"); # here we go again
136: }
137:
138: # --------------------------------------------------------------------- Logging
139:
140: sub logthis {
141: my $message=shift;
142: my $execdir=$perlvar{'lonDaemons'};
143: my $fh=IO::File->new(">>$execdir/logs/lond.log");
144: my $now=time;
145: my $local=localtime($now);
146: print $fh "$local ($$): $message\n";
147: }
148:
1.11 www 149:
150: # -------------------------------------------------------- Escape Special Chars
151:
152: sub escape {
153: my $str=shift;
154: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
155: return $str;
156: }
157:
158: # ----------------------------------------------------- Un-Escape Special Chars
159:
160: sub unescape {
161: my $str=shift;
162: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
163: return $str;
164: }
165:
1.1 albertel 166: # ----------------------------------------------------------- Send USR1 to lonc
167:
168: sub reconlonc {
169: my $peerfile=shift;
170: &logthis("Trying to reconnect for $peerfile");
171: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
172: if (my $fh=IO::File->new("$loncfile")) {
173: my $loncpid=<$fh>;
174: chomp($loncpid);
175: if (kill 0 => $loncpid) {
176: &logthis("lonc at pid $loncpid responding, sending USR1");
177: kill USR1 => $loncpid;
178: sleep 1;
179: if (-e "$peerfile") { return; }
180: &logthis("$peerfile still not there, give it another try");
181: sleep 5;
182: if (-e "$peerfile") { return; }
1.9 www 183: &logthis(
184: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 185: } else {
1.9 www 186: &logthis(
187: "<font color=red>CRITICAL: "
188: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 189: }
190: } else {
1.9 www 191: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
1.1 albertel 192: }
193: }
194:
195: # -------------------------------------------------- Non-critical communication
1.11 www 196:
1.1 albertel 197: sub subreply {
198: my ($cmd,$server)=@_;
199: my $peerfile="$perlvar{'lonSockDir'}/$server";
200: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
201: Type => SOCK_STREAM,
202: Timeout => 10)
203: or return "con_lost";
204: print $sclient "$cmd\n";
205: my $answer=<$sclient>;
206: chomp($answer);
207: if (!$answer) { $answer="con_lost"; }
208: return $answer;
209: }
210:
211: sub reply {
212: my ($cmd,$server)=@_;
213: my $answer;
214: if ($server ne $perlvar{'lonHostID'}) {
215: $answer=subreply($cmd,$server);
216: if ($answer eq 'con_lost') {
217: $answer=subreply("ping",$server);
218: if ($answer ne $server) {
219: &reconlonc("$perlvar{'lonSockDir'}/$server");
220: }
221: $answer=subreply($cmd,$server);
222: }
223: } else {
224: $answer='self_reply';
225: }
226: return $answer;
227: }
228:
1.13 www 229: # -------------------------------------------------------------- Talk to lonsql
230:
1.12 harris41 231: sub sqlreply {
232: my ($cmd)=@_;
233: my $answer=subsqlreply($cmd);
234: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
235: return $answer;
236: }
237:
238: sub subsqlreply {
239: my ($cmd)=@_;
240: my $unixsock="mysqlsock";
241: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
242: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
243: Type => SOCK_STREAM,
244: Timeout => 10)
245: or return "con_lost";
246: print $sclient "$cmd\n";
247: my $answer=<$sclient>;
248: chomp($answer);
249: if (!$answer) { $answer="con_lost"; }
250: return $answer;
251: }
252:
1.1 albertel 253: # -------------------------------------------- Return path to profile directory
1.11 www 254:
1.1 albertel 255: sub propath {
256: my ($udom,$uname)=@_;
257: $udom=~s/\W//g;
258: $uname=~s/\W//g;
1.16 www 259: my $subdir=$uname.'__';
1.1 albertel 260: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
261: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
262: return $proname;
263: }
264:
265: # --------------------------------------- Is this the home server of an author?
1.11 www 266:
1.1 albertel 267: sub ishome {
268: my $author=shift;
269: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
270: my ($udom,$uname)=split(/\//,$author);
271: my $proname=propath($udom,$uname);
272: if (-e $proname) {
273: return 'owner';
274: } else {
275: return 'not_owner';
276: }
277: }
278:
279: # ======================================================= Continue main program
280: # ---------------------------------------------------- Fork once and dissociate
281:
282: $fpid=fork;
283: exit if $fpid;
1.22 harris41 284: catchdie "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 285:
1.22 harris41 286: POSIX::setsid() or catchdie "Can't start new session: $!";
1.1 albertel 287:
288: # ------------------------------------------------------- Write our PID on disk
289:
290: $execdir=$perlvar{'lonDaemons'};
291: open (PIDSAVE,">$execdir/logs/lond.pid");
292: print PIDSAVE "$$\n";
293: close(PIDSAVE);
1.9 www 294: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.1 albertel 295:
296: # ------------------------------------------------------- Now we are on our own
297:
298: # Fork off our children.
299: for (1 .. $PREFORK) {
300: make_new_child();
301: }
302:
303: # ----------------------------------------------------- Install signal handlers
304:
305: $SIG{CHLD} = \&REAPER;
306: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
307: $SIG{HUP} = \&HUPSMAN;
308:
309: # And maintain the population.
310: while (1) {
311: sleep; # wait for a signal (i.e., child's death)
312: for ($i = $children; $i < $PREFORK; $i++) {
313: make_new_child(); # top up the child pool
314: }
315: }
316:
317: sub make_new_child {
318: my $pid;
319: my $cipher;
320: my $sigset;
321: &logthis("Attempting to start child");
322: # block signal for fork
323: $sigset = POSIX::SigSet->new(SIGINT);
324: sigprocmask(SIG_BLOCK, $sigset)
1.22 harris41 325: or catchdie "Can't block SIGINT for fork: $!\n";
1.1 albertel 326:
1.22 harris41 327: catchdie "fork: $!" unless defined ($pid = fork);
1.1 albertel 328:
329: if ($pid) {
330: # Parent records the child's birth and returns.
331: sigprocmask(SIG_UNBLOCK, $sigset)
1.22 harris41 332: or catchdie "Can't unblock SIGINT for fork: $!\n";
1.1 albertel 333: $children{$pid} = 1;
334: $children++;
335: return;
336: } else {
337: # Child can *not* return from this subroutine.
338: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
339:
340: # unblock signals
341: sigprocmask(SIG_UNBLOCK, $sigset)
1.22 harris41 342: or catchdie "Can't unblock SIGINT for fork: $!\n";
1.13 www 343:
344: $tmpsnum=0;
1.1 albertel 345:
346: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
347: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
348: $client = $server->accept() or last;
349:
350: # =============================================================================
351: # do something with the connection
352: # -----------------------------------------------------------------------------
1.2 www 353: # see if we know client and check for spoof IP by challenge
1.1 albertel 354: my $caller=getpeername($client);
355: my ($port,$iaddr)=unpack_sockaddr_in($caller);
356: my $clientip=inet_ntoa($iaddr);
357: my $clientrec=($hostid{$clientip} ne undef);
1.9 www 358: &logthis(
359: "<font color=yellow>INFO: Connect from $clientip ($hostid{$clientip})</font>");
1.2 www 360: my $clientok;
1.1 albertel 361: if ($clientrec) {
1.2 www 362: my $remotereq=<$client>;
363: $remotereq=~s/\W//g;
364: if ($remotereq eq 'init') {
365: my $challenge="$$".time;
366: print $client "$challenge\n";
367: $remotereq=<$client>;
368: $remotereq=~s/\W//g;
369: if ($challenge eq $remotereq) {
370: $clientok=1;
371: print $client "ok\n";
372: } else {
1.9 www 373: &logthis(
374: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
1.16 www 375: print $client "bye\n";
1.2 www 376: }
377: } else {
1.9 www 378: &logthis(
379: "<font color=blue>WARNING: "
380: ."$clientip failed to initialize: >$remotereq< </font>");
1.16 www 381: print $client "bye\n";
1.2 www 382: }
383: } else {
1.9 www 384: &logthis(
385: "<font color=blue>WARNING: Unknown client $clientip</font>");
1.16 www 386: print $client "bye\n";
1.2 www 387: }
388: if ($clientok) {
1.1 albertel 389: # ---------------- New known client connecting, could mean machine online again
390: &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
1.9 www 391: &logthis(
392: "<font color=green>Established connection: $hostid{$clientip}</font>");
1.1 albertel 393: # ------------------------------------------------------------ Process requests
394: while (my $userinput=<$client>) {
395: chomp($userinput);
396: my $wasenc=0;
397: # ------------------------------------------------------------ See if encrypted
398: if ($userinput =~ /^enc/) {
399: if ($cipher) {
400: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
401: $userinput='';
402: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
403: $userinput.=
404: $cipher->decrypt(
405: pack("H16",substr($encinput,$encidx,16))
406: );
407: }
408: $userinput=substr($userinput,0,$cmdlength);
409: $wasenc=1;
410: }
411: }
412: # ------------------------------------------------------------- Normal commands
413: # ------------------------------------------------------------------------ ping
414: if ($userinput =~ /^ping/) {
415: print $client "$perlvar{'lonHostID'}\n";
416: # ------------------------------------------------------------------------ pong
417: } elsif ($userinput =~ /^pong/) {
418: $reply=reply("ping",$hostid{$clientip});
419: print $client "$perlvar{'lonHostID'}:$reply\n";
420: # ------------------------------------------------------------------------ ekey
421: } elsif ($userinput =~ /^ekey/) {
422: my $buildkey=time.$$.int(rand 100000);
423: $buildkey=~tr/1-6/A-F/;
424: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
425: my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
426: $key=~tr/a-z/A-Z/;
427: $key=~tr/G-P/0-9/;
428: $key=~tr/Q-Z/0-9/;
429: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
430: $key=substr($key,0,32);
431: my $cipherkey=pack("H32",$key);
432: $cipher=new IDEA $cipherkey;
433: print $client "$buildkey\n";
434: # ------------------------------------------------------------------------ load
435: } elsif ($userinput =~ /^load/) {
436: my $loadavg;
437: {
438: my $loadfile=IO::File->new('/proc/loadavg');
439: $loadavg=<$loadfile>;
440: }
441: $loadavg =~ s/\s.*//g;
442: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
443: print $client "$loadpercent\n";
444: # ------------------------------------------------------------------------ auth
445: } elsif ($userinput =~ /^auth/) {
446: if ($wasenc==1) {
447: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
448: chomp($upass);
1.11 www 449: $upass=unescape($upass);
1.1 albertel 450: my $proname=propath($udom,$uname);
451: my $passfilename="$proname/passwd";
452: if (-e $passfilename) {
453: my $pf = IO::File->new($passfilename);
454: my $realpasswd=<$pf>;
455: chomp($realpasswd);
1.2 www 456: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
457: my $pwdcorrect=0;
458: if ($howpwd eq 'internal') {
459: $pwdcorrect=
460: (crypt($upass,$contentpwd) eq $contentpwd);
461: } elsif ($howpwd eq 'unix') {
462: $contentpwd=(getpwnam($uname))[1];
463: $pwdcorrect=
464: (crypt($upass,$contentpwd) eq $contentpwd);
1.3 www 465: } elsif ($howpwd eq 'krb4') {
466: $pwdcorrect=(
467: Authen::Krb4::get_pw_in_tkt($uname,"",
468: $contentpwd,'krbtgt',$contentpwd,1,
469: $upass) == 0);
1.2 www 470: }
471: if ($pwdcorrect) {
1.1 albertel 472: print $client "authorized\n";
473: } else {
474: print $client "non_authorized\n";
475: }
476: } else {
477: print $client "unknown_user\n";
478: }
479: } else {
480: print $client "refused\n";
481: }
482: # ---------------------------------------------------------------------- passwd
483: } elsif ($userinput =~ /^passwd/) {
484: if ($wasenc==1) {
485: my
486: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
487: chomp($npass);
488: my $proname=propath($udom,$uname);
489: my $passfilename="$proname/passwd";
490: if (-e $passfilename) {
491: my $realpasswd;
492: { my $pf = IO::File->new($passfilename);
493: $realpasswd=<$pf>; }
494: chomp($realpasswd);
1.2 www 495: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
496: if ($howpwd eq 'internal') {
497: if (crypt($upass,$contentpwd) eq $contentpwd) {
498: my $salt=time;
499: $salt=substr($salt,6,2);
500: my $ncpass=crypt($npass,$salt);
1.1 albertel 501: { my $pf = IO::File->new(">$passfilename");
1.2 www 502: print $pf "internal:$ncpass\n";; }
1.1 albertel 503: print $client "ok\n";
1.2 www 504: } else {
505: print $client "non_authorized\n";
506: }
1.1 albertel 507: } else {
1.2 www 508: print $client "auth_mode_error\n";
1.1 albertel 509: }
510: } else {
511: print $client "unknown_user\n";
512: }
513: } else {
514: print $client "refused\n";
515: }
516: # ------------------------------------------------------------------------ home
517: } elsif ($userinput =~ /^home/) {
518: my ($cmd,$udom,$uname)=split(/:/,$userinput);
519: chomp($uname);
520: my $proname=propath($udom,$uname);
521: if (-e $proname) {
522: print $client "found\n";
523: } else {
524: print $client "not_found\n";
525: }
526: # ---------------------------------------------------------------------- update
527: } elsif ($userinput =~ /^update/) {
528: my ($cmd,$fname)=split(/:/,$userinput);
529: my $ownership=ishome($fname);
530: if ($ownership eq 'not_owner') {
531: if (-e $fname) {
532: my ($dev,$ino,$mode,$nlink,
533: $uid,$gid,$rdev,$size,
534: $atime,$mtime,$ctime,
535: $blksize,$blocks)=stat($fname);
536: $now=time;
537: $since=$now-$atime;
538: if ($since>$perlvar{'lonExpire'}) {
539: $reply=
540: reply("unsub:$fname","$hostid{$clientip}");
541: unlink("$fname");
542: } else {
543: my $transname="$fname.in.transfer";
544: my $remoteurl=
545: reply("sub:$fname","$hostid{$clientip}");
546: my $response;
547: {
548: my $ua=new LWP::UserAgent;
549: my $request=new HTTP::Request('GET',"$remoteurl");
550: $response=$ua->request($request,$transname);
551: }
552: if ($response->is_error()) {
1.24 ! albertel 553: unlink($transname);
1.1 albertel 554: my $message=$response->status_line;
555: &logthis(
556: "LWP GET: $message for $fname ($remoteurl)");
557: } else {
1.14 www 558: if ($remoteurl!~/\.meta$/) {
559: my $mrequest=
560: new HTTP::Request('GET',$remoteurl.'.meta');
561: my $mresponse=
562: $ua->request($mrequest,$fname.'.meta');
563: if ($mresponse->is_error()) {
564: unlink($fname.'.meta');
565: }
566: }
1.1 albertel 567: rename($transname,$fname);
568: }
569: }
570: print $client "ok\n";
571: } else {
572: print $client "not_found\n";
573: }
574: } else {
575: print $client "rejected\n";
576: }
577: # ----------------------------------------------------------------- unsubscribe
578: } elsif ($userinput =~ /^unsub/) {
579: my ($cmd,$fname)=split(/:/,$userinput);
580: if (-e $fname) {
581: if (unlink("$fname.$hostid{$clientip}")) {
582: print $client "ok\n";
583: } else {
584: print $client "not_subscribed\n";
585: }
586: } else {
587: print $client "not_found\n";
588: }
589: # ------------------------------------------------------------------- subscribe
590: } elsif ($userinput =~ /^sub/) {
591: my ($cmd,$fname)=split(/:/,$userinput);
592: my $ownership=ishome($fname);
593: if ($ownership eq 'owner') {
594: if (-e $fname) {
1.18 www 595: if (-d $fname) {
596: print $client "directory\n";
597: } else {
1.1 albertel 598: $now=time;
599: {
600: my $sh=IO::File->new(">$fname.$hostid{$clientip}");
601: print $sh "$clientip:$now\n";
602: }
603: $fname=~s/\/home\/httpd\/html\/res/raw/;
604: $fname="http://$thisserver/".$fname;
605: print $client "$fname\n";
1.18 www 606: }
1.1 albertel 607: } else {
608: print $client "not_found\n";
609: }
610: } else {
611: print $client "rejected\n";
612: }
1.12 harris41 613: # ------------------------------------------------------------------------- log
614: } elsif ($userinput =~ /^log/) {
615: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
616: chomp($what);
617: my $proname=propath($udom,$uname);
618: my $now=time;
619: {
620: my $hfh;
621: if ($hfh=IO::File->new(">>$proname/activity.log")) {
622: print $hfh "$now:$hostid{$clientip}:$what\n";
623: print $client "ok\n";
624: } else {
625: print $client "error:$!\n";
626: }
627: }
1.1 albertel 628: # ------------------------------------------------------------------------- put
629: } elsif ($userinput =~ /^put/) {
1.6 www 630: my ($cmd,$udom,$uname,$namespace,$what)
1.1 albertel 631: =split(/:/,$userinput);
1.8 www 632: $namespace=~s/\//\_/g;
1.6 www 633: $namespace=~s/\W//g;
634: if ($namespace ne 'roles') {
1.1 albertel 635: chomp($what);
636: my $proname=propath($udom,$uname);
637: my $now=time;
638: {
639: my $hfh;
640: if (
641: $hfh=IO::File->new(">>$proname/$namespace.hist")
642: ) { print $hfh "P:$now:$what\n"; }
643: }
644: my @pairs=split(/\&/,$what);
1.4 www 645: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 646: foreach $pair (@pairs) {
647: ($key,$value)=split(/=/,$pair);
648: $hash{$key}=$value;
649: }
1.4 www 650: if (untie(%hash)) {
1.1 albertel 651: print $client "ok\n";
652: } else {
653: print $client "error:$!\n";
654: }
655: } else {
656: print $client "error:$!\n";
657: }
1.6 www 658: } else {
659: print $client "refused\n";
660: }
661: # -------------------------------------------------------------------- rolesput
662: } elsif ($userinput =~ /^rolesput/) {
663: if ($wasenc==1) {
664: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
665: =split(/:/,$userinput);
666: my $namespace='roles';
667: chomp($what);
668: my $proname=propath($udom,$uname);
669: my $now=time;
670: {
671: my $hfh;
672: if (
673: $hfh=IO::File->new(">>$proname/$namespace.hist")
674: ) {
675: print $hfh "P:$now:$exedom:$exeuser:$what\n";
676: }
677: }
678: my @pairs=split(/\&/,$what);
679: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
680: foreach $pair (@pairs) {
681: ($key,$value)=split(/=/,$pair);
682: $hash{$key}=$value;
683: }
684: if (untie(%hash)) {
685: print $client "ok\n";
686: } else {
687: print $client "error:$!\n";
688: }
689: } else {
690: print $client "error:$!\n";
691: }
692: } else {
693: print $client "refused\n";
694: }
1.1 albertel 695: # ------------------------------------------------------------------------- get
696: } elsif ($userinput =~ /^get/) {
697: my ($cmd,$udom,$uname,$namespace,$what)
698: =split(/:/,$userinput);
1.8 www 699: $namespace=~s/\//\_/g;
1.1 albertel 700: $namespace=~s/\W//g;
701: chomp($what);
702: my @queries=split(/\&/,$what);
703: my $proname=propath($udom,$uname);
704: my $qresult='';
1.20 www 705: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 706: for ($i=0;$i<=$#queries;$i++) {
707: $qresult.="$hash{$queries[$i]}&";
708: }
1.4 www 709: if (untie(%hash)) {
1.1 albertel 710: $qresult=~s/\&$//;
711: print $client "$qresult\n";
712: } else {
713: print $client "error:$!\n";
714: }
715: } else {
716: print $client "error:$!\n";
717: }
718: # ------------------------------------------------------------------------ eget
719: } elsif ($userinput =~ /^eget/) {
720: my ($cmd,$udom,$uname,$namespace,$what)
721: =split(/:/,$userinput);
1.8 www 722: $namespace=~s/\//\_/g;
1.1 albertel 723: $namespace=~s/\W//g;
724: chomp($what);
725: my @queries=split(/\&/,$what);
726: my $proname=propath($udom,$uname);
727: my $qresult='';
1.20 www 728: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 729: for ($i=0;$i<=$#queries;$i++) {
730: $qresult.="$hash{$queries[$i]}&";
731: }
1.4 www 732: if (untie(%hash)) {
1.1 albertel 733: $qresult=~s/\&$//;
734: if ($cipher) {
735: my $cmdlength=length($qresult);
736: $qresult.=" ";
737: my $encqresult='';
738: for
739: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
740: $encqresult.=
741: unpack("H16",
742: $cipher->encrypt(substr($qresult,$encidx,8)));
743: }
744: print $client "enc:$cmdlength:$encqresult\n";
745: } else {
746: print $client "error:no_key\n";
747: }
748: } else {
749: print $client "error:$!\n";
750: }
751: } else {
752: print $client "error:$!\n";
753: }
754: # ------------------------------------------------------------------------- del
755: } elsif ($userinput =~ /^del/) {
756: my ($cmd,$udom,$uname,$namespace,$what)
757: =split(/:/,$userinput);
1.8 www 758: $namespace=~s/\//\_/g;
1.1 albertel 759: $namespace=~s/\W//g;
760: chomp($what);
761: my $proname=propath($udom,$uname);
762: my $now=time;
763: {
764: my $hfh;
765: if (
766: $hfh=IO::File->new(">>$proname/$namespace.hist")
767: ) { print $hfh "D:$now:$what\n"; }
768: }
769: my @keys=split(/\&/,$what);
1.4 www 770: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 771: foreach $key (@keys) {
772: delete($hash{$key});
773: }
1.4 www 774: if (untie(%hash)) {
1.1 albertel 775: print $client "ok\n";
776: } else {
777: print $client "error:$!\n";
778: }
779: } else {
780: print $client "error:$!\n";
781: }
782: # ------------------------------------------------------------------------ keys
783: } elsif ($userinput =~ /^keys/) {
784: my ($cmd,$udom,$uname,$namespace)
785: =split(/:/,$userinput);
1.8 www 786: $namespace=~s/\//\_/g;
1.1 albertel 787: $namespace=~s/\W//g;
788: my $proname=propath($udom,$uname);
789: my $qresult='';
1.20 www 790: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 791: foreach $key (keys %hash) {
792: $qresult.="$key&";
793: }
1.4 www 794: if (untie(%hash)) {
1.1 albertel 795: $qresult=~s/\&$//;
796: print $client "$qresult\n";
797: } else {
798: print $client "error:$!\n";
799: }
800: } else {
801: print $client "error:$!\n";
802: }
803: # ------------------------------------------------------------------------ dump
804: } elsif ($userinput =~ /^dump/) {
805: my ($cmd,$udom,$uname,$namespace)
806: =split(/:/,$userinput);
1.8 www 807: $namespace=~s/\//\_/g;
1.1 albertel 808: $namespace=~s/\W//g;
809: my $proname=propath($udom,$uname);
810: my $qresult='';
1.20 www 811: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 812: foreach $key (keys %hash) {
813: $qresult.="$key=$hash{$key}&";
1.7 www 814: }
815: if (untie(%hash)) {
816: $qresult=~s/\&$//;
817: print $client "$qresult\n";
818: } else {
819: print $client "error:$!\n";
820: }
821: } else {
822: print $client "error:$!\n";
823: }
824: # ----------------------------------------------------------------------- store
825: } elsif ($userinput =~ /^store/) {
826: my ($cmd,$udom,$uname,$namespace,$rid,$what)
827: =split(/:/,$userinput);
1.8 www 828: $namespace=~s/\//\_/g;
1.7 www 829: $namespace=~s/\W//g;
830: if ($namespace ne 'roles') {
831: chomp($what);
832: my $proname=propath($udom,$uname);
833: my $now=time;
834: {
835: my $hfh;
836: if (
837: $hfh=IO::File->new(">>$proname/$namespace.hist")
838: ) { print $hfh "P:$now:$rid:$what\n"; }
839: }
840: my @pairs=split(/\&/,$what);
841:
842: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
843: my @previouskeys=split(/&/,$hash{"keys:$rid"});
844: my $key;
845: $hash{"version:$rid"}++;
846: my $version=$hash{"version:$rid"};
847: my $allkeys='';
848: foreach $pair (@pairs) {
849: ($key,$value)=split(/=/,$pair);
850: $allkeys.=$key.':';
851: $hash{"$version:$rid:$key"}=$value;
852: }
853: $allkeys=~s/:$//;
854: $hash{"$version:keys:$rid"}=$allkeys;
855: if (untie(%hash)) {
856: print $client "ok\n";
857: } else {
858: print $client "error:$!\n";
859: }
860: } else {
861: print $client "error:$!\n";
862: }
863: } else {
864: print $client "refused\n";
865: }
866: # --------------------------------------------------------------------- restore
867: } elsif ($userinput =~ /^restore/) {
868: my ($cmd,$udom,$uname,$namespace,$rid)
869: =split(/:/,$userinput);
1.8 www 870: $namespace=~s/\//\_/g;
1.7 www 871: $namespace=~s/\W//g;
872: chomp($rid);
873: my $proname=propath($udom,$uname);
874: my $qresult='';
1.20 www 875: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.7 www 876: my $version=$hash{"version:$rid"};
877: $qresult.="version=$version&";
878: my $scope;
879: for ($scope=1;$scope<=$version;$scope++) {
880: my $vkeys=$hash{"$scope:keys:$rid"};
881: my @keys=split(/:/,$vkeys);
882: my $key;
883: $qresult.="$scope:keys=$vkeys&";
884: foreach $key (@keys) {
1.21 www 885: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1.7 www 886: }
1.1 albertel 887: }
1.4 www 888: if (untie(%hash)) {
1.1 albertel 889: $qresult=~s/\&$//;
890: print $client "$qresult\n";
891: } else {
892: print $client "error:$!\n";
893: }
894: } else {
895: print $client "error:$!\n";
896: }
1.12 harris41 897: # ------------------------------------------------------------------- querysend
898: } elsif ($userinput =~ /^querysend/) {
899: my ($cmd,$query)=split(/:/,$userinput);
900: $query=~s/\n*$//g;
1.13 www 901: print $client sqlreply("$hostid{$clientip}\&$query")."\n";
1.12 harris41 902: # ------------------------------------------------------------------ queryreply
903: } elsif ($userinput =~ /^queryreply/) {
904: my ($cmd,$id,$reply)=split(/:/,$userinput);
905: my $store;
1.13 www 906: my $execdir=$perlvar{'lonDaemons'};
907: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1.12 harris41 908: print $store $reply;
909: close $store;
910: print $client "ok\n";
911: }
912: else {
913: print $client "error:$!\n";
914: }
1.1 albertel 915: # ----------------------------------------------------------------------- idput
916: } elsif ($userinput =~ /^idput/) {
917: my ($cmd,$udom,$what)=split(/:/,$userinput);
918: chomp($what);
919: $udom=~s/\W//g;
920: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
921: my $now=time;
922: {
923: my $hfh;
924: if (
925: $hfh=IO::File->new(">>$proname.hist")
926: ) { print $hfh "P:$now:$what\n"; }
927: }
928: my @pairs=split(/\&/,$what);
1.4 www 929: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 930: foreach $pair (@pairs) {
931: ($key,$value)=split(/=/,$pair);
932: $hash{$key}=$value;
933: }
1.4 www 934: if (untie(%hash)) {
1.1 albertel 935: print $client "ok\n";
936: } else {
937: print $client "error:$!\n";
938: }
939: } else {
940: print $client "error:$!\n";
941: }
942: # ----------------------------------------------------------------------- idget
943: } elsif ($userinput =~ /^idget/) {
944: my ($cmd,$udom,$what)=split(/:/,$userinput);
945: chomp($what);
946: $udom=~s/\W//g;
947: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
948: my @queries=split(/\&/,$what);
949: my $qresult='';
1.20 www 950: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
1.1 albertel 951: for ($i=0;$i<=$#queries;$i++) {
952: $qresult.="$hash{$queries[$i]}&";
953: }
1.4 www 954: if (untie(%hash)) {
1.1 albertel 955: $qresult=~s/\&$//;
956: print $client "$qresult\n";
957: } else {
958: print $client "error:$!\n";
959: }
960: } else {
961: print $client "error:$!\n";
962: }
1.13 www 963: # ---------------------------------------------------------------------- tmpput
964: } elsif ($userinput =~ /^tmpput/) {
965: my ($cmd,$what)=split(/:/,$userinput);
966: my $store;
967: $tmpsnum++;
968: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
969: $id=~s/\W/\_/g;
970: $what=~s/\n//g;
971: my $execdir=$perlvar{'lonDaemons'};
972: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
973: print $store $what;
974: close $store;
975: print $client "$id\n";
976: }
977: else {
978: print $client "error:$!\n";
979: }
980:
981: # ---------------------------------------------------------------------- tmpget
982: } elsif ($userinput =~ /^tmpget/) {
983: my ($cmd,$id)=split(/:/,$userinput);
984: chomp($id);
985: $id=~s/\W/\_/g;
986: my $store;
987: my $execdir=$perlvar{'lonDaemons'};
988: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
989: my $reply=<$store>;
990: print $client "$reply\n";
991: close $store;
992: }
993: else {
994: print $client "error:$!\n";
995: }
996:
1.5 www 997: # -------------------------------------------------------------------------- ls
998: } elsif ($userinput =~ /^ls/) {
999: my ($cmd,$ulsdir)=split(/:/,$userinput);
1000: my $ulsout='';
1001: my $ulsfn;
1002: if (-e $ulsdir) {
1003: while ($ulsfn=<$ulsdir/*>) {
1004: my @ulsstats=stat($ulsfn);
1005: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1006: }
1007: } else {
1008: $ulsout='no_such_dir';
1009: }
1.17 www 1010: if ($ulsout eq '') { $ulsout='empty'; }
1.5 www 1011: print $client "$ulsout\n";
1.1 albertel 1012: # ------------------------------------------------------------- unknown command
1013: } else {
1014: # unknown command
1015: print $client "unknown_cmd\n";
1016: }
1017: # ------------------------------------------------------ client unknown, refuse
1018: }
1019: } else {
1020: print $client "refused\n";
1.9 www 1021: &logthis("<font color=blue>WARNING: "
1022: ."Rejected client $clientip, closing connection</font>");
1.1 albertel 1023: }
1.9 www 1024: &logthis("<font color=red>CRITICAL: "
1.10 www 1025: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1.1 albertel 1026: # =============================================================================
1027: }
1028:
1029: # tidy up gracefully and finish
1030:
1031: # this exit is VERY important, otherwise the child will become
1032: # a producer of more and more children, forking yourself into
1033: # process death.
1034: exit;
1035: }
1036: }
1037:
1038:
1039:
1040:
1041:
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