--- loncom/lond	2011/09/02 13:10:38	1.446.2.2
+++ loncom/lond	2010/07/17 20:01:56	1.447
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # lond "LON Daemon" Server (port "LOND" 5663)
 #
-# $Id: lond,v 1.446.2.2 2011/09/02 13:10:38 raeburn Exp $
+# $Id: lond,v 1.447 2010/07/17 20:01:56 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -58,7 +58,7 @@ my $DEBUG = 0;		       # Non zero to ena
 my $status='';
 my $lastlog='';
 
-my $VERSION='$Revision: 1.446.2.2 $'; #' stupid emacs
+my $VERSION='$Revision: 1.447 $'; #' stupid emacs
 my $remoteVERSION;
 my $currenthostid="default";
 my $currentdomainid;
@@ -67,6 +67,7 @@ my $client;
 my $clientip;			# IP address of client.
 my $clientname;			# LonCAPA name of client.
 my $clientversion;              # LonCAPA version running on client
+my @clientdoms;                 # Array of domains on $clientip
 
 my $server;
 
@@ -1765,15 +1766,37 @@ sub authenticate_handler {
     #  upass   - User's password.
     #  checkdefauth - Pass to validate_user() to try authentication
     #                 with default auth type(s) if no user account.
+    #  clientcancheckhost - Passed by clients with functionality in lonauth.pm
+    #                       to check if session can be hosted.
     
-    my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
+    my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
     &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");
     chomp($upass);
     $upass=&unescape($upass);
 
     my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
     if($pwdcorrect) {
-	&Reply( $client, "authorized\n", $userinput);
+        my $canhost = 1;
+        unless ($clientcancheckhost) {
+            unless (grep(/^\Q$udom\E$/,@clientdoms)) {
+                my ($remote,$hosted);
+                my $remotesession = &get_usersession_config($udom,'remotesession');
+                if (ref($remotesession) eq 'HASH') {
+                    $remote = $remotesession->{'remote'}
+                }
+                my $hostedsession = &get_usersession_config($clientdoms[0],'hostedsession');
+                if (ref($hostedsession) eq 'HASH') {
+                    $hosted = $hostedsession->{'hosted'};
+                }
+                $canhost = &Apache::lonnet::can_host_session($udom,$currentdomainid,$clientversion,
+                                                             $remote,$hosted);
+            }
+        }
+        if ($canhost) {               
+            &Reply( $client, "authorized\n", $userinput);
+        } else {
+            &Reply( $client, "not_allowed_to_host\n", $userinput);
+        }
 	#
 	#  Bad credentials: Failed to authorize
 	#
@@ -2197,9 +2220,7 @@ sub fetch_user_file_handler {
 
 	my $destname=$udir.'/'.$ufile;
 	my $transname=$udir.'/'.$ufile.'.in.transit';
-        my $clientprotocol=$Apache::lonnet::protocol{$clientname};
-        $clientprotocol = 'http' if ($clientprotocol ne 'https');
-        my $remoteurl=$clientprotocol.'://'.$clientip.'/userfiles/'.$fname;
+	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
 	my $response;
 	Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
 	alarm(120);
@@ -3132,7 +3153,7 @@ sub dump_with_regexp {
                 if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_community)_(cc|co|in|ta|ep|ad|st|cr)}) {
                     my $cdom = $1;
                     my $cnum = $2;
-                    if ($clientversion =~ /^['"]?(\d+)\.(\d+)[.\d\-]+['"]?$/) {
+                    if ($clientversion =~ /^\'?(\d+)\.(\d+)/) {
                         my $major = $1;
                         my $minor = $2;
                         next if (($major < 2) || (($major == 2) && ($minor < 9)));
@@ -6252,6 +6273,7 @@ $SIG{USR2} = \&UpdateHosts;
 
 #  Read the host hashes:
 &Apache::lonnet::load_hosts_tab();
+my %iphost = &Apache::lonnet::get_iphost(1);
 
 my $dist=`$perlvar{'lonDaemons'}/distprobe`;
 
@@ -6312,7 +6334,6 @@ sub make_new_child {
             or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $clientip;
         &status('Started child '.$pid);
-        close($client);
         return;
     } else {
         # Child can *not* return from this subroutine.
@@ -6469,6 +6490,15 @@ sub make_new_child {
 # ------------------------------------------------------------ Process requests
 	    my $keep_going = 1;
 	    my $user_input;
+            @clientdoms = ();
+            if (ref($iphost{$clientip}) eq 'ARRAY') {
+                foreach my $id (@{$iphost{$clientip}}) {
+                    my $clientdom = &Apache::lonnet::host_domain($id);
+                    unless (grep(/^\Q$clientdom\E/,@clientdoms)) {
+                        push(@clientdoms,$clientdom);
+                    }
+                }
+            }
 	    while(($user_input = get_request) && $keep_going) {
 		alarm(120);
 		Debug("Main: Got $user_input\n");
@@ -7041,9 +7071,7 @@ sub subscribe {
                 # the metadata
 		unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
 		$fname=~s/\/home\/httpd\/html\/res/raw/;
-                my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
-                $protocol = 'http' if ($protocol ne 'https');
-                $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
+		$fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
 		$result="$fname\n";
 	    }
 	} else {
@@ -7216,6 +7244,20 @@ sub version {
     return "version:$VERSION";
 }
 
+sub get_usersession_config {
+    my ($dom,$name) = @_;
+    my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
+    if (defined($cached)) {
+        return $usersessionconf;
+    } else {
+        my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
+        if (ref($domconfig{'usersessions'}) eq 'HASH') {
+            &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
+            return $domconfig{'usersessions'};
+        }
+    }
+    return;
+}
 
 # ----------------------------------- POD (plain old documentation, CPAN style)