--- loncom/lond 2010/04/12 19:15:57 1.439 +++ 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.439 2010/04/12 19:15:57 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.439 $'; #' 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; @@ -975,6 +976,9 @@ sub read_profile { &GDBM_READER()); if ($hashref) { my @queries=split(/\&/,$what); + if ($namespace eq 'roles') { + @queries = map { &unescape($_); } @queries; + } my $qresult=''; for (my $i=0;$i<=$#queries;$i++) { @@ -1762,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 # @@ -3124,11 +3150,16 @@ sub dump_with_regexp { my $count=0; while (my ($key,$value) = each(%$hashref)) { if ($namespace eq 'roles') { - if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_(cc|co|in|ta|ep|ad|st|cr)/) { - if ($clientversion =~ /^(\d+)\.(\d+)$/) { + 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+)/) { my $major = $1; my $minor = $2; next if (($major < 2) || (($major == 2) && ($minor < 9))); + } else { + my $homeserver = &Apache::lonnet::homeserver($cnum,$cdom); + next unless ($currenthostid eq $homeserver); } } } @@ -3725,6 +3756,9 @@ sub put_course_id_hash_handler { # createdafter - include courses for which creation date followed this date. # creationcontext - include courses created in specified context # +# domcloner - flag to indicate if user can create CCs in course's domain. +# If so, ability to clone course is automatic. +# # $client - The socket open on the client. # Returns: # 1 - Continue processing. @@ -3737,7 +3771,7 @@ sub dump_course_id_handler { my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter, - $creationcontext) =split(/:/,$tail); + $creationcontext,$domcloner) =split(/:/,$tail); my $now = time; my ($cloneruname,$clonerudom,%cc_clone); if (defined($description)) { @@ -3810,7 +3844,6 @@ sub dump_course_id_handler { } else { $creationcontext = '.'; } - my $unpack = 1; if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && $typefilter eq '.') { @@ -3841,7 +3874,9 @@ sub dump_course_id_handler { next if ($since > 1); } $is_hash = 1; - if (defined($clonerudom)) { + if ($domcloner) { + $canclone = 1; + } elsif (defined($clonerudom)) { if ($items->{'cloners'}) { my @cloneable = split(',',$items->{'cloners'}); if (@cloneable) { @@ -3874,7 +3909,7 @@ sub dump_course_id_handler { if ($items->{'owner'} eq $cloner) { $canclone = 1; } - } elsif ($cloner eq $udom.':'.$items->{'owner'}) { + } elsif ($cloner eq $items->{'owner'}.':'.$udom) { $canclone = 1; } if ($canclone) { @@ -6238,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`; @@ -6390,7 +6426,7 @@ sub make_new_child { my $cipherkey = pack("H32", $key); $cipher = new IDEA($cipherkey); print $client "ok:local\n"; - &logthis('' . "Successful local authentication "); $keymode = "local" } else { @@ -6454,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"); @@ -7184,7 +7229,7 @@ sub sethost { eq &Apache::lonnet::get_host_ip($hostid)) { $currenthostid =$hostid; $currentdomainid=&Apache::lonnet::host_domain($hostid); - &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); +# &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); } else { &logthis("Requested host id $hostid not an alias of ". $perlvar{'lonHostID'}." refusing connection"); @@ -7199,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) @@ -7934,5 +7993,7 @@ string. =back +=back + =cut