Annotation of loncom/auth/lonauth.pm, revision 1.121.2.24.2.1

1.1       albertel    1: # The LearningOnline Network
                      2: # User Authentication Module
1.27      www         3: #
1.121.2.24.2.  (raeburn    4:): # $Id: lonauth.pm,v 1.121.2.24 2021/12/30 05:11:28 raeburn Exp $
1.27      www         5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.1       albertel   28: 
                     29: package Apache::lonauth;
                     30: 
1.18      albertel   31: use strict;
1.121.2.24.2.  (raeburn   32:): use LONCAPA qw(:DEFAULT :match);
1.1       albertel   33: use Apache::Constants qw(:common);
                     34: use CGI qw(:standard);
1.45      matthew    35: use Apache::loncommon();
1.66      albertel   36: use Apache::lonnet;
1.12      www        37: use Apache::lonmenu();
1.90      raeburn    38: use Apache::createaccount;
1.18      albertel   39: use Fcntl qw(:flock);
1.56      www        40: use Apache::lonlocal;
1.119     raeburn    41: use Apache::File();
1.101     raeburn    42: use HTML::Entities;
1.121.2.18  raeburn    43: use Digest::MD5;
1.121.2.24  raeburn    44: use CGI::Cookie();
1.85      albertel   45:  
1.1       albertel   46: # ------------------------------------------------------------ Successful login
1.85      albertel   47: sub success {
                     48:     my ($r, $username, $domain, $authhost, $lowerurl, $extra_env,
1.121.2.22  raeburn    49: 	$form,$cid,$expirepub) = @_;
1.1       albertel   50: 
1.85      albertel   51: # ------------------------------------------------------------ Get cookie ready
                     52:     my $cookie =
                     53: 	&Apache::loncommon::init_user_environment($r, $username, $domain,
                     54: 						  $authhost, $form,
1.86      albertel   55: 						  {'extra_env' => $extra_env,});
1.4       www        56: 
1.69      albertel   57:     my $public=($username eq 'public' && $domain eq 'public');
                     58: 
1.85      albertel   59:     if ($public or $lowerurl eq 'noredirect') { return $cookie; }
1.78      albertel   60: 
1.7       www        61: # -------------------------------------------------------------------- Log this
                     62: 
1.121.2.21  raeburn    63:     my $ip = &Apache::lonnet::get_requestor_ip();
1.7       www        64:     &Apache::lonnet::log($domain,$username,$authhost,
1.121.2.21  raeburn    65:                          "Login $ip");
1.4       www        66: 
1.14      www        67: # ------------------------------------------------- Check for critical messages
                     68: 
1.21      www        69:     my @what=&Apache::lonnet::dump('critical',$domain,$username);
1.14      www        70:     if ($what[0]) {
1.22      www        71: 	if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) {
1.21      www        72: 	    $lowerurl='/adm/email?critical=display';
1.14      www        73:         }
                     74:     }
                     75: 
1.121.2.18  raeburn    76: # ------------------------------------------------------------ Get cookies ready
                     77:     my ($securecookie,$defaultcookie);
                     78:     my $ssl = $r->subprocess_env('https');
                     79:     if ($ssl) {
                     80:         $securecookie="lonSID=$cookie; path=/; HttpOnly; secure";
                     81:         my $lonidsdir=$r->dir_config('lonIDsDir');
                     82:         if (($lonidsdir) && (-e "$lonidsdir/$cookie.id")) {
                     83:             my $linkname=substr(Digest::MD5::md5_hex(Digest::MD5::md5_hex(time(). {}. rand(). $$)), 0, 32).'_linked';
                     84:             if (-e "$lonidsdir/$linkname.id") {
                     85:                 unlink("$lonidsdir/$linkname.id");
                     86:             }
                     87:             my $made_symlink = eval { symlink("$lonidsdir/$cookie.id",
                     88:                                               "$lonidsdir/$linkname.id"); 1 };
                     89:             if ($made_symlink) {
                     90:                 $defaultcookie = "lonLinkID=$linkname; path=/; HttpOnly;";
                     91:                 &Apache::lonnet::appenv({'user.linkedenv' => $linkname});
                     92:             }
                     93:         }
                     94:     } else {
                     95:         $defaultcookie = "lonID=$cookie; path=/; HttpOnly;";
                     96:     }
1.12      www        97: # -------------------------------------------------------- Menu script and info
1.100     raeburn    98:     my $destination = $lowerurl;
                     99: 
                    100:     if (defined($form->{role})) {
                    101:         my $envkey = 'user.role.'.$form->{role};
                    102:         my $now=time;
                    103:         my $then=$env{'user.login.time'};
                    104:         my $refresh=$env{'user.refresh.time'};
1.111     raeburn   105:         my $update=$env{'user.update.time'};
                    106:         if (!$update) {
                    107:             $update = $then;
                    108:         }
1.100     raeburn   109:         if (exists($env{$envkey})) {
                    110:             my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus);
1.111     raeburn   111:             &Apache::lonnet::role_status($envkey,$update,$refresh,$now,\$role,\$where,
1.100     raeburn   112:                                          \$trolecode,\$tstatus,\$tstart,\$tend);
                    113:             if ($tstatus eq 'is') {
1.101     raeburn   114:                 $destination  .= ($destination =~ /\?/) ? '&' : '?';
                    115:                 my $newrole = &HTML::Entities::encode($form->{role},'"<>&');
                    116:                 $destination .= 'selectrole=1&'.$newrole.'=1';
1.100     raeburn   117:             }
                    118:         }
                    119:     }
1.101     raeburn   120:     if (defined($form->{symb})) {
                    121:         my $destsymb = $form->{symb};
1.121.2.19  raeburn   122:         my $encrypted;
                    123:         if ($destsymb =~ m{^/enc/}) {
                    124:             $encrypted = 1;
                    125:             if ($cid) {
                    126:                 $destsymb = &Apache::lonenc::unencrypted($destsymb,$cid);
                    127:             }
                    128:         }
1.101     raeburn   129:         $destination  .= ($destination =~ /\?/) ? '&' : '?';
                    130:         if ($destsymb =~ /___/) {
                    131:             my ($map,$resid,$desturl)=split(/___/,$destsymb);
1.121.2.13  raeburn   132:             $desturl = &Apache::lonnet::clutter($desturl);
1.121.2.19  raeburn   133:             if ($encrypted) {
                    134:                 $desturl = &Apache::lonenc::encrypted($desturl,1,$cid);
                    135:                 $destsymb = $form->{symb};
                    136:             }
1.101     raeburn   137:             $desturl = &HTML::Entities::encode($desturl,'"<>&');
                    138:             $destsymb = &HTML::Entities::encode($destsymb,'"<>&');
1.121.2.8  raeburn   139:             $destination .= 'destinationurl='.$desturl.
1.101     raeburn   140:                             '&destsymb='.$destsymb;
1.121.2.19  raeburn   141:         } elsif (!$encrypted) {
1.101     raeburn   142:             $destsymb = &HTML::Entities::encode($destsymb,'"<>&');
1.121.2.8  raeburn   143:             $destination .= 'destinationurl='.$destsymb;
1.101     raeburn   144:         }
                    145:     }
1.111     raeburn   146:     if ($destination =~ m{^/adm/roles}) {
                    147:         $destination  .= ($destination =~ /\?/) ? '&' : '?';
                    148:         $destination .= 'source=login';
                    149:     }
1.100     raeburn   150: 
1.121.2.24.2.  (raeburn  151:):     if (($env{'request.deeplink.login'} eq $lowerurl) &&
                    152:):         (($env{'request.linkprot'}) || ($env{'request.linkkey'} ne ''))) {
                    153:):         my %info;
                    154:):         if ($env{'request.linkprot'}) {
                    155:):             $info{'linkprot'} = $env{'request.linkprot'};
                    156:):         } elsif ($env{'request.linkkey'} ne '') {
                    157:):             $info{'linkkey'} = $env{'request.linkkey'};
                    158:):         }
                    159:):         $info{'origurl'} = $lowerurl;
                    160:):         my $token = &Apache::lonnet::tmpput(\%info,$r->dir_config('lonHostID'),'link');
                    161:):         unless (($token eq 'con_lost') || ($token eq 'refused') ||
                    162:):                 ($token eq 'unknown_cmd') || ($token eq 'no_such_host')) {
                    163:):             $destination .= (($destination =~ /\?/) ? '&' : '?') . 'ttoken='.$token;
                    164:):         }
                    165:):     }
                    166:): 
1.121.2.1  raeburn   167:     my $windowinfo=&Apache::lonmenu::open($env{'browser.os'});
                    168:     my $startupremote=&Apache::lonmenu::startupremote($destination);
                    169:     my $remoteinfo=&Apache::lonmenu::load_remote_msg($lowerurl);
                    170:     my $setflags=&Apache::lonmenu::setflags();
                    171:     my $maincall=&Apache::lonmenu::maincall();
1.99      bisitz    172:     my $brcrum = [{'href' => '',
                    173:                    'text' => 'Successful Login'},];
1.74      albertel  174:     my $start_page=&Apache::loncommon::start_page('Successful Login',
1.121.2.1  raeburn   175:                                                   $startupremote,
                    176:                                                   {'no_inline_link' => 1,
                    177:                                                    'bread_crumbs' => $brcrum,});
1.74      albertel  178:     my $end_page  =&Apache::loncommon::end_page();
                    179: 
1.121.2.1  raeburn   180:     my $continuelink;
                    181:     if ($env{'environment.remote'} eq 'off') {
                    182: 	$continuelink='<a href="'.$destination.'">'.&mt('Continue').'</a>';
                    183:     }
1.5       www       184: # ------------------------------------------------- Output for successful login
                    185: 
1.74      albertel  186:     &Apache::loncommon::content_type($r,'text/html');
1.121.2.18  raeburn   187:     if ($securecookie) {
                    188:         $r->headers_out->add('Set-cookie' => $securecookie);
                    189:     }
                    190:     if ($defaultcookie) {
                    191:         $r->headers_out->add('Set-cookie' => $defaultcookie);
                    192:     }
1.121.2.22  raeburn   193:     if ($expirepub) {
                    194:         my $c = new CGI::Cookie(-name    => 'lonPubID',
                    195:                                 -value   => '',
                    196:                                 -expires => '-10y',);
                    197:         $r->headers_out->add('Set-cookie' => $c);
                    198:     }
1.74      albertel  199:     $r->send_http_header;
1.1       albertel  200: 
1.58      www       201:     my %lt=&Apache::lonlocal::texthash(
                    202: 				       'wel' => 'Welcome',
1.92      bisitz    203: 				       'pro' => 'Login problems?',
1.58      www       204: 				       );
1.121.2.2  raeburn   205:     my $loginhelp = &loginhelpdisplay($domain);
                    206:     if ($loginhelp) {
                    207:         $loginhelp = '<p><a href="'.$loginhelp.'">'.$lt{'pro'}.'</a></p>';
                    208:     }
                    209: 
1.112     raeburn   210:     my $welcome = &mt('Welcome to the Learning[_1]Online[_2] Network with CAPA. Please wait while your session is being set up.','<i>','</i>'); 
1.1       albertel  211:     $r->print(<<ENDSUCCESS);
1.74      albertel  212: $start_page
1.121.2.1  raeburn   213: $setflags
1.19      www       214: $windowinfo
1.58      www       215: <h1>$lt{'wel'}</h1>
1.121.2.2  raeburn   216: $welcome
                    217: $loginhelp
1.121.2.1  raeburn   218: $remoteinfo
                    219: $maincall
1.64      albertel  220: $continuelink
1.74      albertel  221: $end_page
1.1       albertel  222: ENDSUCCESS
1.121.2.11  raeburn   223:     return;
1.1       albertel  224: }
                    225: 
                    226: # --------------------------------------------------------------- Failed login!
                    227: 
                    228: sub failed {
1.121.2.22  raeburn   229:     my ($r,$message,$form,$authhost) = @_;
1.121.2.7  raeburn   230:     (undef,undef,undef,my $clientmathml,my $clientunicode) =
                    231:         &Apache::loncommon::decode_user_agent();
                    232:     my $args = {};
                    233:     if ($clientunicode && !$clientmathml) {
                    234:         $args = {'browser.unicode' => 1};
                    235:     }
                    236: 
                    237:     my $start_page = &Apache::loncommon::start_page('Unsuccessful Login',undef,$args);
                    238:     my $uname = &Apache::loncommon::cleanup_html($form->{'uname'});
                    239:     my $udom = &Apache::loncommon::cleanup_html($form->{'udom'});
                    240:     if (&Apache::lonnet::domain($udom,'description') eq '') {
                    241:         undef($udom);
                    242:     }
                    243:     my $retry = '/adm/login';
                    244:     if ($uname eq $form->{'uname'}) {
                    245:         $retry .= '?username='.$uname;
                    246:     }
                    247:     if ($udom) {
                    248:         $retry .= (($retry=~/\?/)?'&amp;':'?').'domain='.$udom;
                    249:     }
1.121.2.22  raeburn   250:     my $lonhost = $r->dir_config('lonHostID');
                    251:     my $querystr;
                    252:     my $result = &set_retry_token($form,$lonhost,\$querystr);
                    253:     if ($result eq 'fail') {
                    254:         if (exists($form->{role})) {
                    255:             my $role = &Apache::loncommon::cleanup_html($form->{role});
                    256:             if ($role ne '') {
                    257:                 $retry .= (($retry=~/\?/)?'&amp;':'?').'role='.$role;
                    258:             }
                    259:         }
                    260:         if (exists($form->{symb})) {
                    261:             my $symb = &Apache::loncommon::cleanup_html($form->{symb});
                    262:             if ($symb ne '') {
                    263:                 $retry .= (($retry=~/\?/)?'&amp;':'?').'symb='.$symb;
                    264:             }
                    265:         }
                    266:         if (exists($form->{firsturl})) {
                    267:             my $firsturl = &Apache::loncommon::cleanup_html($form->{firsturl});
                    268:             if ($firsturl ne '') {
                    269:                 $retry .= (($retry=~/\?/)?'&amp;':'?').'firsturl='.$firsturl;
1.121.2.24.2.  (raeburn  270:):                 if ($form->{firsturl} =~ m{^/tiny/$match_domain/\w+$}) {
                    271:):                     unless (exists($form->{linkprot})) {
                    272:):                         if (exists($form->{linkkey})) {
                    273:):                             $retry .= 'linkkey='.$form->{linkkey};
                    274:):                         }
                    275:):                     }
                    276:):                 }
                    277:):             }
                    278:):         }
                    279:):         if (exists($form->{linkprot})) {
                    280:):             my $ltoken = &Apache::lonnet::tmpput({linkprot => $form->{'linkprot'}},
                    281:):                                                  $r->dir_config('lonHostID'),'retry');
                    282:):             if ($ltoken) {
                    283:):                 $retry .= (($retry =~ /\?/) ? '&' : '?').'ltoken='.$ltoken;
1.121.2.22  raeburn   284:             }
1.121.2.7  raeburn   285:         }
1.121.2.22  raeburn   286:     } elsif ($querystr ne '') {
                    287:         $retry .= (($retry=~/\?/)?'&amp;':'?').$querystr;
1.100     raeburn   288:     }
1.121.2.7  raeburn   289:     my $end_page = &Apache::loncommon::end_page();
1.74      albertel  290:     &Apache::loncommon::content_type($r,'text/html');
                    291:     $r->send_http_header;
1.121.2.9  raeburn   292:     my @actions =
                    293:          (&mt('Please [_1]log in again[_2].','<a href="'.$retry.'">','</a>'));
1.121.2.7  raeburn   294:     my $loginhelp = &loginhelpdisplay($udom);
1.121.2.2  raeburn   295:     if ($loginhelp) {
1.121.2.9  raeburn   296:         push(@actions, '<a href="'.$loginhelp.'">'.&mt('Login problems?').'</a>');
1.121.2.2  raeburn   297:     }
1.121.2.9  raeburn   298:     #FIXME: link to helpdesk might be added here
1.121.2.2  raeburn   299: 
1.92      bisitz    300:     $r->print(
                    301:        $start_page
1.121.2.9  raeburn   302:       .'<h2>'.&mt('Sorry ...').'</h2>'
                    303:       .&Apache::lonhtmlcommon::confirm_success(&mt($message),1).'<br /><br />'
                    304:       .&Apache::lonhtmlcommon::actionbox(\@actions)
1.92      bisitz    305:       .$end_page
                    306:     );
                    307:  }
1.60      www       308: 
1.55      www       309: # ------------------------------------------------------------------ Rerouting!
                    310: 
                    311: sub reroute {
1.74      albertel  312:     my ($r) = @_;
                    313:     &Apache::loncommon::content_type($r,'text/html');
                    314:     $r->send_http_header;
1.121.2.5  raeburn   315:     my $msg='<b>'.&mt('Sorry ...').'</b><br />'
1.92      bisitz    316:            .&mt('Please [_1]log in again[_2].');
1.121.2.5  raeburn   317:     &Apache::loncommon::simple_error_page($r,'Rerouting',$msg,{'no_auto_mt_msg' => 1});
1.55      www       318: }
                    319: 
1.1       albertel  320: # ---------------------------------------------------------------- Main handler
                    321: 
                    322: sub handler {
                    323:     my $r = shift;
1.120     raeburn   324:     my $londocroot = $r->dir_config('lonDocRoot');
1.55      www       325: # Are we re-routing?
1.120     raeburn   326:     if (-e "$londocroot/lon-status/reroute.txt") {
1.55      www       327: 	&reroute($r);
                    328: 	return OK;
                    329:     }
1.56      www       330: 
1.57      www       331:     &Apache::lonlocal::get_language_handle($r);
1.1       albertel  332: 
1.59      www       333: # -------------------------------- Prevent users from attempting to login twice
1.89      albertel  334:     my $handle = &Apache::lonnet::check_for_valid_session($r);
                    335:     if ($handle ne '') {
1.103     raeburn   336:         my $lonidsdir=$r->dir_config('lonIDsDir');
                    337:         if ($handle=~/^publicuser\_/) {
                    338: # For "public user" - remove it, we apparently really want to login
                    339:             unlink($r->dir_config('lonIDsDir')."/$handle.id");
                    340:         } else {
1.59      www       341: # Indeed, a valid token is found
1.103     raeburn   342:             &Apache::lonnet::transfer_profile_to_env($lonidsdir,$handle);
                    343: 	    &Apache::loncommon::content_type($r,'text/html');
                    344: 	    $r->send_http_header;
                    345: 	    my $start_page = 
                    346: 	        &Apache::loncommon::start_page('Already logged in');
                    347: 	    my $end_page = 
                    348: 	        &Apache::loncommon::end_page();
1.105     raeburn   349:             my $dest = '/adm/roles';
1.121.2.22  raeburn   350:             my %form = &get_form_items($r);
                    351:             if ($form{'logtoken'}) {
                    352:                 my $tmpinfo = &Apache::lonnet::reply('tmpget:'.$form{'logtoken'},
                    353:                                                      $form{'serverid'});
                    354:                 unless (($tmpinfo=~/^error/) || ($tmpinfo eq 'con_lost') ||
                    355:                         ($tmpinfo eq 'no_such_host')) {
1.121.2.23  raeburn   356:                     my ($des_key,$firsturl,@rest)=split(/&/,$tmpinfo);
1.121.2.22  raeburn   357:                     $firsturl = &unescape($firsturl);
                    358:                     my %info;
                    359:                     foreach my $item (@rest) {
                    360:                         my ($key,$value) = split(/=/,$item);
                    361:                         $info{$key} = &unescape($value);
                    362:                     }
                    363:                     if ($firsturl ne '') {
                    364:                         $info{'firsturl'} = $firsturl;
                    365:                         $dest = $firsturl;
1.121.2.24.2.  (raeburn  366:):                         my $relogin;
                    367:):                         if ($dest =~ m{^/tiny/$match_domain/\w+$}) {
                    368:):                             if ($env{'request.course.id'}) {
                    369:):                                 my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                    370:):                                 my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                    371:):                                 my $symb = &Apache::loncommon::symb_from_tinyurl($dest,$cnum,$cdom);
                    372:):                                 if ($symb) {
                    373:):                                     unless (&set_deeplink_login(%info) eq 'ok') {
                    374:):                                         $relogin = 1;
                    375:):                                     }
                    376:):                                 }
                    377:):                             }
                    378:):                             if ($relogin) {
                    379:):                                 $r->print(
                    380:):                                       $start_page
                    381:):                                      .'<p class="LC_warning">'.&mt('You are already logged in!').'</p>'
                    382:):                                      .'<p>'.&mt('Please [_1]log out[_2] first, and then try your access again',
                    383:):                                                 '<a href="/adm/logout">','</a>')
                    384:):                                      .'</p>'
                    385:):                                      .$end_page);
                    386:):                             } else {
                    387:):                                 if (($info{'linkprot'}) || ($info{'linkkey'} ne '')) {
                    388:):                                     my $token = &Apache::lonnet::tmpput(\%info,$r->dir_config('lonHostID'),'link');
                    389:):                                     unless (($token eq 'con_lost') || ($token eq 'refused') ||
                    390:):                                             ($token eq 'unknown_cmd') || ($token eq 'no_such_host')) {
                    391:):                                         $dest .= (($dest =~ /\?/) ? '&' : '?') . 'ttoken='.$token;
                    392:):                                     }
                    393:):                                 }
                    394:):                                 $r->print(
                    395:):                                       $start_page
                    396:):                                      .'<p class="LC_warning">'.&mt('You are already logged in!').'</p>'
                    397:):                                      .'<p>'.&mt('Please either [_1]continue the current session[_2] or [_3]log out[_4] first, and then try your access again',
                    398:):                                                 '<a href="'.$dest.'">','</a>',
                    399:):                                                 '<a href="/adm/logout">','</a>')
                    400:):                                      .'</p>'
                    401:):                                      .$end_page);
                    402:):                             }
                    403:):                             return OK;
                    404:):                         }
1.121.2.22  raeburn   405:                     }
                    406:                 }
1.105     raeburn   407:             }
1.103     raeburn   408:             $r->print(
                    409:                $start_page
1.121.2.4  raeburn   410:               .'<p class="LC_warning">'.&mt('You are already logged in!').'</p>'
1.103     raeburn   411:               .'<p>'.&mt('Please either [_1]continue the current session[_2] or [_3]log out[_4].'
1.105     raeburn   412:                     ,'<a href="'.$dest.'">','</a>','<a href="/adm/logout">','</a>')
1.103     raeburn   413:               .'</p>'
                    414:               .$end_page
                    415:             );
                    416:             return OK;
                    417:         }
1.59      www       418:     }
                    419: 
                    420: # ---------------------------------------------------- No valid token, continue
                    421: 
1.121.2.22  raeburn   422:     my %form = &get_form_items($r);
1.85      albertel  423:     if ((!$form{'uname'}) || (!$form{'upass0'}) || (!$form{'udom'})) {
                    424: 	&failed($r,'Username, password and domain need to be specified.',
                    425: 		\%form);
1.1       albertel  426:         return OK;
                    427:     }
1.61      www       428: 
                    429: # split user logging in and "su"-user
                    430: 
1.121.2.17  raeburn   431:     ($form{'uname'},$form{'suname'},$form{'sudom'})=split(/\:/,$form{'uname'});
1.87      albertel  432:     $form{'uname'} = &LONCAPA::clean_username($form{'uname'});
                    433:     $form{'suname'}= &LONCAPA::clean_username($form{'suname'});
1.121.2.17  raeburn   434:     $form{'udom'}  = &LONCAPA::clean_domain($form{'udom'});
                    435:     $form{'sudom'} = &LONCAPA::clean_domain($form{'sudom'});
1.1       albertel  436: 
                    437:     my $role   = $r->dir_config('lonRole');
                    438:     my $domain = $r->dir_config('lonDefDomain');
                    439:     my $prodir = $r->dir_config('lonUsersDir');
1.93      raeburn   440:     my $contact_name = &mt('LON-CAPA helpdesk');
1.1       albertel  441: 
1.8       www       442: # ---------------------------------------- Get the information from login token
                    443: 
1.85      albertel  444:     my $tmpinfo=Apache::lonnet::reply('tmpget:'.$form{'logtoken'},
                    445:                                       $form{'serverid'});
1.121.2.7  raeburn   446: 
1.114     raeburn   447:     if (($tmpinfo=~/^error/) || ($tmpinfo eq 'con_lost') || 
                    448:         ($tmpinfo eq 'no_such_host')) {
1.85      albertel  449: 	&failed($r,'Information needed to verify your login information is missing, inaccessible or expired.',\%form);
1.8       www       450:         return OK;
1.44      www       451:     } else {
1.85      albertel  452: 	my $reply = &Apache::lonnet::reply('tmpdel:'.$form{'logtoken'},
                    453: 					   $form{'serverid'});
1.77      albertel  454:         if ( $reply ne 'ok' ) {
1.85      albertel  455:             &failed($r,'Session could not be opened.',\%form);
                    456: 	    &Apache::lonnet::logthis("ERROR got a reply of $reply when trying to contact ". $form{'serverid'}." to get login token");
1.77      albertel  457: 	    return OK;
1.44      www       458: 	}
1.8       www       459:     }
1.100     raeburn   460: 
1.93      raeburn   461:     if (!&Apache::lonnet::domain($form{'udom'})) {
                    462:         &failed($r,'The domain you provided is not a valid LON-CAPA domain.',\%form);
                    463:         return OK;
                    464:     }
1.100     raeburn   465: 
1.121.2.22  raeburn   466:     my ($des_key,$firsturl,@rest)=split(/&/,$tmpinfo);
                    467:     $firsturl = &unescape($firsturl);
                    468:     foreach my $item (@rest) {
                    469:         my ($key,$value) = split(/=/,$item);
                    470:         $form{$key} = &unescape($value);
1.100     raeburn   471:     }
1.121.2.24.2.  (raeburn  472:):     if ($firsturl =~ m{^/tiny/$match_domain/\w+$}) {
                    473:):         $form{'firsturl'} = $firsturl;
                    474:):     }
1.121.2.23  raeburn   475:     my $upass = &Apache::loncommon::des_decrypt($des_key,$form{'upass0'});
1.8       www       476: 
1.1       albertel  477: # ---------------------------------------------------------------- Authenticate
1.119     raeburn   478: 
1.90      raeburn   479:     my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$form{'udom'});
1.119     raeburn   480:     my ($cancreate,$statustocreate) =
                    481:         &Apache::createaccount::get_creation_controls($form{'udom'},$domconfig{'usercreation'});
                    482:     my $defaultauth;
                    483:     if (ref($cancreate) eq 'ARRAY') {
                    484:         if (grep(/^login$/,@{$cancreate})) {
                    485:             $defaultauth = 1;
1.90      raeburn   486:         }
                    487:     }
1.105     raeburn   488:     my $clientcancheckhost = 1;
1.90      raeburn   489:     my $authhost=Apache::lonnet::authenticate($form{'uname'},$upass,
1.105     raeburn   490:                                               $form{'udom'},$defaultauth,
                    491:                                               $clientcancheckhost);
1.1       albertel  492:     
                    493: # --------------------------------------------------------------------- Failed?
                    494: 
                    495:     if ($authhost eq 'no_host') {
1.85      albertel  496: 	&failed($r,'Username and/or password could not be authenticated.',
                    497: 		\%form);
1.1       albertel  498:         return OK;
1.90      raeburn   499:     } elsif ($authhost eq 'no_account_on_host') {
1.119     raeburn   500:         if ($defaultauth) {
1.105     raeburn   501:             my $domdesc = &Apache::lonnet::domain($form{'udom'},'description');
1.110     raeburn   502:             unless (&check_can_host($r,\%form,'no_account_on_host',$domdesc)) {
                    503:                 return OK;
                    504:             }
1.90      raeburn   505:             my $start_page = 
1.121.2.1  raeburn   506:                 &Apache::loncommon::start_page('Create a user account in LON-CAPA',
                    507:                                                '',{'no_inline_link'   => 1,});
1.93      raeburn   508:             my $lonhost = $r->dir_config('lonHostID');
                    509:             my $origmail = $Apache::lonnet::perlvar{'lonSupportEMail'};
                    510:             my $contacts = 
                    511:                 &Apache::loncommon::build_recipient_list(undef,'helpdeskmail',
                    512:                                                         $form{'udom'},$origmail);
                    513:             my ($contact_email) = split(',',$contacts); 
1.119     raeburn   514:             my $output = 
                    515:                 &Apache::createaccount::username_check($form{'uname'},$form{'udom'},
                    516:                                                        $domdesc,'',$lonhost,
                    517:                                                        $contact_email,$contact_name,
                    518:                                                        undef,$statustocreate);
1.90      raeburn   519:             &Apache::loncommon::content_type($r,'text/html');
                    520:             $r->send_http_header;
                    521:             &Apache::createaccount::print_header($r,$start_page);
1.94      raeburn   522:             $r->print('<h3>'.&mt('Account creation').'</h3>'.
                    523:                       &mt('Although your username and password were authenticated, you do not currently have a LON-CAPA account at this institution.').'<br />'.
                    524:                       $output.&Apache::loncommon::end_page());
1.90      raeburn   525:             return OK;
                    526:         } else {
                    527:             &failed($r,'Although your username and password were authenticated, you do not currently have a LON-CAPA account in this domain, and you are not permitted to create one.',\%form);
                    528:             return OK;
                    529:         }
1.1       albertel  530:     }
                    531: 
1.59      www       532:     if (($firsturl eq '') || 
                    533: 	($firsturl=~/^\/adm\/(logout|remote)/)) {
1.24      www       534: 	$firsturl='/adm/roles';
1.7       www       535:     }
1.121.2.6  raeburn   536: 
1.121.2.23  raeburn   537:     my ($hosthere,%sessiondata);
1.121.2.6  raeburn   538:     if ($form{'iptoken'}) {
1.121.2.23  raeburn   539:         %sessiondata = &Apache::lonnet::tmpget($form{'iptoken'});
1.121.2.12  raeburn   540:         my $delete = &Apache::lonnet::tmpdel($form{'iptoken'});
1.121.2.6  raeburn   541:         if (($sessiondata{'domain'} eq $form{'udom'}) &&
                    542:             ($sessiondata{'username'} eq $form{'uname'})) {
                    543:             $hosthere = 1;
                    544:         }
                    545:     }
                    546: 
1.61      www       547: # --------------------------------- Are we attempting to login as somebody else?
1.85      albertel  548:     if ($form{'suname'}) {
1.121.2.17  raeburn   549:         my ($suname,$sudom,$sudomref);
                    550:         $suname = $form{'suname'};
                    551:         $sudom = $form{'udom'};
                    552:         if ($form{'sudom'}) {
                    553:             unless ($sudom eq $form{'sudom'}) {
                    554:                 if (&Apache::lonnet::domain($form{'sudom'})) {
                    555:                     $sudomref = [$form{'sudom'}];
                    556:                     $sudom = $form{'sudom'};
                    557:                 }
                    558:             }
                    559:         }
1.61      www       560: # ------------ see if the original user has enough privileges to pull this stunt
1.121.2.17  raeburn   561: 	if (&Apache::lonnet::privileged($form{'uname'},$form{'udom'},$sudomref)) {
1.61      www       562: # ---------------------------------------------------- see if the su-user exists
1.121.2.17  raeburn   563: 	    unless (&Apache::lonnet::homeserver($suname,$sudom) eq 'no_host') {
1.61      www       564: # ------------------------------ see if the su-user is not too highly privileged
1.121.2.17  raeburn   565: 		if (&Apache::lonnet::privileged($suname,$sudom)) {
                    566:                     &Apache::lonnet::logthis('Attempted switch user to privileged user');
                    567:                 } else {
                    568:                     my $noprivswitch;
                    569: #
                    570: # su-user's home server and user's home server must have one of:
                    571: # (a) same domain
                    572: # (b) same primary library server for the two domains
                    573: # (c) same "internet domain" for primary library server(s) for home servers' domains
                    574: #
                    575:                     my $suprim = &Apache::lonnet::domain($sudom,'primary');
                    576:                     my $suintdom = &Apache::lonnet::internet_dom($suprim);
                    577:                     unless ($sudom eq $form{'udom'}) {
                    578:                         my $uprim = &Apache::lonnet::domain($form{'udom'},'primary');
                    579:                         my $uintdom = &Apache::lonnet::internet_dom($uprim);
                    580:                         unless ($suprim eq $uprim) {
                    581:                             unless ($suintdom eq $uintdom) {
                    582:                                 &Apache::lonnet::logthis('Attempted switch user '
                    583:                                    .'to user with different "internet domain".');
                    584:                                 $noprivswitch = 1;
                    585:                             }
                    586:                         }
                    587:                     }
                    588: 
                    589:                     unless ($noprivswitch) {
                    590: #
                    591: # server where log-in occurs must have same "internet domain" as su-user's home
                    592: # server
                    593: #
                    594:                         my $lonhost = $r->dir_config('lonHostID');
                    595:                         my $hostintdom = &Apache::lonnet::internet_dom($lonhost);
                    596:                         if ($hostintdom ne $suintdom) {
                    597:                             &Apache::lonnet::logthis('Attempted switch user on a '
                    598:                                 .'server with a different "internet domain".');
                    599:                         } else {
                    600: 
1.61      www       601: # -------------------------------------------------------- actually switch users
1.121.2.17  raeburn   602: 
                    603: 			    &Apache::lonnet::logperm('User '.$form{'uname'}.' at '.
                    604: 				$form{'udom'}.' logging in as '.$suname.':'.$sudom);
                    605: 			    $form{'uname'}=$suname;
                    606:                             if ($form{'udom'} ne $sudom) {
                    607:                                 $form{'udom'}=$sudom;
                    608:                             }
                    609:                         }
                    610:                     }
1.61      www       611: 		}
                    612: 	    }
                    613: 	} else {
                    614: 	    &Apache::lonnet::logthis('Non-privileged user attempting switch user');
                    615: 	}
                    616:     }
1.85      albertel  617: 
1.121.2.6  raeburn   618:     my ($is_balancer,$otherserver);
                    619: 
                    620:     unless ($hosthere) {
                    621:         ($is_balancer,$otherserver) =
1.121.2.15  raeburn   622:             &Apache::lonnet::check_loadbalancing($form{'uname'},$form{'udom'},'login');
                    623:         if ($is_balancer) {
1.121.2.20  raeburn   624:             # Check if browser sent a LON-CAPA load balancer cookie (and this is a balancer)
                    625:             my ($found_server,$balancer_cookie) = &Apache::lonnet::check_for_balancer_cookie($r);
                    626:             if (($found_server) && ($balancer_cookie =~ /^\Q$env{'user.domain'}\E_\Q$env{'user.name'}\E_/)) {
                    627:                 $otherserver = $found_server;
                    628:             }
1.121.2.15  raeburn   629:             if ($otherserver eq '') {
                    630:                 my $lowest_load;
                    631:                 ($otherserver,undef,undef,undef,$lowest_load) = &Apache::lonnet::choose_server($form{'udom'});
                    632:                 if ($lowest_load > 100) {
1.121.2.22  raeburn   633:                     $otherserver = &Apache::lonnet::spareserver($r,$lowest_load,$lowest_load,1,$form{'udom'});
1.121.2.15  raeburn   634:                 }
                    635:             }
                    636:             if ($otherserver ne '') {
                    637:                 my @hosts = &Apache::lonnet::current_machine_ids();
                    638:                 if (grep(/^\Q$otherserver\E$/,@hosts)) {
                    639:                     $hosthere = $otherserver;
                    640:                 }
                    641:             }
                    642:         }
1.121.2.6  raeburn   643:     }
1.117     raeburn   644: 
1.121.2.15  raeburn   645:     if (($is_balancer) && (!$hosthere)) {
1.115     raeburn   646:         if ($otherserver) {
                    647:             &success($r,$form{'uname'},$form{'udom'},$authhost,'noredirect',undef,
                    648:                      \%form);
1.121.2.8  raeburn   649:             my $switchto = '/adm/switchserver?otherserver='.$otherserver;
                    650:             if (($firsturl) && ($firsturl ne '/adm/switchserver') && ($firsturl ne '/adm/roles')) {
                    651:                 $switchto .= '&origurl='.$firsturl;
                    652:             }
                    653:             if ($form{'role'}) {
                    654:                 $switchto .= '&role='.$form{'role'};
                    655:             }
                    656:             if ($form{'symb'}) {
                    657:                 $switchto .= '&symb='.$form{'symb'};
                    658:             }
1.121.2.24.2.  (raeburn  659:):             if ($form{'linkprot'}) {
                    660:):                 $env{'request.linkprot'} = $form{'linkprot'};
                    661:):             } elsif ($form{'linkkey'} ne '') {
                    662:):                 $env{'request.linkkey'} = $form{'linkkey'};
                    663:):             }
                    664:):             if ($form{'firsturl'} =~ m{^/tiny/$match_domain/\w+$}) {
                    665:):                 &set_deeplink_login(%form);
                    666:):             }
1.121.2.8  raeburn   667:             $r->internal_redirect($switchto);
1.115     raeburn   668:         } else {
1.121.2.20  raeburn   669:             &Apache::loncommon::content_type($r,'text/html');
                    670:             $r->send_http_header;
1.115     raeburn   671:             $r->print(&noswitch());
                    672:         }
1.110     raeburn   673:         return OK;
1.81      albertel  674:     } else {
1.115     raeburn   675:         if (!&check_can_host($r,\%form,$authhost)) {
1.118     raeburn   676:             my ($otherserver) = &Apache::lonnet::choose_server($form{'udom'});
1.115     raeburn   677:             if ($otherserver) {
                    678:                 &success($r,$form{'uname'},$form{'udom'},$authhost,'noredirect',undef,
                    679:                          \%form);
1.121.2.8  raeburn   680:                 my $switchto = '/adm/switchserver?otherserver='.$otherserver;
                    681:                 if (($firsturl) && ($firsturl ne '/adm/switchserver') && ($firsturl ne '/adm/roles')) {
                    682:                     $switchto .= '&origurl='.$firsturl;
                    683:                 }
                    684:                 if ($form{'role'}) {
                    685:                     $switchto .= '&role='.$form{'role'};
                    686:                 }
                    687:                 if ($form{'symb'}) {
                    688:                     $switchto .= '&symb='.$form{'symb'};
                    689:                 }
1.121.2.24.2.  (raeburn  690:):                 if ($form{'linkprot'}) {
                    691:):                     $env{'request.linkprot'} = $form{'linkprot'};
                    692:):                 } elsif ($form{'linkkey'} ne '') {
                    693:):                     $env{'request.linkkey'} = $form{'linkkey'};
                    694:):                 }
                    695:):                 if ($form{'firsturl'} =~ m{^/tiny/$match_domain/\w+$}) {
                    696:):                     &set_deeplink_login(%form);
                    697:):                 }
1.121.2.8  raeburn   698:                 $r->internal_redirect($switchto);
1.115     raeburn   699:             } else {
1.121.2.20  raeburn   700:                 &Apache::loncommon::content_type($r,'text/html');
                    701:                 $r->send_http_header;
1.115     raeburn   702:                 $r->print(&noswitch());
                    703:             }
                    704:             return OK;
                    705:         }
                    706: 
1.109     raeburn   707: # ------------------------------------------------------- Do the load balancing
                    708: 
                    709: # ---------------------------------------------------------- Determine own load
                    710:         my $loadlim = $r->dir_config('lonLoadLim');
                    711:         my $loadavg;
                    712:         {
                    713:             my $loadfile=Apache::File->new('/proc/loadavg');
                    714:             $loadavg=<$loadfile>;
                    715:         }
                    716:         $loadavg =~ s/\s.*//g;
                    717:         my $loadpercent=sprintf("%.1f",100*$loadavg/$loadlim);
                    718:         my $userloadpercent=&Apache::lonnet::userload();
                    719: 
                    720: # ---------------------------------------------------------- Are we overloaded?
                    721:         if ((($userloadpercent>100.0)||($loadpercent>100.0))) {
1.121.2.22  raeburn   722:             my $unloaded=Apache::lonnet::spareserver($r,$loadpercent,$userloadpercent,1,$form{'udom'});
1.115     raeburn   723:             if (!$unloaded) {
1.118     raeburn   724:                 ($unloaded) = &Apache::lonnet::choose_server($form{'udom'});
1.115     raeburn   725:             }
1.109     raeburn   726:             if ($unloaded) {
                    727:                 &success($r,$form{'uname'},$form{'udom'},$authhost,'noredirect',
                    728:                          undef,\%form);
1.121.2.24.2.  (raeburn  729:):                 if ($form{'linkprot'}) {
                    730:):                     $env{'request.linkprot'} = $form{'linkprot'};
                    731:):                 } elsif ($form{'linkkey'} ne '') {
                    732:):                     $env{'request.linkkey'} = $form{'linkkey'};
                    733:):                 }
                    734:):                 if ($form{'firsturl'} =~ m{^/tiny/$match_domain/\w+$}) {
                    735:):                     &set_deeplink_login(%form);
                    736:):                 }
1.109     raeburn   737:                 $r->internal_redirect('/adm/switchserver?otherserver='.$unloaded.'&origurl='.$firsturl);
1.110     raeburn   738:                 return OK;
1.109     raeburn   739:             }
                    740:         }
1.121.2.15  raeburn   741:         if (($is_balancer) && ($hosthere)) {
                    742:             $form{'noloadbalance'} = $hosthere;
                    743:         }
1.121.2.22  raeburn   744:         my $extra_env;
                    745:         if (($hosthere) && ($sessiondata{'sessionserver'} ne '')) {
                    746:             if ($sessiondata{'origurl'} ne '') {
                    747:                 $firsturl = $sessiondata{'origurl'};
                    748:                 $form{'firsturl'} = $sessiondata{'origurl'};
                    749:                 my @names = ('role','symb','linkprot','linkkey');
                    750:                 foreach my $item (@names) {
                    751:                     if ($sessiondata{$item} ne '') {
                    752:                         $form{$item} = $sessiondata{$item};
                    753:                     }
                    754:                 }
                    755:             }
                    756:         }
1.121.2.24.2.  (raeburn  757:):         if ($form{'linkprot'}) {
                    758:):             my ($linkprotector,$uri) = split(/:/,$form{'linkprot'},2);
                    759:):             if ($linkprotector) {
                    760:):                 $extra_env = {'user.linkprotector' => $linkprotector,
                    761:):                               'user.linkproturi'   => $uri};
                    762:):             }
                    763:):         } elsif ($form{'linkkey'} ne '') {
                    764:):             $extra_env = {'user.deeplinkkey'  => $form{'linkkey'},
                    765:):                           'user.keyedlinkuri' => $form{'firsturl'}};
                    766:):         }
                    767:):         if ($form{'firsturl'} =~ m{^/tiny/$match_domain/\w+$}) {
                    768:):             &set_deeplink_login(%form);
                    769:):             if ($form{'linkprot'}) {
                    770:):                 if (ref($extra_env) eq 'HASH') {
                    771:):                     %{$extra_env} = ( %{$extra_env}, 'request.linkprot' => $form{'linkprot'} );
                    772:):                 } else {
                    773:):                     $extra_env = {'request.linkprot' => $form{'linkprot'}};
                    774:):                 }
                    775:):             } elsif ($form{'linkkey'} ne '') {
                    776:):                 if (ref($extra_env) eq 'HASH') {
                    777:):                     %{$extra_env} = ( %{$extra_env}, 'request.linkkey' => $form{'linkkey'} );
                    778:):                 } else {
                    779:):                     $extra_env = {'request.linkkey' => $form{'linkkey'}};
                    780:):                 }
                    781:):             }
                    782:):             if ($env{'request.deeplink.login'}) {
                    783:):                 if (ref($extra_env) eq 'HASH') {
                    784:):                     %{$extra_env} = ( %{$extra_env}, 'request.deeplink.login' => $form{'firsturl'} );
                    785:):                 } else {
                    786:):                     $extra_env = {'request.deeplink.login' => $form{'firsturl'}};
                    787:):                 }
                    788:):             }
                    789:):         }
                    790:):         &success($r,$form{'uname'},$form{'udom'},$authhost,$firsturl,$extra_env,
1.109     raeburn   791:                  \%form);
1.110     raeburn   792:         return OK;
1.81      albertel  793:     }
1.1       albertel  794: }
                    795: 
1.121.2.22  raeburn   796: sub get_form_items {
                    797:     my ($r) = @_;
                    798:     my $buffer;
                    799:     if ($r->header_in('Content-length') > 0) {
                    800:         $r->read($buffer,$r->header_in('Content-length'),0);
                    801:     }
                    802:     my %form;
                    803:     foreach my $pair (split(/&/,$buffer)) {
                    804:        my ($name,$value) = split(/=/,$pair);
                    805:        $value =~ tr/+/ /;
                    806:        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    807:        $form{$name}=$value;
                    808:     }
                    809:     return %form;
                    810: }
                    811: 
1.121.2.24.2.  (raeburn  812:): sub set_deeplink_login {
                    813:):     my (%form) = @_;
                    814:):     my $disallow;
                    815:):     if ($form{'firsturl'} =~ m{^/tiny/($match_domain)/\w+$}) {
                    816:):         my $cdom = $1;
                    817:):         my ($cnum,$symb) = &Apache::loncommon::symb_from_tinyurl($form{'firsturl'},'',$cdom);
                    818:):         if ($symb) {
                    819:):             if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
                    820:):                 my $deeplink;
                    821:):                 if ($symb =~ /\.(page|sequence)$/) {
                    822:):                     my $mapname = &Apache::lonnet::deversion((&Apache::lonnet::decode_symb($symb))[2]);
                    823:):                     my $navmap = Apache::lonnavmaps::navmap->new();
                    824:):                     if (ref($navmap)) {
                    825:):                         $deeplink = $navmap->get_mapparam(undef,$mapname,'0.deeplink');
                    826:):                     }
                    827:):                 } else {
                    828:):                     $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$symb);
                    829:):                 }
                    830:):                 if ($deeplink ne '') {
                    831:):                     my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
                    832:):                     if (($protect ne 'none') && ($protect ne '')) {
                    833:):                         my ($acctype,$item) = split(/:/,$protect);
                    834:):                         if ($acctype =~ /lti(c|d)$/) {
                    835:):                             unless ($form{'linkprot'} eq $item.$1.':'.$env{'request.deeplink.login'}) {
                    836:):                                 $disallow = 1;
                    837:):                             }
                    838:):                         } elsif ($acctype eq 'key') {
                    839:):                             unless ($form{'linkkey'} eq $item) {
                    840:):                                 $disallow = 1;
                    841:):                             }
                    842:):                         }
                    843:):                     }
                    844:):                 }
                    845:):                 unless ($disallow) {
                    846:):                     $env{'request.deeplink.login'} = $form{'firsturl'};
                    847:):                 }
                    848:):             } else {
                    849:):                 $env{'request.deeplink.login'} = $form{'firsturl'};
                    850:):             }
                    851:):         }
                    852:):     }
                    853:):     if ($disallow) {
                    854:):         return;
                    855:):     }
                    856:):     return 'ok';
                    857:): }
                    858:): 
1.121.2.22  raeburn   859: sub set_retry_token {
                    860:     my ($form,$lonhost,$querystr) = @_;
                    861:     if (ref($form) eq 'HASH') {
                    862:         my ($firsturl,$token,$extras,@names);
1.121.2.24.2.  (raeburn  863:):         @names = ('role','symb','linkprot','linkkey','iptoken');
1.121.2.22  raeburn   864:         foreach my $name (@names) {
                    865:             if ($form->{$name} ne '') {
                    866:                 $extras .= '&'.$name.'='.&escape($form->{$name});
                    867:                 last if ($name eq 'linkprot');
                    868:             }
                    869:         }
                    870:         my $firsturl = $form->{'firsturl'};
                    871:         if (($firsturl ne '') || ($extras ne '')) {
                    872:             $extras .= ':retry';
                    873:             $token = &Apache::lonnet::reply('tmpput:'.&escape($firsturl).
                    874:                                             $extras,$lonhost);
                    875:             if (($token eq 'con_lost') || ($token eq 'no_such_host')) {
                    876:                 return 'fail';
                    877:             } else {
                    878:                 if (ref($querystr)) {
                    879:                     $$querystr = 'retry='.$token;
                    880:                 }
                    881:                 return 'ok';
                    882:             }
                    883:         }
                    884:     }
                    885:     return;
                    886: }
                    887: 
1.105     raeburn   888: sub check_can_host {
                    889:     my ($r,$form,$authhost,$domdesc) = @_;
                    890:     return unless (ref($form) eq 'HASH');
                    891:     my $canhost = 1;
1.106     raeburn   892:     my $lonhost = $r->dir_config('lonHostID');
1.105     raeburn   893:     my $udom = $form->{'udom'};
1.108     raeburn   894:     my @intdoms;
                    895:     my $internet_names = &Apache::lonnet::get_internet_names($lonhost);
                    896:     if (ref($internet_names) eq 'ARRAY') {
                    897:         @intdoms = @{$internet_names};
                    898:     }
1.106     raeburn   899:     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
                    900:     my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
                    901:     unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
                    902:         my $machine_dom = &Apache::lonnet::host_domain($lonhost);
                    903:         my $hostname = &Apache::lonnet::hostname($lonhost);
                    904:         my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
                    905:         my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
                    906:         my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
1.105     raeburn   907:         my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
                    908:         my $loncaparev;
                    909:         if ($authhost eq 'no_account_on_host') {
1.106     raeburn   910:             $loncaparev = &Apache::lonnet::get_server_loncaparev($machine_dom);
1.105     raeburn   911:         } else {
1.106     raeburn   912:             $loncaparev = &Apache::lonnet::get_server_loncaparev($machine_dom,$lonhost);
1.105     raeburn   913:         }
1.106     raeburn   914:         $canhost = &Apache::lonnet::can_host_session($udom,$lonhost,$loncaparev,
                    915:                                                      $udomdefaults{'remotesessions'},
                    916:                                                      $defdomdefaults{'hostedsessions'});
1.105     raeburn   917:     }
                    918:     unless ($canhost) {
                    919:         if ($authhost eq 'no_account_on_host') {
1.115     raeburn   920:             my $checkloginvia = 1;
                    921:             my ($login_host,$hostname) = 
                    922:                 &Apache::lonnet::choose_server($udom,$checkloginvia);
1.105     raeburn   923:             &Apache::loncommon::content_type($r,'text/html');
                    924:             $r->send_http_header;
                    925:             if ($login_host ne '') {
                    926:                 my $protocol = $Apache::lonnet::protocol{$login_host};
                    927:                 $protocol = 'http' if ($protocol ne 'https');
1.121.2.22  raeburn   928:                 my $alias = &Apache::lonnet::use_proxy_alias($r,$login_host);
                    929:                 $hostname = $alias if ($alias ne '');
1.105     raeburn   930:                 my $newurl = $protocol.'://'.$hostname.'/adm/createaccount';
1.121.2.24.2.  (raeburn  931:): #FIXME Should preserve where user was going and linkprot by setting ltoken at $login_host
1.105     raeburn   932:                 $r->print(&Apache::loncommon::start_page('Create a user account in LON-CAPA').
                    933:                           '<h3>'.&mt('Account creation').'</h3>'.
                    934:                           &mt('You do not currently have a LON-CAPA account at this institution.').'<br />'.
                    935:                           '<p>'.&mt('You will be able to create one by logging into a LON-CAPA server within the [_1] domain.',$domdesc).'</p>'.
                    936:                           '<p>'.&mt('[_1]Log in[_2]','<a href="'.$newurl.'">','</a>').
                    937:                           &Apache::loncommon::end_page());
                    938:             } else {
                    939:                 $r->print(&Apache::loncommon::start_page('Access to LON-CAPA unavailable').
                    940:                           '<h3>'.&mt('Account creation unavailable').'</h3>'.
                    941:                           &mt('You do not currently have a LON-CAPA account at this institution.').'<br />'.
                    942:                           '<p>'.&mt('Currently a LON-CAPA server is not available within the [_1] domain for you to log-in to, to create an account.',$domdesc).'</p>'.
                    943:                           &Apache::loncommon::end_page());
                    944:             }
                    945:         } else {
                    946:             &success($r,$form->{'uname'},$udom,$authhost,'noredirect',undef,
                    947:                      $form);
1.121.2.24.2.  (raeburn  948:):             if ($form->{'firsturl'} =~ m{^/tiny/$match_domain/\w+$}) {
                    949:):                 $env{'request.deeplink.login'} = $form->{'firsturl'};
                    950:):             }
                    951:):             if ($form->{'linkprot'}) {
                    952:):                 $env{'request.linkprot'} = $form->{'linkprot'};
                    953:):             } elsif ($form->{'linkkey'} ne '') {
                    954:):                 $env{'request.linkkey'} = $form->{'linkkey'};
                    955:):             }
1.107     raeburn   956:             my ($otherserver) = &Apache::lonnet::choose_server($udom);
1.105     raeburn   957:             $r->internal_redirect('/adm/switchserver?otherserver='.$otherserver);
                    958:         }
                    959:     }
1.110     raeburn   960:     return $canhost;
1.105     raeburn   961: }
                    962: 
1.115     raeburn   963: sub noswitch {
                    964:     my $result = &Apache::loncommon::start_page('Access to LON-CAPA unavailable').
                    965:                  '<h3>'.&mt('Session unavailable').'</h3>'.
                    966:                  &mt('This LON-CAPA server is unable to host your session.').'<br />'.
                    967:                  '<p>'.&mt('Currently no other LON-CAPA server is available to host your session either.').'</p>'.
                    968:                  &Apache::loncommon::end_page();
                    969:     return $result;
                    970: }
                    971: 
1.121.2.2  raeburn   972: sub loginhelpdisplay {
                    973:     my ($authdomain) = @_;
                    974:     my $login_help = 1;
                    975:     my $lang = &Apache::lonlocal::current_language();
                    976:     if ($login_help) {
                    977:         my $dom = $authdomain;
                    978:         if ($dom eq '') {
                    979:             $dom = &Apache::lonnet::default_login_domain();
                    980:         }
                    981:         my %domconfhash = &Apache::loncommon::get_domainconf($dom);
                    982:         my $loginhelp_url;
                    983:         if ($lang) {
                    984:             $loginhelp_url = $domconfhash{$dom.'.login.helpurl_'.$lang};
                    985:             if ($loginhelp_url ne '') {
                    986:                 return $loginhelp_url;
                    987:             }
                    988:         }
                    989:         $loginhelp_url = $domconfhash{$dom.'.login.helpurl_nolang'};
                    990:         if ($loginhelp_url ne '') {
                    991:             return $loginhelp_url;
                    992:         } else {
                    993:             return '/adm/loginproblems.html';
                    994:         }
                    995:     }
                    996:     return;
                    997: }
                    998: 
1.1       albertel  999: 1;
                   1000: __END__
1.7       www      1001: 
                   1002: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>