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