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