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