--- loncom/lond 2004/04/07 10:02:11 1.186 +++ loncom/lond 2004/06/17 11:02:25 1.196 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.186 2004/04/07 10:02:11 foxr Exp $ +# $Id: lond,v 1.196 2004/06/17 11:02:25 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -45,25 +45,29 @@ use Authen::Krb4; use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; +use localenroll; use File::Copy; use LONCAPA::ConfigFileEdit; +use LONCAPA::lonlocal; +use LONCAPA::lonssl; -my $DEBUG = 0; # Non zero to enable debug log entries. +my $DEBUG = 11; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.186 $'; #' stupid emacs +my $VERSION='$Revision: 1.196 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; my $client; -my $clientip; -my $clientname; +my $clientip; # IP address of client. +my $clientdns; # DNS name of client. +my $clientname; # LonCAPA name of client. my $server; -my $thisserver; +my $thisserver; # DNS of us. # # Connection type is: @@ -74,9 +78,10 @@ my $thisserver; my $ConnectionType; -my %hostid; -my %hostdom; -my %hostip; +my %hostid; # ID's for hosts in cluster by ip. +my %hostdom; # LonCAPA domain for hosts in cluster. +my %hostip; # IPs for hosts in cluster. +my %hostdns; # ID's of hosts looked up by DNS name. my %managers; # Ip -> manager names @@ -120,6 +125,178 @@ my @adderrors = ("ok", "lcuseradd Password mismatch"); +#------------------------------------------------------------------------ +# +# LocalConnection +# Completes the formation of a locally authenticated connection. +# This function will ensure that the 'remote' client is really the +# local host. If not, the connection is closed, and the function fails. +# If so, initcmd is parsed for the name of a file containing the +# IDEA session key. The fie is opened, read, deleted and the session +# key returned to the caller. +# +# Parameters: +# $Socket - Socket open on client. +# $initcmd - The full text of the init command. +# +# Implicit inputs: +# $clientdns - The DNS name of the remote client. +# $thisserver - Our DNS name. +# +# Returns: +# IDEA session key on success. +# undef on failure. +# +sub LocalConnection { + my ($Socket, $initcmd) = @_; + Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver"); + if($clientdns ne $thisserver) { + &logthis(' LocalConnection rejecting non local: ' + ."$clientdns ne $thisserver "); + close $Socket; + return undef; + } + else { + chomp($initcmd); # Get rid of \n in filename. + my ($init, $type, $name) = split(/:/, $initcmd); + Debug(" Init command: $init $type $name "); + + # Require that $init = init, and $type = local: Otherwise + # the caller is insane: + + if(($init ne "init") && ($type ne "local")) { + &logthis(' LocalConnection: caller is insane! ' + ."init = $init, and type = $type "); + close($Socket);; + return undef; + + } + # Now get the key filename: + + my $IDEAKey = lonlocal::ReadKeyFile($name); + return $IDEAKey; + } +} +#------------------------------------------------------------------------------ +# +# SSLConnection +# Completes the formation of an ssh authenticated connection. The +# socket is promoted to an ssl socket. If this promotion and the associated +# certificate exchange are successful, the IDEA key is generated and sent +# to the remote peer via the SSL tunnel. The IDEA key is also returned to +# the caller after the SSL tunnel is torn down. +# +# Parameters: +# Name Type Purpose +# $Socket IO::Socket::INET Plaintext socket. +# +# Returns: +# IDEA key on success. +# undef on failure. +# +sub SSLConnection { + my $Socket = shift; + + Debug("SSLConnection: "); + my $KeyFile = lonssl::KeyFile(); + if(!$KeyFile) { + my $err = lonssl::LastError(); + &logthis(" CRITICAL" + ."Can't get key file $err "); + return undef; + } + my ($CACertificate, + $Certificate) = lonssl::CertificateFile(); + + + # If any of the key, certificate or certificate authority + # certificate filenames are not defined, this can't work. + + if((!$Certificate) || (!$CACertificate)) { + my $err = lonssl::LastError(); + &logthis(" CRITICAL" + ."Can't get certificates: $err "); + + return undef; + } + Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate"); + + # Indicate to our peer that we can procede with + # a transition to ssl authentication: + + print $Socket "ok:ssl\n"; + + Debug("Approving promotion -> ssl"); + # And do so: + + my $SSLSocket = lonssl::PromoteServerSocket($Socket, + $CACertificate, + $Certificate, + $KeyFile); + if(! ($SSLSocket) ) { # SSL socket promotion failed. + my $err = lonssl::LastError(); + &logthis(" CRITICAL " + ."SSL Socket promotion failed: $err "); + return undef; + } + Debug("SSL Promotion successful"); + + # + # The only thing we'll use the socket for is to send the IDEA key + # to the peer: + + my $Key = lonlocal::CreateCipherKey(); + print $SSLSocket "$Key\n"; + + lonssl::Close($SSLSocket); + + Debug("Key exchange complete: $Key"); + + return $Key; +} +# +# InsecureConnection: +# If insecure connections are allowd, +# exchange a challenge with the client to 'validate' the +# client (not really, but that's the protocol): +# We produce a challenge string that's sent to the client. +# The client must then echo the challenge verbatim to us. +# +# Parameter: +# Socket - Socket open on the client. +# Returns: +# 1 - success. +# 0 - failure (e.g.mismatch or insecure not allowed). +# +sub InsecureConnection { + my $Socket = shift; + + # Don't even start if insecure connections are not allowed. + + if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed. + return 0; + } + + # Fabricate a challenge string and send it.. + + my $challenge = "$$".time; # pid + time. + print $Socket "$challenge\n"; + &status("Waiting for challenge reply"); + + my $answer = <$Socket>; + $answer =~s/\W//g; + if($challenge eq $answer) { + return 1; + } + else { + logthis("WARNING client did not respond to challenge"); + &status("No challenge reqply"); + return 0; + } + + +} + # # GetCertificate: Given a transaction that requires a certificate, # this function will extract the certificate from the transaction @@ -225,8 +402,8 @@ sub ValidManager { # 1 - Success. # sub CopyFile { - my $oldfile = shift; - my $newfile = shift; + + my ($oldfile, $newfile) = @_; # The file must exist: @@ -326,8 +503,8 @@ sub AdjustHostContents { # 0 - failure and $! has an errno. # sub InstallFile { - my $Filename = shift; - my $Contents = shift; + + my ($Filename, $Contents) = @_; my $TempFile = $Filename.".tmp"; # Open the file for write: @@ -350,6 +527,8 @@ sub InstallFile { return 1; } + + # # ConfigFileFromSelector: converts a configuration file selector # (one of host or domain at this point) into a @@ -564,8 +743,8 @@ sub isValidEditCommand { # file being edited. # sub ApplyEdit { - my $directive = shift; - my $editor = shift; + + my ($directive, $editor) = @_; # Break the directive down into its command and its parameters # (at most two at this point. The meaning of the parameters, if in fact @@ -649,8 +828,8 @@ sub AdjustOurHost { # editor - Editor containing the file. # sub ReplaceConfigFile { - my $filename = shift; - my $editor = shift; + + my ($filename, $editor) = @_; CopyFile ($filename, $filename.".old"); @@ -749,7 +928,7 @@ sub catchexception { $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; &status("Catching exception"); - &logthis("CRITICAL: " + &logthis("CRITICAL: " ."ABNORMAL EXIT. Child $$ for server $thisserver died through " ."a crash with this error msg->[$error]"); &logthis('Famous last words: '.$status.' - '.$lastlog); @@ -760,7 +939,7 @@ sub catchexception { sub timeout { &status("Handling Timeout"); - &logthis("CRITICAL: TIME OUT ".$$.""); + &logthis("CRITICAL: TIME OUT ".$$.""); &catchexception('Timeout'); } # -------------------------------- Set signal handlers to record abnormal exits @@ -843,7 +1022,7 @@ sub HUNTSMAN { # si &logthis("Free socket: ".shutdown($server,2)); # free up socket my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); - &logthis("CRITICAL: Shutting down"); + &logthis("CRITICAL: Shutting down"); &status("Done killing children"); exit; # clean up with dignity } @@ -853,7 +1032,7 @@ sub HUPSMAN { # sig &status("Killing children for restart (HUP)"); kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket - &logthis("CRITICAL: Restarting"); + &logthis("CRITICAL: Restarting"); my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); &status("Restarting self (HUP)"); @@ -863,7 +1042,7 @@ sub HUPSMAN { # sig # # Kill off hashes that describe the host table prior to re-reading it. # Hashes affected are: -# %hostid, %hostdom %hostip +# %hostid, %hostdom %hostip %hostdns. # sub KillHostHashes { foreach my $key (keys %hostid) { @@ -875,6 +1054,9 @@ sub KillHostHashes { foreach my $key (keys %hostip) { delete $hostip{$key}; } + foreach my $key (keys %hostdns) { + delete $hostdns{$key}; + } } # # Read in the host table from file and distribute it into the various hashes: @@ -885,15 +1067,21 @@ sub KillHostHashes { sub ReadHostTable { open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; - + my $myloncapaname = $perlvar{'lonHostID'}; + Debug("My loncapa name is : $myloncapaname"); while (my $configline=) { if (!($configline =~ /^\s*\#/)) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); chomp($ip); $ip=~s/\D+$//; - $hostid{$ip}=$id; - $hostdom{$id}=$domain; - $hostip{$id}=$ip; - if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } + $hostid{$ip}=$id; # LonCAPA name of host by IP. + $hostdom{$id}=$domain; # LonCAPA domain name of host. + $hostip{$id}=$ip; # IP address of host. + $hostdns{$name} = $id; # LonCAPA name of host by DNS. + + if ($id eq $perlvar{'lonHostID'}) { + Debug("Found me in the host table: $name"); + $thisserver=$name; + } } } close(CONFIG); @@ -1015,9 +1203,8 @@ sub Debug { # request - Original request from client. # sub Reply { - my $fd = shift; - my $reply = shift; - my $request = shift; + + my ($fd, $reply, $request) = @_; print $fd $reply; Debug("Request was $request Reply was $reply"); @@ -1030,7 +1217,8 @@ sub logstatus { my $docdir=$perlvar{'lonDocRoot'}; { my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); - print $fh $$."\t".$clientname."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; + print $fh $$."\t".$clientname."\t".$currenthostid."\t" + .$status."\t".$lastlog."\n"; $fh->close(); } &status("Finished londstatus.txt"); @@ -1095,11 +1283,11 @@ sub reconlonc { kill USR1 => $loncpid; } else { &logthis( - "CRITICAL: " + "CRITICAL: " ."lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('CRITICAL: lonc not running, giving up'); + &logthis('CRITICAL: lonc not running, giving up'); } } @@ -1203,7 +1391,7 @@ my $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lond.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); -&logthis("CRITICAL: ---------- Starting ----------"); +&logthis("CRITICAL: ---------- Starting ----------"); &status('Starting'); @@ -1265,9 +1453,12 @@ sub make_new_child { &logthis("Unable to determine who caller was, getpeername returned nothing"); } if (defined($iaddr)) { - $clientip=inet_ntoa($iaddr); + $clientip = inet_ntoa($iaddr); + Debug("Connected with $clientip"); + $clientdns = gethostbyaddr($iaddr, AF_INET); + Debug("Connected with $clientdns by name"); } else { - &logthis("Unable to determine clinetip"); + &logthis("Unable to determine clientip"); $clientip='Unavailable'; } @@ -1301,7 +1492,7 @@ sub make_new_child { # ============================================================================= # do something with the connection # ----------------------------------------------------------------------------- - # see if we know client and check for spoof IP by challenge + # see if we know client and 'check' for spoof IP by ineffective challenge ReadManagerTable; # May also be a manager!! @@ -1319,6 +1510,7 @@ sub make_new_child { $clientname = $managers{$clientip}; } my $clientok; + if ($clientrec || $ismanager) { &status("Waiting for init from $clientip $clientname"); &logthis('INFO: Connection, '. @@ -1326,34 +1518,92 @@ sub make_new_child { " ($clientname) connection type = $ConnectionType " ); &status("Connecting $clientip ($clientname))"); my $remotereq=<$client>; - $remotereq=~s/[^\w:]//g; + chomp($remotereq); + Debug("Got init: $remotereq"); + my $inikeyword = split(/:/, $remotereq); if ($remotereq =~ /^init/) { &sethost("sethost:$perlvar{'lonHostID'}"); - my $challenge="$$".time; - print $client "$challenge\n"; - &status( - "Waiting for challenge reply from $clientip ($clientname)"); - $remotereq=<$client>; - $remotereq=~s/\W//g; - if ($challenge eq $remotereq) { - $clientok=1; - print $client "ok\n"; + # + # If the remote is attempting a local init... give that a try: + # + my ($i, $inittype) = split(/:/, $remotereq); + + # If the connection type is ssl, but I didn't get my + # certificate files yet, then I'll drop back to + # insecure (if allowed). + + if($inittype eq "ssl") { + my ($ca, $cert) = lonssl::CertificateFile; + my $kfile = lonssl::KeyFile; + if((!$ca) || + (!$cert) || + (!$kfile)) { + $inittype = ""; # This forces insecure attempt. + &logthis(" Certificates not " + ."installed -- trying insecure auth"); + } + else { # SSL certificates are in place so + } # Leave the inittype alone. + } + + if($inittype eq "local") { + my $key = LocalConnection($client, $remotereq); + if($key) { + Debug("Got local key $key"); + $clientok = 1; + my $cipherkey = pack("H32", $key); + $cipher = new IDEA($cipherkey); + print $client "ok:local\n"; + &logthis('"); + } else { + Debug("Failed to get local key"); + $clientok = 0; + shutdown($client, 3); + close $client; + } + } elsif ($inittype eq "ssl") { + my $key = SSLConnection($client); + if ($key) { + $clientok = 1; + my $cipherkey = pack("H32", $key); + $cipher = new IDEA($cipherkey); + &logthis('' + ."Successfull ssl authentication with $clientname "); + + } else { + $clientok = 0; + close $client; + } + } else { - &logthis( - "WARNING: $clientip did not reply challenge"); - &status('No challenge reply '.$clientip); + my $ok = InsecureConnection($client); + if($ok) { + $clientok = 1; + &logthis('' + ."Successful insecure authentication with $clientname "); + print $client "ok\n"; + } else { + &logthis('' + ."Attempted insecure connection disallowed "); + close $client; + $clientok = 0; + + } } } else { &logthis( - "WARNING: " + "WARNING: " ."$clientip failed to initialize: >$remotereq< "); &status('No init '.$clientip); } + } else { &logthis( - "WARNING: Unknown client $clientip"); + "WARNING: Unknown client $clientip"); &status('Hung up on '.$clientip); } + if ($clientok) { # ---------------- New known client connecting, could mean machine online again @@ -1365,7 +1615,7 @@ sub make_new_child { } &reconlonc("$perlvar{'lonSockDir'}/$id"); } - &logthis("Established connection: $clientname"); + &logthis("Established connection: $clientname"); &status('Will listen to '.$clientname); # ------------------------------------------------------------ Process requests while (my $userinput=<$client>) { @@ -1562,7 +1812,7 @@ sub make_new_child { $pwdcorrect=0; # log error if it is not a bad password if ($krb4_error != 62) { - &logthis('krb4:'.$uname.','.$contentpwd.','. + &logthis('krb4:'.$uname.','. &Authen::Krb4::get_err_txt($Authen::Krb4::error)); } } @@ -1872,6 +2122,37 @@ sub make_new_child { } else { Reply($client, "refused\n", $userinput); } +# --------------------------------------------------------- remove a user file + } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc. + if(isClient) { + my ($cmd,$fname)=split(/:/,$userinput); + my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); + &logthis("$udom - $uname - $ufile"); + if ($ufile =~m|/\.\./|) { + # any files paths with /../ in them refuse + # to deal with + print $client "refused\n"; + } else { + my $udir=propath($udom,$uname); + if (-e $udir) { + my $file=$udir.'/userfiles/'.$ufile; + if (-e $file) { + unlink($file); + if (-e $file) { + print $client "failed\n"; + } else { + print $client "ok\n"; + } + } else { + print $client "not_found\n"; + } + } else { + print $client "not_home\n"; + } + } + } else { + Reply($client, "refused\n", $userinput); + } # ------------------------------------------ authenticate access to a user file } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only if(isClient) { @@ -1897,7 +2178,7 @@ sub make_new_child { if(isClient) { my ($cmd,$fname)=split(/:/,$userinput); if (-e $fname) { - print $client &unsub($client,$fname,$clientip); + print $client &unsub($fname,$clientip); } else { print $client "not_found\n"; } @@ -2502,7 +2783,7 @@ sub make_new_child { } # ------------------------------------------------------------------- querysend } elsif ($userinput =~ /^querysend/) { - if(isClient) { + if (isClient) { my ($cmd,$query, $arg1,$arg2,$arg3)=split(/\:/,$userinput); $query=~s/\n*$//g; @@ -2592,7 +2873,7 @@ sub make_new_child { $qresult.=$key.'='.$descr.'&'; } else { my $unescapeVal = &unescape($descr); - if (eval('$unescapeVal=~/$description/i')) { + if (eval('$unescapeVal=~/\Q$description\E/i')) { $qresult.="$key=$descr&"; } } @@ -2833,6 +3114,78 @@ sub make_new_child { } else { print $client "refused\n"; } +#------------------------------- is auto-enrollment enabled? + } elsif ($userinput =~/^autorun/) { + if (isClient) { + my $outcome = &localenroll::run(); + print $client "$outcome\n"; + } else { + print $client "0\n"; + } +#------------------------------- get official sections (for auto-enrollment). + } elsif ($userinput =~/^autogetsections/) { + if (isClient) { + my ($cmd,$coursecode)=split(/:/,$userinput); + my @secs = &localenroll::get_sections($coursecode); + my $seclist = &escape(join(':',@secs)); + print $client "$seclist\n"; + } else { + print $client "refused\n"; + } +#----------------------- validate owner of new course section (for auto-enrollment). + } elsif ($userinput =~/^autonewcourse/) { + if (isClient) { + my ($cmd,$course_id,$owner)=split(/:/,$userinput); + my $outcome = &localenroll::new_course($course_id,$owner); + print $client "$outcome\n"; + } else { + print $client "refused\n"; + } +#-------------- validate course section in schedule of classes (for auto-enrollment). + } elsif ($userinput =~/^autovalidatecourse/) { + if (isClient) { + my ($cmd,$course_id)=split(/:/,$userinput); + my $outcome=&localenroll::validate_courseID($course_id); + print $client "$outcome\n"; + } else { + print $client "refused\n"; + } +#--------------------------- create password for new user (for auto-enrollment). + } elsif ($userinput =~/^autocreatepassword/) { + if (isClient) { + my ($cmd,$authparam)=split(/:/,$userinput); + my ($create_passwd,$authchk) = @_; + ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam); + print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n"; + } else { + print $client "refused\n"; + } +#--------------------------- read and remove temporary files (for auto-enrollment). + } elsif ($userinput =~/^autoretrieve/) { + if (isClient) { + my ($cmd,$filename) = split(/:/,$userinput); + my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; + if ( (-e $source) && ($filename ne '') ) { + my $reply = ''; + if (open(my $fh,$source)) { + while (<$fh>) { + chomp($_); + $_ =~ s/^\s+//g; + $_ =~ s/\s+$//g; + $reply .= $_; + } + close($fh); + print $client &escape($reply)."\n"; +# unlink($source); + } else { + print $client "error\n"; + } + } else { + print $client "error\n"; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------- unknown command } else { @@ -2847,14 +3200,14 @@ sub make_new_child { } else { print $client "refused\n"; $client->close(); - &logthis("WARNING: " + &logthis("WARNING: " ."Rejected client $clientip, closing connection"); } } # ============================================================================= - &logthis("CRITICAL: " + &logthis("CRITICAL: " ."Disconnect from $clientip ($clientname)"); @@ -2879,10 +3232,8 @@ sub make_new_child { # sub ManagePermissions { - my $request = shift; - my $domain = shift; - my $user = shift; - my $authtype= shift; + + my ($request, $domain, $user, $authtype) = @_; # See if the request is of the form /$domain/_au if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... @@ -2899,8 +3250,8 @@ sub ManagePermissions # sub GetAuthType { - my $domain = shift; - my $user = shift; + + my ($domain, $user) = @_; Debug("GetAuthType( $domain, $user ) \n"); my $proname = &propath($domain, $user); @@ -3009,17 +3360,36 @@ sub chatadd { sub unsub { my ($fname,$clientip)=@_; my $result; + my $unsubs = 0; # Number of successful unsubscribes: + + + # An old way subscriptions were handled was to have a + # subscription marker file: + + Debug("Attempting unlink of $fname.$clientname"); if (unlink("$fname.$clientname")) { - $result="ok\n"; - } else { - $result="not_subscribed\n"; - } + $unsubs++; # Successful unsub via marker file. + } + + # The more modern way to do it is to have a subscription list + # file: + if (-e "$fname.subscription") { my $found=&addline($fname,$clientname,$clientip,''); - if ($found) { $result="ok\n"; } + if ($found) { + $unsubs++; + } + } + + # If either or both of these mechanisms succeeded in unsubscribing a + # resource we can return ok: + + if($unsubs) { + $result = "ok\n"; } else { - if ($result != "ok\n") { $result="not_subscribed\n"; } + $result = "not_subscribed\n"; } + return $result; } @@ -3183,7 +3553,7 @@ sub sethost { my (undef,$hostid)=split(/:/,$remotereq); if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { - $currenthostid=$hostid; + $currenthostid =$hostid; $currentdomainid=$hostdom{$hostid}; &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); } else { @@ -3223,6 +3593,7 @@ sub userload { return $userloadpercent; } + # ----------------------------------- POD (plain old documentation, CPAN style) =head1 NAME 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.