Annotation of loncom/lti/ltiauth.pm, revision 1.39

1.1       raeburn     1: # The LearningOnline Network
                      2: # Basic LTI Authentication Module
                      3: #
1.39    ! raeburn     4: # $Id: ltiauth.pm,v 1.38 2022/06/26 04:03:48 raeburn Exp $
1.1       raeburn     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: #
                     28: 
                     29: package Apache::ltiauth;
                     30: 
                     31: use strict;
                     32: use LONCAPA qw(:DEFAULT :match);
1.35      raeburn    33: use Encode;
1.37      raeburn    34: use Apache::Constants qw(:common :http :remotehost);
1.1       raeburn    35: use Apache::lonlocal;
                     36: use Apache::lonnet;
                     37: use Apache::loncommon;
                     38: use Apache::lonacc;
1.6       raeburn    39: use Apache::lonrequestcourse;
1.2       raeburn    40: use LONCAPA::ltiutils;
1.1       raeburn    41: 
                     42: sub handler {
                     43:     my $r = shift;
                     44:     my $requri = $r->uri;
1.20      raeburn    45:     my $hostname = $r->hostname;
1.1       raeburn    46: #
1.9       raeburn    47: # Check for existing session, and temporarily delete any form items
                     48: # in %env, if session exists
                     49: #
                     50:     my %savedform;
                     51:     my $handle = &Apache::lonnet::check_for_valid_session($r);
                     52:     if ($handle ne '') {
                     53:         foreach my $key (sort(keys(%env))) {
                     54:             if ($key =~ /^form\.(.+)$/) {
                     55:                 $savedform{$1} = $env{$key};
                     56:                 delete($env{$key});
                     57:             }
                     58:         }
                     59:     }
                     60: #
1.20      raeburn    61: # Retrieve data POSTed by LTI launch
1.1       raeburn    62: #
                     63:     &Apache::lonacc::get_posted_cgi($r);
                     64:     my $params = {};
                     65:     foreach my $key (sort(keys(%env))) {
                     66:         if ($key =~ /^form\.(.+)$/) {
1.35      raeburn    67:             $params->{$1} = &Encode::decode('UTF-8',$env{$key});
1.1       raeburn    68:         }
                     69:     }
1.9       raeburn    70: #
1.22      raeburn    71: # Check for existing session, and restore temporarily
1.9       raeburn    72: # deleted form items to %env, if session exists.
                     73: #
                     74:     if ($handle ne '') {
                     75:         if (keys(%savedform)) {
                     76:             foreach my $key (sort(keys(%savedform))) {
                     77:                 $env{'form.'.$key} = $savedform{$key};
                     78:             }
                     79:         }
                     80:     }
1.1       raeburn    81: 
                     82:     unless (keys(%{$params})) {
1.32      raeburn    83:         &invalid_request($r,'No parameters included in launch request');
1.1       raeburn    84:         return OK;
                     85:     }
                     86: 
                     87:     unless ($params->{'oauth_consumer_key'} &&
                     88:             $params->{'oauth_nonce'} &&
                     89:             $params->{'oauth_timestamp'} &&
                     90:             $params->{'oauth_version'} &&
                     91:             $params->{'oauth_signature'} &&
                     92:             $params->{'oauth_signature_method'}) {
1.32      raeburn    93:         &invalid_request($r,'One or more required parameters missing from launch request');
1.1       raeburn    94:         return OK;
                     95:     }
                     96: 
                     97: #
                     98: # Retrieve "internet domains" for all this institution's LON-CAPA
                     99: # nodes.
                    100: #
1.20      raeburn   101:     my @intdoms;
1.1       raeburn   102:     my $lonhost = $r->dir_config('lonHostID');
                    103:     my $internet_names = &Apache::lonnet::get_internet_names($lonhost);
                    104:     if (ref($internet_names) eq 'ARRAY') {
                    105:         @intdoms = @{$internet_names};
                    106:     }
1.20      raeburn   107: #
                    108: # Determine course's domain in LON-CAPA
                    109: # for basic launch using key and secret managed
                    110: # in LON-CAPA course (i.e., uri begins /adm/launch)
                    111: #
                    112: 
                    113:    my ($cdom,$cnum);
                    114: 
                    115: # Note: "internet domain" for course's domain must be one of the
                    116: # internet domains for the institution's LON-CAPA servers.
                    117: #
                    118:     if ($requri =~ m{^/adm/launch(|/.*)$}) {
                    119:         my $tail = $1;
1.37      raeburn   120:         if ($tail =~ m{^/tiny/$match_domain/\w+$}) {
1.20      raeburn   121:             my ($urlcdom,$urlcnum) = &course_from_tinyurl($tail);
                    122:             if (($urlcdom ne '') && ($urlcnum ne '')) {
                    123:                 $cdom = $urlcdom;
                    124:                 $cnum = $urlcnum;
                    125:                 my $primary_id = &Apache::lonnet::domain($cdom,'primary');
                    126:                 if ($primary_id ne '') {
                    127:                     my $intdom = &Apache::lonnet::internet_dom($primary_id);
                    128:                     if (($intdom ne '') && (grep(/^\Q$intdom\E$/,@intdoms))) {
                    129: #
                    130: # Verify the signed request using the secret for LTI link
                    131: # protectors for which the key in the POSTed data matches
                    132: # keys in the course configuration.
                    133: #
                    134: # Request is invalid if the signed request could not be verified
                    135: # for the key and secret from LON-CAPA course configuration for
                    136: # LTI link protectors or from LON-CAPA configuration for the
                    137: # course's domain if there are LTI Providers which may be used.
                    138: #
                    139: # Determine if nonce in POSTed data has expired.
                    140: # If unexpired, confirm it has not already been used.
                    141: #
1.30      raeburn   142: # Retrieve information for LTI link protectors in course
                    143: # where url was /adm/launch/tiny/$cdom/$uniqueid
                    144: #
                    145: 
1.37      raeburn   146:                         my ($itemid,$ltitype,%crslti,%lti_in_use,$ltiuser);
1.34      raeburn   147:                         $itemid = &get_lti_itemid($requri,$hostname,$params,$cdom,$cnum,'linkprot');
1.30      raeburn   148:                         if ($itemid) {
1.34      raeburn   149:                             %crslti = &Apache::lonnet::get_course_lti($cnum,$cdom);
1.20      raeburn   150:                         }
                    151:                         if (($itemid) && (ref($crslti{$itemid}) eq 'HASH')) {
                    152:                             $ltitype = 'c';
1.32      raeburn   153:                             if (&LONCAPA::ltiutils::check_nonce($params->{'oauth_nonce'},$params->{'oauth_timestamp'},
                    154:                                                                 $crslti{$itemid}{'lifetime'},$cdom,$r->dir_config('lonLTIDir'))) {
                    155:                                 %lti_in_use = %{$crslti{$itemid}};
                    156:                             } else {
                    157:                                 &invalid_request($r,'Time limit exceeded for launch request credentials');
1.20      raeburn   158:                                 return OK;
                    159:                             }
                    160:                         } else {
1.34      raeburn   161:                             $itemid = &get_lti_itemid($requri,$hostname,$params,$cdom,'','linkprot');
1.30      raeburn   162:                             my %lti;
                    163:                             if ($itemid) {
1.34      raeburn   164:                                 %lti = &Apache::lonnet::get_domain_lti($cdom,'linkprot');
1.20      raeburn   165:                             }
1.30      raeburn   166:                             if (($itemid) && (ref($lti{$itemid}) eq 'HASH')) {
1.20      raeburn   167:                                 $ltitype = 'd';
1.32      raeburn   168:                                 if (&LONCAPA::ltiutils::check_nonce($params->{'oauth_nonce'},$params->{'oauth_timestamp'},
1.30      raeburn   169:                                                                         $lti{$itemid}{'lifetime'},$cdom,
1.20      raeburn   170:                                                                         $r->dir_config('lonLTIDir'))) {
1.32      raeburn   171:                                     %lti_in_use = %{$lti{$itemid}};
                    172:                                 } else {
                    173:                                     &invalid_request($r,'Time limit exceeded for launch request credentials');
1.20      raeburn   174:                                     return OK;
                    175:                                 }
                    176:                             }
                    177:                         }
1.39    ! raeburn   178:                         my $exiturl;
        !           179:                         if (($itemid) && ($lti_in_use{'returnurl'} ne '')) {
        !           180:                             if (exists($params->{$lti_in_use{'returnurl'}})) {
        !           181:                                 $exiturl = $params->{$lti_in_use{'returnurl'}};
        !           182:                             } elsif (exists($params->{'custom_'.$lti_in_use{'returnurl'}})) {
        !           183:                                 $exiturl = $params->{'custom_'.$lti_in_use{'returnurl'}};
        !           184:                             }
        !           185:                         }
1.32      raeburn   186:                         if (($itemid) && ($lti_in_use{'requser'})) {
                    187:                             my %courseinfo = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);
                    188:                             my $ltiauth;
                    189:                             if (exists($courseinfo{'internal.ltiauth'})) {
                    190:                                 $ltiauth = $courseinfo{'internal.ltiauth'};
                    191:                             } else {
                    192:                                 my %domdefs = &Apache::lonnet::get_domain_defaults($cdom);
                    193:                                 $ltiauth = $domdefs{'crsltiauth'};
                    194:                             }
                    195:                             if ($ltiauth) {
                    196:                                 my $possuname;
1.34      raeburn   197:                                 my $mapuser = $lti_in_use{'mapuser'};
1.32      raeburn   198:                                 if ($mapuser eq 'sourcedid') {
                    199:                                     if ($params->{'lis_person_sourcedid'} =~ /^$match_username$/) {
                    200:                                         $possuname = $params->{'lis_person_sourcedid'};
                    201:                                     }
                    202:                                 } elsif ($mapuser eq 'email') {
                    203:                                     if ($params->{'lis_person_contact_email_primary'} =~ /^$match_username$/) {
                    204:                                         $possuname = $params->{'lis_person_contact_email_primary'};
                    205:                                     }
                    206:                                 } elsif (exists($params->{$mapuser})) {
                    207:                                     if ($params->{$mapuser} =~ /^$match_username$/) {
                    208:                                         $possuname = $params->{$mapuser};
                    209:                                     }
                    210:                                 }
                    211:                                 if ($possuname ne '') {
                    212:                                     my $uhome = &Apache::lonnet::homeserver($possuname,$cdom);
                    213:                                     unless ($uhome eq 'no_host') {
                    214:                                         my $uname = $possuname;
                    215:                                         my ($is_student,$is_nonstudent);
                    216:                                         my %course_roles =
                    217:                                             &Apache::lonnet::get_my_roles($uname,$cdom,,'userroles',['active'],
                    218:                                                                           ['cc','co','in','ta','ep','ad','st','cr'],
                    219:                                                                           [$cdom]);
                    220:                                         foreach my $key (keys(%course_roles)) {
                    221:                                             my ($trest,$tdomain,$trole,$sec) = split(/:/,$key);
                    222:                                             if (($trest eq $cnum) && ($tdomain eq $cdom)) {
                    223:                                                 if ($trole eq 'st') {
                    224:                                                     $is_student = 1;
                    225:                                                 } else {
                    226:                                                     $is_nonstudent = 1;
                    227:                                                     last;
                    228:                                                 }
                    229:                                             }
                    230:                                         }
                    231:                                         if (($is_student) && (!$is_nonstudent)) {
                    232:                                             unless (&Apache::lonnet::is_advanced_user($uname,$cdom)) {
                    233:                                                 foreach my $key (%{$params}) {
                    234:                                                     delete($env{'form.'.$key});
                    235:                                                 }
1.39    ! raeburn   236:                                                 &linkprot_session($r,$uname,$cnum,$cdom,$uhome,$itemid,$ltitype,$tail,$lonhost,$exiturl);
1.32      raeburn   237:                                                 return OK;
                    238:                                             }
                    239:                                         }
1.37      raeburn   240:                                         $ltiuser = $uname.':'.$cdom;
1.32      raeburn   241:                                     }
                    242:                                 }
                    243:                                 if ($lti_in_use{'notstudent'} eq 'reject') {
                    244:                                     &invalid_request($r,'Information for valid user missing from launch request');
1.36      raeburn   245:                                     return OK;
1.32      raeburn   246:                                 }
                    247:                             }
                    248:                         }
1.20      raeburn   249:                         if ($itemid) {
                    250:                             foreach my $key (%{$params}) {
                    251:                                 delete($env{'form.'.$key});
                    252:                             }
1.37      raeburn   253:                             my %info = (
                    254:                                           'linkprot' => $itemid.$ltitype.':'.$tail,
                    255:                                        );
                    256:                             if ($ltiuser ne '') {
                    257:                                 $info{'linkprotuser'} = $ltiuser;
                    258:                             }
1.39    ! raeburn   259:                             if ($exiturl ne '') {
        !           260:                                 $info{'linkprotexit'} = $exiturl; 
        !           261:                             }
1.37      raeburn   262:                             my $ltoken = &Apache::lonnet::tmpput(\%info,$lonhost,'link');
                    263:                             if (($ltoken eq 'con_lost') || ($ltoken eq 'refused') || ($ltoken =~ /^error:/) ||
                    264:                                 ($ltoken eq 'unknown_cmd') || ($ltoken eq 'no_such_host') ||
                    265:                                 ($ltoken eq '')) {
                    266:                                 &invalid_request($r,'Failed to store information from launch request');
                    267:                             } else {
1.20      raeburn   268:                                 $r->internal_redirect($tail.'?ltoken='.$ltoken);
                    269:                                 $r->set_handlers('PerlHandler'=> undef);
                    270:                             }
                    271:                         } else {
1.32      raeburn   272:                             &invalid_request($r,'Launch request could not be validated');
1.20      raeburn   273:                         }
                    274:                     } else {
1.32      raeburn   275:                         &invalid_request($r,'Launch unavailable on this LON-CAPA server');
1.20      raeburn   276:                     }
                    277:                 } else {
1.32      raeburn   278:                     &invalid_request($r,'Launch unavailable for this domain');
1.20      raeburn   279:                 }
                    280:             } else {
1.32      raeburn   281:                 &invalid_request($r,'Invalid launch URL');
1.20      raeburn   282:             }
                    283:         } else {
1.32      raeburn   284:             &invalid_request($r,'Invalid launch URL');
1.20      raeburn   285:         }
                    286:         return OK;
                    287:     }
                    288: 
                    289:     my ($udom,$uname,$uhome,$symb,$mapurl);
1.1       raeburn   290: 
                    291: #
                    292: # For user who launched LTI in Consumer, determine user's domain in 
                    293: # LON-CAPA.
                    294: #
                    295: # Order is:
                    296: #
                    297: # (a) from custom_userdomain item in POSTed data
                    298: # (b) from lis_person_sourcedid in POSTed data
                    299: # (c) from default "log-in" domain for node
                    300: #     (can support multidomain servers, where specific domain is 
                    301: #      first part of hostname).
                    302: #
                    303: # Note: "internet domain" for user's domain must be one of the
                    304: # "internet domain(s)" for the institution's LON-CAPA servers.
                    305: #
                    306:     if (exists($params->{'custom_userdomain'})) {
                    307:         if ($params->{'custom_userdomain'} =~ /^$match_domain$/) {
                    308:             my $uprimary_id = &Apache::lonnet::domain($params->{'custom_userdomain'},'primary');
                    309:             if ($uprimary_id ne '') {
                    310:                 my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
                    311:                 if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) {
                    312:                     $udom = $params->{'custom_userdomain'};
                    313:                 }
                    314:             }
                    315:         }
                    316:     }
                    317:     my $defdom = &Apache::lonnet::default_login_domain();
                    318:     my ($domain,$possuname,$possudom,$possmapuser);
                    319:     if ($env{'form.lis_person_sourcedid'} =~ /^($match_username)\:($match_domain)$/) {
                    320:         ($possuname,$possudom) = ($1,$2);
                    321:         if ($udom eq '') {
                    322:             my $uintdom = &Apache::lonnet::domain($possudom,'primary');
                    323:             if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) {
                    324:                 $udom = $possudom;
                    325:                 $possmapuser = 'lis_person_sourcedid';
                    326:             } else {
                    327:                 $udom = $defdom;
                    328:             }
                    329:         } elsif ($udom eq $possudom) {
                    330:             $possmapuser = 'lis_person_sourcedid';
                    331:         }
                    332:     }
                    333:     unless ($possuname) {
                    334:         if ($env{'form.lis_person_sourcedid'} =~ /^$match_username$/) {
                    335:             $possuname = $env{'form.lis_person_sourcedid'};
                    336:             $possmapuser = 'lis_person_sourcedid';
                    337:         } elsif ($env{'form.lis_person_contact_email_primary'} =~ /^$match_username$/) {
                    338:             $possuname = $env{'form.lis_person_contact_email_primary'};
                    339:             $possmapuser = 'lis_person_contact_email_primary';
                    340:         }
                    341:         unless ($udom) {
                    342:             $udom = $defdom;
                    343:         }
                    344:     }
                    345: 
                    346: #
                    347: # Determine course's domain in LON-CAPA
                    348: #
                    349: # Order is:
                    350: #
                    351: # (a) from custom_coursedomain item in POSTed data
1.9       raeburn   352: # (b) from tail of requested URL (after /adm/lti/) if it has format of a symb  
1.1       raeburn   353: # (c) from tail of requested URL (after /adm/lti) if it has format of a map 
                    354: # (d) from tail of requested URL (after /adm/lti) if it has format /domain/courseID
1.5       raeburn   355: # (e) from tail of requested URL (after /adm/lti) if it has format /tiny/domain/\w+
                    356: #     i.e., a shortened URL (see bug #6400).
1.1       raeburn   357: # (f) same as user's domain 
                    358: #
                    359: # Request invalid if custom_coursedomain is defined and is inconsistent with
                    360: # domain contained in requested URL.
                    361: #
                    362: # Note: "internet domain" for course's domain must be one of the
                    363: # internet domains for the institution's LON-CAPA servers.
                    364: #
                    365: 
                    366:     if (exists($params->{'custom_coursedomain'})) {
                    367:         if ($params->{'custom_coursedomain'} =~ /^$match_domain$/) {
                    368:             my $cprimary_id = &Apache::lonnet::domain($params->{'custom_coursedomain'},'primary');
                    369:             if ($cprimary_id ne '') {
                    370:                 my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);
                    371:                 if (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {
                    372:                     $cdom = $params->{'custom_coursedomain'};
                    373:                 }
                    374:             }
                    375:         }
                    376:     }
                    377: 
                    378:     my ($tail) = ($requri =~ m{^/adm/lti(|/.*)$});
                    379:     my $urlcnum;
                    380:     if ($tail ne '') {
                    381:         my $urlcdom;
                    382:         if ($tail =~ m{^/uploaded/($match_domain)/($match_courseid)/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {
                    383:             ($urlcdom,$urlcnum,my $rest) = ($1,$2,$3);
                    384:             if (($cdom ne '') && ($cdom ne $urlcdom)) {
1.32      raeburn   385:                 &invalid_request($r,'Incorrect domain in requested URL');
1.1       raeburn   386:                 return OK;
                    387:             }
                    388:             if ($rest eq '') {
                    389:                 $mapurl = $tail;
                    390:             } else {
                    391:                 $symb = $tail;
1.16      raeburn   392:                 $symb =~ s{^/}{};
1.1       raeburn   393:             }
1.9       raeburn   394:         } elsif ($tail =~ m{^/res/(?:$match_domain)/(?:$match_username)/.+\.(?:sequence|page)(|___\d+___.+)$}) {
                    395:             if ($1 eq '') {
                    396:                 $mapurl = $tail;
                    397:             } else {
                    398:                 $symb = $tail;
1.16      raeburn   399:                 $symb =~ s{^/res/}{};
1.9       raeburn   400:             }
1.1       raeburn   401:         } elsif ($tail =~ m{^/($match_domain)/($match_courseid)$}) {
                    402:             ($urlcdom,$urlcnum) = ($1,$2);
                    403:             if (($cdom ne '') && ($cdom ne $urlcdom)) {
1.32      raeburn   404:                 &invalid_request($r,'Incorrect domain in requested URL');
1.1       raeburn   405:                 return OK;
                    406:             }
1.5       raeburn   407:         } elsif ($tail =~ m{^/tiny/($match_domain)/(\w+)$}) {
1.20      raeburn   408:             ($urlcdom,$urlcnum) = &course_from_tinyurl($tail);
                    409:             if (($urlcdom eq '') || ($urlcnum eq '')) {
1.32      raeburn   410:                 &invalid_request($r,'Invalid URL shortcut');
1.5       raeburn   411:                 return OK;
                    412:             }
1.1       raeburn   413:         }
                    414:         if (($cdom eq '') && ($urlcdom ne '')) { 
                    415:             my $cprimary_id = &Apache::lonnet::domain($urlcdom,'primary');
                    416:             if ($cprimary_id ne '') {
                    417:                 my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);
                    418:                 if (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {
                    419:                     $cdom = $urlcdom;
                    420:                 }
                    421:             } else {
                    422:                 $urlcnum = '';
                    423:             }
                    424:         }
                    425:     }
                    426:     if ($cdom eq '') {
                    427:         if ($udom ne '') {
                    428:             $cdom = $udom;
                    429:         } else {
                    430:             $cdom = $defdom;
                    431:         }
                    432:     }
                    433: 
                    434: #
1.20      raeburn   435: # Retrieve information for LTI Consumers in course's domain
1.30      raeburn   436: # defined in domain configuration for LTI.
1.1       raeburn   437: #
                    438: # Verify the signed request using the secret for those
1.30      raeburn   439: # Consumers for which the key in the POSTed data matches
1.20      raeburn   440: # keys in the course configuration or the domain configuration
                    441: # for LTI.
1.1       raeburn   442: #
                    443: 
1.30      raeburn   444:     my %lti;
                    445:     my $itemid = &get_lti_itemid($requri,$hostname,$params,$cdom);
                    446:     if ($itemid) {
                    447:         %lti = &Apache::lonnet::get_domain_lti($cdom,'provider');
                    448:     }
1.1       raeburn   449: 
                    450: #
                    451: # Request is invalid if the signed request could not be verified
                    452: # for the Consumer key and Consumer secret from the domain
                    453: # configuration in LON-CAPA for that LTI Consumer.
                    454: #
                    455:     unless (($itemid) && (ref($lti{$itemid}) eq 'HASH')) {
1.32      raeburn   456:         &invalid_request($r,'Launch request could not be validated');
1.1       raeburn   457:         return OK;
                    458:     }
                    459: 
                    460: #
                    461: # Determine if nonce in POSTed data has expired.
                    462: # If unexpired, confirm it has not already been used.
                    463: #
1.2       raeburn   464:     unless (&LONCAPA::ltiutils::check_nonce($params->{'oauth_nonce'},$params->{'oauth_timestamp'},
                    465:                                             $lti{$itemid}{'lifetime'},$cdom,$r->dir_config('lonLTIDir'))) {
1.32      raeburn   466:         &invalid_request($r,'Time limit exceeded for launch request credentials');
1.1       raeburn   467:         return OK;
                    468:     }
                    469: 
                    470: #
1.17      raeburn   471: # Determine if a username is required from the domain
                    472: # configuration for the specific LTI Consumer
                    473: #
                    474: 
                    475:     if (!$lti{$itemid}{'requser'}) {
                    476:         if ($tail =~ m{^/tiny/($match_domain)/(\w+)$}) {
1.20      raeburn   477:             my $ltitype = 'd';
1.17      raeburn   478:             foreach my $key (%{$params}) {
                    479:                 delete($env{'form.'.$key});
                    480:             }
1.20      raeburn   481:             my $ltoken = &Apache::lonnet::tmpput({'linkprot' => $itemid.$ltitype.':'.$tail},
1.17      raeburn   482:                                                    $lonhost);
                    483:             if ($ltoken) {
                    484:                 $r->internal_redirect($tail.'?ltoken='.$ltoken);
                    485:                 $r->set_handlers('PerlHandler'=> undef);
                    486:             } else {
1.32      raeburn   487:                 &invalid_request($r,'Failed to store information from launch request');
1.17      raeburn   488:             }
                    489:         } else {
1.32      raeburn   490:             &invalid_request($r,'Launch URL invalid for matched launch credentials');
1.17      raeburn   491:         }
                    492:         return OK;
                    493:     }
                    494: 
                    495: #
1.6       raeburn   496: # Determine if source of username matches requirement from the 
1.1       raeburn   497: # domain configuration for the specific LTI Consumer.
                    498: # 
                    499: 
                    500:     if ($lti{$itemid}{'mapuser'} eq $possmapuser) {
                    501:         $uname = $possuname;
                    502:     } elsif ($lti{$itemid}{'mapuser'} eq 'lis_person_sourcedid') {
                    503:         if ($params->{'lis_person_sourcedid'} =~ /^$match_username$/) {
                    504:             $uname = $possuname;
                    505:         }
                    506:     } elsif ($lti{$itemid}{'mapuser'} eq 'lis_person_contact_email_primary') {
                    507:         if ($params->{'lis_person_contact_email_primary'} =~ /^$match_username$/) {
                    508:             $uname = $params->{'lis_person_contact_email_primary'};
                    509:         }
                    510:     } elsif (exists($params->{$lti{$itemid}{'mapuser'}})) {
                    511:         if ($params->{$lti{$itemid}{'mapuser'}} =~ /^$match_username$/) {
                    512:             $uname = $params->{$lti{$itemid}{'mapuser'}};
                    513:         }
                    514:     }
                    515: 
                    516: #
                    517: # Determine the courseID of the LON-CAPA course to which the
                    518: # launch of LON-CAPA should provide access.
                    519: #
                    520: # Order is:
                    521: #
                    522: # (a) from course mapping (if the link between Consumer "course" and 
                    523: # Provider "course" has been established previously).
1.9       raeburn   524: # (b) from tail of requested URL (after /adm/lti/) if it has format of a symb
1.1       raeburn   525: # (c) from tail of requested URL (after /adm/lti) if it has format of a map
                    526: # (d) from tail of requested URL (after /adm/lti) if it has format /domain/courseID
1.5       raeburn   527: # (e) from tail of requested URL (after /adm/lti) if it has format /tiny/domain/\w+
                    528: #     i.e., a shortened URL (see bug #6400).
1.1       raeburn   529: #
                    530: # If Consumer course included in POSTed data points as a target course which
                    531: # has a format which matches a LON-CAPA courseID, but the course does not
                    532: # exist, the request is invalid.
                    533: # 
                    534: 
                    535:     my ($sourcecrs,%consumers);
                    536:     if ($lti{$itemid}{'mapcrs'} eq 'course_offering_sourcedid') {
                    537:         $sourcecrs = $params->{'course_offering_sourcedid'};
                    538:     } elsif ($lti{$itemid}{'mapcrs'} eq 'context_id') {
                    539:         $sourcecrs = $params->{'context_id'};
                    540:     } elsif ($lti{$itemid}{'mapcrs'} ne '') {
                    541:         $sourcecrs = $params->{$lti{$itemid}{'mapcrs'}};
                    542:     }
                    543: 
                    544:     my $posscnum;
                    545:     if ($sourcecrs ne '') {
                    546:         %consumers = &Apache::lonnet::get_dom('lticonsumers',[$sourcecrs],$cdom);
                    547:         if (exists($consumers{$sourcecrs})) {
1.28      raeburn   548:             if ($consumers{$sourcecrs} =~ /^\Q$itemid:\E($match_courseid)$/) {
1.29      raeburn   549:                 my $storedcnum = $1;
1.28      raeburn   550:                 my $crshome = &Apache::lonnet::homeserver($storedcnum,$cdom);
1.1       raeburn   551:                 if ($crshome =~ /(con_lost|no_host|no_such_host)/) {
1.32      raeburn   552:                     &invalid_request($r,'Invalid courseID included in launch data');
1.1       raeburn   553:                     return OK;
                    554:                 } else {
1.28      raeburn   555:                     $posscnum = $storedcnum;
1.1       raeburn   556:                 }
                    557:             }
                    558:         }
                    559:     }
                    560: 
                    561:     if ($urlcnum ne '') {
                    562:         if ($posscnum ne '') {
                    563:             if ($posscnum ne $urlcnum) {
1.32      raeburn   564:                 &invalid_request($r,'Course ID included in launch data incompatible with URL');
1.1       raeburn   565:                 return OK;
                    566:             } else {
                    567:                 $cnum = $posscnum;
                    568:             }
                    569:         } else {
                    570:             my $crshome = &Apache::lonnet::homeserver($urlcnum,$cdom);
                    571:             if ($crshome =~ /(con_lost|no_host|no_such_host)/) {
1.32      raeburn   572:                 &invalid_request($r,'Valid course ID could not be extracted from requested URL');
1.1       raeburn   573:                 return OK;
                    574:             } else {
                    575:                 $cnum = $urlcnum;
                    576:             }
                    577:         }
                    578:     } elsif ($posscnum ne '') {
                    579:         $cnum = $posscnum;
                    580:     }
                    581: 
                    582: #
1.6       raeburn   583: # Get LON-CAPA role(s) to use from role-mapping of Consumer roles
1.1       raeburn   584: # defined in domain configuration for the appropriate LTI
                    585: # Consumer.
                    586: #
1.6       raeburn   587: # If multiple LON-CAPA roles are indicated for the current user,
                    588: # ordering (from first to last) is: cc/co, in, ta, ep, st.
1.1       raeburn   589: #
                    590: 
1.6       raeburn   591:     my (@ltiroles,@lcroles);
                    592:     my @lcroleorder = ('cc','in','ta','ep','st');
1.15      raeburn   593:     my ($lcrolesref,$ltirolesref) = 
                    594:         &LONCAPA::ltiutils::get_lc_roles($params->{'roles'},
                    595:                                          \@lcroleorder,
                    596:                                          $lti{$itemid}{maproles});
1.13      raeburn   597:     if (ref($lcrolesref) eq 'ARRAY') {
                    598:         @lcroles = @{$lcrolesref};
1.1       raeburn   599:     }
1.13      raeburn   600:     if (ref($ltirolesref) eq 'ARRAY') {
                    601:         @ltiroles = @{$ltirolesref};
1.1       raeburn   602:     }
                    603: 
                    604: #
                    605: # If no LON-CAPA username  -- is user allowed to create one?
                    606: #
                    607: 
                    608:     my $selfcreate;
                    609:     if (($uname ne '') && ($udom ne '')) {
                    610:         $uhome = &Apache::lonnet::homeserver($uname,$udom);
                    611:         if ($uhome =~ /(con_lost|no_host|no_such_host)/) {
                    612:             &Apache::lonnet::logthis(" LTI authorized unknown user $uname:$udom ");
                    613:             if (ref($lti{$itemid}{'makeuser'}) eq 'ARRAY') {
                    614:                 if (@{$lti{$itemid}{'makeuser'}} > 0) {
                    615:                     foreach my $ltirole (@ltiroles) {
                    616:                         if (grep(/^\Q$ltirole\E$/,@{$lti{$itemid}{'makeuser'}})) {
                    617:                             $selfcreate = 1;
1.6       raeburn   618:                             last;
1.1       raeburn   619:                         }
                    620:                     }
                    621:                 }
                    622:             }
                    623:             if ($selfcreate) {
1.13      raeburn   624:                 my (%rulematch,%inst_results,%curr_rules,%got_rules,%alerts);
                    625:                 my $domdesc = &Apache::lonnet::domain($udom,'description');
                    626:                 my %data = (
                    627:                     'permanentemail' => $env{'form.lis_person_contact_email_primary'},
                    628:                     'firstname'      => $env{'form.lis_person_name_given'},
                    629:                     'lastname'       => $env{'form.lis_person_name_family'},
                    630:                     'fullname'       => $env{'form.lis_person_name_full'},
                    631:                 );
                    632:                 my $result =
                    633:                     &LONCAPA::ltiutils::create_user($lti{$itemid},$uname,$udom,
                    634:                                                     $domdesc,\%data,\%alerts,\%rulematch,
                    635:                                                     \%inst_results,\%curr_rules,%got_rules);
                    636:                 if ($result eq 'notallowed') {
1.32      raeburn   637:                     &invalid_request($r,'Account creation not permitted for this user');
1.13      raeburn   638:                 } elsif ($result eq 'ok') {
1.6       raeburn   639:                     if (($ltiroles[0] eq 'Instructor') && ($lcroles[0] eq 'cc') && ($lti{$itemid}{'mapcrs'}) &&
                    640:                         ($lti{$itemid}{'makecrs'})) {
                    641:                         unless (&Apache::lonnet::usertools_access($uname,$udom,'lti','reload','requestcourses')) {
1.10      raeburn   642:                             &Apache::lonnet::put('environment',{ 'requestcourses.lti' => 'autolimit=', },$udom,$uname);
1.6       raeburn   643:                         }
                    644:                     }
                    645:                 } else {
1.32      raeburn   646:                     &invalid_request($r,'An error occurred during account creation');
1.6       raeburn   647:                     return OK;
                    648:                 }
1.1       raeburn   649:             } else {
1.32      raeburn   650:                 &invalid_request($r,'Account creation not permitted');
1.1       raeburn   651:                 return OK;
1.6       raeburn   652:             }
                    653:         }
1.1       raeburn   654:     } else {
1.32      raeburn   655:         &invalid_request($r,'Could not determine username and/or domain for user');
1.1       raeburn   656:         return OK;
                    657:     }
                    658: 
                    659: #
                    660: # If no LON-CAPA course available, check if domain's configuration
                    661: # for the specific LTI Consumer allows a new course to be created 
1.6       raeburn   662: # (requires role in Consumer to be: Instructor and Instructor to map to CC)
1.1       raeburn   663: #
                    664: 
1.6       raeburn   665:     my $reqcrs;
1.1       raeburn   666:     if ($cnum eq '') {
1.26      raeburn   667:         if ($lti{$itemid}{'crsinc'}) {
                    668:             if ((@ltiroles) && ($lti{$itemid}{'mapcrs'}) &&
                    669:                 ($ltiroles[0] eq 'Instructor') && ($lcroles[0] eq 'cc') && ($lti{$itemid}{'makecrs'})) {
                    670:                 my (%can_request,%request_domains);
                    671:                 &Apache::lonnet::check_can_request($cdom,\%can_request,\%request_domains,$uname,$udom);
                    672:                 if ($can_request{'lti'}) {
                    673:                     $reqcrs = 1;
                    674:                     &lti_session($r,$itemid,$uname,$udom,$uhome,$lonhost,undef,$mapurl,$tail,
                    675:                                  $symb,$cdom,$cnum,$params,\@ltiroles,$lti{$itemid},\@lcroles,
                    676:                                  $reqcrs,$sourcecrs);
                    677:                 } else {
1.32      raeburn   678:                     &invalid_request($r,'No LON-CAPA course available, and creation is not permitted for this user');
1.26      raeburn   679:                 }
1.6       raeburn   680:             } else {
1.32      raeburn   681:                 &invalid_request($r,'No LON-CAPA course available, and creation is not permitted');
1.6       raeburn   682:             }
1.1       raeburn   683:         } else {
1.26      raeburn   684:             &lti_session($r,$itemid,$uname,$udom,$uhome,$lonhost,undef,$mapurl,$tail,
                    685:                          $symb,$cdom,$cnum,$params,\@ltiroles,$lti{$itemid},\@lcroles,
                    686:                          $reqcrs,$sourcecrs);
1.1       raeburn   687:         }
1.6       raeburn   688:         return OK;
1.1       raeburn   689:     }
                    690: 
                    691: #
                    692: # If LON-CAPA course is a Community, and LON-CAPA role
                    693: # indicated is cc, change role indicated to co.
1.27      raeburn   694: #
1.1       raeburn   695: 
1.6       raeburn   696:     my %crsenv;
                    697:     if ($lcroles[0] eq 'cc') {
1.1       raeburn   698:         if (($cdom ne '') && ($cnum ne '')) {
1.6       raeburn   699:             %crsenv = &Apache::lonnet::coursedescription($cdom.'_'.$cnum,{ 'one_time' => 1,});
1.1       raeburn   700:             if ($crsenv{'type'} eq 'Community') {
1.6       raeburn   701:                 $lcroles[0] = 'co';
                    702:             }
                    703:         }
                    704:     }
                    705: 
                    706: #
                    707: # Determine if user has a LON-CAPA role in the mapped LON-CAPA course.
                    708: # If multiple LON-CAPA roles are available for the user's assigned LTI roles,
                    709: # choose the first available LON-CAPA role in the order: cc/co, in, ta, ep, st
                    710: #
                    711: 
                    712:     my ($role,$usec,$withsec);
                    713:     unless ((($lcroles[0] eq 'cc') || ($lcroles[0] eq 'co')) && (@lcroles == 1)) {
                    714:         if ($lti{$itemid}{'section'} ne '') {
                    715:             if ($lti{$itemid}{'section'} eq 'course_section_sourcedid') {
                    716:                 if ($env{'form.course_section_sourcedid'} !~ /\W/) {
                    717:                     $usec = $env{'form.course_section_sourcedid'};
                    718:                 }
                    719:             } elsif ($env{'form.'.$lti{$itemid}{'section'}} !~ /\W/) {
                    720:                 $usec = $env{'form.'.$lti{$itemid}{'section'}};
                    721:             }
                    722:         }
                    723:         if ($usec ne '') {
                    724:             $withsec = 1;
                    725:         }
                    726:     }
                    727: 
                    728:     if (@lcroles) {
                    729:         my %crsroles = &Apache::lonnet::get_my_roles($uname,$udom,'userroles',undef,\@lcroles,
                    730:                                                      [$cdom],$withsec);
                    731:         foreach my $reqrole (@lcroles) {
                    732:             if ($withsec) {
                    733:                 my $incsec;
                    734:                 if (($reqrole eq 'cc') || ($reqrole eq 'co')) {
                    735:                     $incsec = '';
                    736:                 } else {
                    737:                     $incsec = $usec;
                    738:                 }
                    739:                 if (exists($crsroles{$cnum.':'.$cdom.':'.$reqrole.':'.$incsec})) {
                    740:                     $role = $reqrole.'./'.$cdom.'/'.$cnum;
                    741:                     if ($incsec ne '') {
                    742:                         $role .= '/'.$usec;
                    743:                     }
                    744:                     last;
                    745:                 }
                    746:             } else {
                    747:                 if (exists($crsroles{$cnum.':'.$cdom.':'.$reqrole})) {
                    748:                     $role = $reqrole.'./'.$cdom.'/'.$cnum;
                    749:                     last;
                    750:                 }
1.1       raeburn   751:             }
                    752:         }
                    753:     }
                    754: 
                    755: #
1.6       raeburn   756: # Determine if user can selfenroll
1.1       raeburn   757: #
                    758: 
1.6       raeburn   759:     my ($reqrole,$selfenrollrole);
                    760:     if ($role eq '') {
                    761:         if ((@ltiroles) && (ref($lti{$itemid}{'selfenroll'}) eq 'ARRAY')) {
                    762:             foreach my $ltirole (@ltiroles) {
                    763:                 if (grep(/^\Q$ltirole\E$/,@{$lti{$itemid}{'selfenroll'}})) {
                    764:                     if (ref($lti{$itemid}{maproles}) eq 'HASH') {
                    765:                         $reqrole = $lti{$itemid}{maproles}{$ltirole};
                    766:                         last;
                    767:                     }
                    768:                 }
                    769:             }
                    770:         }
                    771:         if ($reqrole eq '') {
1.32      raeburn   772:             &invalid_request($r,'No matching role available in LON-CAPA course, and not permitted to self-enroll');
1.1       raeburn   773:             return OK;
                    774:         } else {
1.6       raeburn   775:             unless (%crsenv) {
                    776:                 %crsenv = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);
                    777:             }
                    778:             my $default_enrollment_start_date = $crsenv{'default_enrollment_start_date'};
                    779:             my $default_enrollment_end_date   = $crsenv{'default_enrollment_end_date'};
                    780:             my $now = time;
                    781:             if ($default_enrollment_end_date && $default_enrollment_end_date <= $now) {
1.32      raeburn   782:                 &invalid_request($r,'No active role available in LON-CAPA course, and past end date for self-enrollment');
1.6       raeburn   783:                 return OK;
                    784:             } elsif ($default_enrollment_start_date && $default_enrollment_start_date >$now) {
1.32      raeburn   785:                 &invalid_request($r,'No active role available in LON-CAPA course, and brefor start date for self-enrollment');
1.6       raeburn   786:                 return OK;
                    787:             } else {
                    788:                 $selfenrollrole = $reqrole.'./'.$cdom.'/'.$cnum;
                    789:                 if (($withsec) && ($reqrole ne 'cc') && ($reqrole ne 'co')) {
                    790:                     if ($usec ne '') {
                    791:                         $selfenrollrole .= '/'.$usec;
                    792:                     }
                    793:                 }
                    794:             }
1.1       raeburn   795:         }
                    796:     }
                    797: 
                    798: #
1.27      raeburn   799: # Retrieve course type of LON-CAPA course to check if mapping from a Consumer
                    800: # course identifier permitted for this type of course (one of: official,
                    801: # unofficial, community, textbook, placement or lti.
                    802: #
                    803: 
                    804:     unless (%crsenv) {
                    805:         %crsenv = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);
                    806:     }
                    807:     my $crstype = lc($crsenv{'type'});
                    808:     if ($crstype eq '') {
                    809:         $crstype = 'course';
                    810:     }
                    811:     if ($crstype eq 'course') {
                    812:         if ($crsenv{'internal.coursecode'}) {
                    813:             $crstype = 'official';
                    814:         } elsif ($crsenv{'internal.textbook'}) {
                    815:             $crstype = 'textbook';
                    816:         } elsif ($crsenv{'internal.lti'}) {
                    817:             $crstype = 'lti';
                    818:         } else {
                    819:             $crstype = 'unofficial';
                    820:         }
                    821:     }
                    822: 
                    823: #
                    824: # Store consumer-to-LON-CAPA course mapping if permitted
1.1       raeburn   825: #
1.6       raeburn   826: 
1.27      raeburn   827:     if (($lti{$itemid}{'storecrs'}) && ($sourcecrs ne '') && 
                    828:         ($consumers{$sourcecrs} eq '') && ($cnum ne '')) {
                    829:         if (ref($lti{$itemid}{'mapcrstype'}) eq 'ARRAY') {
                    830:             if (grep(/^$crstype$/,@{$lti{$itemid}{'mapcrstype'}})) {
1.28      raeburn   831:                 &Apache::lonnet::put_dom('lticonsumers',{ $sourcecrs => $itemid.':'.$cnum },$cdom);
1.27      raeburn   832:             }
                    833:         }
1.1       raeburn   834:     }
                    835: 
                    836: #
1.6       raeburn   837: # Start user session
                    838: #
                    839: 
                    840:     &lti_session($r,$itemid,$uname,$udom,$uhome,$lonhost,$role,$mapurl,$tail,$symb,
                    841:                  $cdom,$cnum,$params,\@ltiroles,$lti{$itemid},\@lcroles,undef,$sourcecrs,
                    842:                  $selfenrollrole);
                    843:     return OK;
                    844: }
                    845: 
1.20      raeburn   846: sub get_lti_itemid {
1.30      raeburn   847:     my ($requri,$hostname,$params,$cdom,$cnum,$context) = @_;
1.31      raeburn   848:     return unless (ref($params) eq 'HASH');
1.20      raeburn   849:     my $protocol = 'http';
                    850:     if ($ENV{'SERVER_PORT'} == 443) {
                    851:         $protocol = 'https';
                    852:     }
1.30      raeburn   853:     my $url = $protocol.'://'.$hostname.$requri;
                    854:     my $method = $env{'request.method'};
                    855:     if ($cnum ne '') {
                    856:         return &Apache::lonnet::courselti_itemid($cnum,$cdom,$url,$method,$params,$context);
                    857:     } else {
                    858:         return &Apache::lonnet::domainlti_itemid($cdom,$url,$method,$params,$context);
1.20      raeburn   859:     }
                    860: }
                    861: 
1.6       raeburn   862: sub lti_enroll {
                    863:     my ($uname,$udom,$selfenrollrole) = @_;
                    864:     my $enrollresult;
                    865:     my ($role,$cdom,$cnum,$sec) =
                    866:            ($selfenrollrole =~ m{^(\w+)\./($match_domain)/($match_courseid)(?:|/(\w*))$});
                    867:     if (($cnum ne '') && ($cdom ne '')) {
                    868:         my $chome = &Apache::lonnet::homeserver($cnum,$cdom);
                    869:         if ($chome ne 'no_host') {
                    870:             my %coursehash = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);
                    871:             my $start = $coursehash{'default_enrollment_start_date'};
                    872:             my $end = $coursehash{'default_enrollment_end_date'};
1.14      raeburn   873:             $enrollresult = &LONCAPA::ltiutils::enrolluser($udom,$uname,$role,$cdom,$cnum,$sec,
                    874:                                                            $start,$end,1);
1.6       raeburn   875:         }
                    876:     }
                    877:     return $enrollresult;
                    878: }
                    879: 
                    880: sub lti_reqcrs {
                    881:     my ($r,$cdom,$form,$uname,$udom) = @_;
                    882:     my (%can_request,%request_domains);
                    883:     &Apache::lonnet::check_can_request($cdom,\%can_request,\%request_domains,$uname,$udom);
                    884:     if ($can_request{'lti'}) {
                    885:         my %domconfig = &Apache::lonnet::get_dom('configuration',['requestcourses'],$cdom);
                    886:         my %domdefs = &Apache::lonnet::get_domain_defaults($cdom);
                    887:         &Apache::lonrequestcourse::print_textbook_form($r,$cdom,[$cdom],\%domdefs,
                    888:                                                        $domconfig{'requestcourses'},
                    889:                                                        \%can_request,'lti',$form);
                    890:     } else {
                    891:         $r->print(
                    892:               &Apache::loncommon::start_page('Invalid LTI call',undef,{'only_body' => 1}).
                    893:               &mt('Invalid LTI call').
                    894:               &Apache::loncommon::end_page()
                    895:         );
                    896:     }
                    897: }
                    898: 
                    899: sub lti_session {
                    900:     my ($r,$itemid,$uname,$udom,$uhome,$lonhost,$role,$mapurl,$tail,$symb,$cdom,$cnum,
                    901:         $params,$ltiroles,$ltihash,$lcroles,$reqcrs,$sourcecrs,$selfenrollrole) = @_;
                    902:     return unless ((ref($params) eq 'HASH') && (ref($ltiroles) eq 'ARRAY') &&
                    903:                    (ref($ltihash) eq 'HASH') && (ref($lcroles) eq 'ARRAY'));
                    904: #
1.1       raeburn   905: # Check if user should be hosted here or switched to another server.
                    906: #
                    907:     $r->user($uname);
1.6       raeburn   908:     if ($cnum) {
                    909:         if ($role) {
                    910:             &Apache::lonnet::logthis(" LTI authorized user ($itemid): $uname:$udom, role: $role, course: $cdom\_$cnum");
                    911:         } elsif ($selfenrollrole =~ m{^(\w+)\./$cdom/$cnum}) {
                    912:             &Apache::lonnet::logthis(" LTI authorized user ($itemid): $uname:$udom, desired role: $1 course: $cdom\_$cnum");
                    913:         }
                    914:     } else {
                    915:         &Apache::lonnet::logthis(" LTI authorized user ($itemid): $uname:$udom, course dom: $cdom");
                    916:     }
1.32      raeburn   917:     my ($is_balancer,$otherserver,$hosthere) = &check_balancer($r,$uname,$udom);
1.19      raeburn   918:     my $protocol = 'http';
                    919:     if ($ENV{'SERVER_PORT'} == 443) {
                    920:         $protocol = 'https';
                    921:     }
1.1       raeburn   922:     if (($is_balancer) && (!$hosthere)) {
                    923:         # login but immediately go to switch server.
                    924:         &Apache::lonauth::success($r,$uname,$udom,$uhome,'noredirect');
1.19      raeburn   925:         if (($ltihash->{'callback'}) && ($params->{$ltihash->{'callback'}})) {
                    926:             &LONCAPA::ltiutils::setup_logout_callback($uname,$udom,$otherserver,
                    927:                                                       $ltihash->{'key'},
                    928:                                                       $ltihash->{'secret'},
                    929:                                                       $params->{$ltihash->{'callback'}},
                    930:                                                       $r->dir_config('ltiIDsDir'),
                    931:                                                       $protocol,$r->hostname);
                    932:         }
1.1       raeburn   933:         if ($symb) {
                    934:             $env{'form.symb'} = $symb;
1.16      raeburn   935:             $env{'request.lti.uri'} = $tail;
1.6       raeburn   936:         } else {
                    937:             if ($mapurl) {
                    938:                 $env{'form.origurl'} = $mapurl;
1.8       raeburn   939:                 $env{'request.lti.uri'} = $mapurl;
1.6       raeburn   940:             } elsif ($tail =~ m{^\Q/tiny/$cdom/\E\w+$}) {
                    941:                 $env{'form.origurl'} = $tail;
1.8       raeburn   942:                 $env{'request.lti.uri'} = $tail;
1.9       raeburn   943:             } elsif ($tail eq "/$cdom/$cnum") {
                    944:                 $env{'form.origurl'} = '/adm/navmaps';
                    945:                 $env{'request.lti.uri'} = $tail;
1.6       raeburn   946:             } else {
                    947:                 unless ($tail eq '/adm/roles') {
1.26      raeburn   948:                     if ($cnum) {
                    949:                         $env{'form.origurl'} = '/adm/navmaps';
                    950:                     }
1.6       raeburn   951:                 }
                    952:             }
1.1       raeburn   953:         }
                    954:         if ($role) {
                    955:             $env{'form.role'} = $role;
                    956:         }
1.6       raeburn   957:         if (($lcroles->[0] eq 'cc') && ($reqcrs)) {
                    958:             $env{'request.lti.reqcrs'} = 1;
                    959:             $env{'request.lti.reqrole'} = 'cc';
                    960:             $env{'request.lti.sourcecrs'} = $sourcecrs;
                    961:         }
                    962:         if ($selfenrollrole) {
1.18      raeburn   963:             $env{'request.lti.selfenrollrole'} = $selfenrollrole;
1.6       raeburn   964:             $env{'request.lti.sourcecrs'} = $sourcecrs;
                    965:         }
                    966:         if ($ltihash->{'passback'}) {
1.1       raeburn   967:             if ($params->{'lis_result_sourcedid'}) {
                    968:                 $env{'request.lti.passbackid'} = $params->{'lis_result_sourcedid'};
                    969:             }
                    970:             if ($params->{'lis_outcome_service_url'}) {
                    971:                 $env{'request.lti.passbackurl'} = $params->{'lis_outcome_service_url'};
                    972:             }
                    973:         }
1.6       raeburn   974:         if (($ltihash->{'roster'}) && (grep(/^Instructor$/,@{$ltiroles}))) {
1.1       raeburn   975:             if ($params->{'ext_ims_lis_memberships_id'}) {
1.6       raeburn   976:                 $env{'request.lti.rosterid'} = $params->{'ext_ims_lis_memberships_id'};
1.1       raeburn   977:             }
                    978:             if ($params->{'ext_ims_lis_memberships_url'}) {
                    979:                 $env{'request.lti.rosterurl'} = $params->{'ext_ims_lis_memberships_url'};
                    980:             }
                    981:         }
1.10      raeburn   982:         $env{'request.lti.login'} = $itemid;
1.8       raeburn   983:         if ($params->{'launch_presentation_document_target'}) {
                    984:             $env{'request.lti.target'} = $params->{'launch_presentation_document_target'};
                    985:         }
1.25      raeburn   986:         foreach my $key (keys(%{$params})) {
1.1       raeburn   987:             delete($env{'form.'.$key});
                    988:         }
                    989:         my $redirecturl = '/adm/switchserver';
                    990:         if ($otherserver ne '') {
                    991:             $redirecturl .= '?otherserver='.$otherserver;
                    992:         }
                    993:         $r->internal_redirect($redirecturl);
                    994:         $r->set_handlers('PerlHandler'=> undef);
                    995:     } else {
1.32      raeburn   996:         # need to login them in, so generate the data migrate expects to do login
1.25      raeburn   997:         foreach my $key (keys(%{$params})) {
1.1       raeburn   998:             delete($env{'form.'.$key});
                    999:         }
1.19      raeburn  1000:         if (($ltihash->{'callback'}) && ($params->{$ltihash->{'callback'}})) {
                   1001:             &LONCAPA::ltiutils::setup_logout_callback($uname,$udom,$lonhost,
                   1002:                                                       $ltihash->{'key'},
                   1003:                                                       $ltihash->{'secret'},
                   1004:                                                       $params->{$ltihash->{'callback'}},
                   1005:                                                       $r->dir_config('ltiIDsDir'),
                   1006:                                                       $protocol,$r->hostname);
                   1007:         }
1.37      raeburn  1008:         my $ip = &Apache::lonnet::get_requestor_ip($r,REMOTE_NOLOOKUP);
1.1       raeburn  1009:         my %info=('ip'        => $ip,
                   1010:                   'domain'    => $udom,
                   1011:                   'username'  => $uname,
                   1012:                   'server'    => $lonhost,
1.10      raeburn  1013:                   'lti.login' => $itemid,
1.8       raeburn  1014:                   'lti.uri'   => $tail,
1.1       raeburn  1015:                  );
                   1016:         if ($role) {
                   1017:             $info{'role'} = $role;
                   1018:         }
                   1019:         if ($symb) {
1.6       raeburn  1020:             $info{'symb'} = $symb;
                   1021:         }
                   1022:         if (($lcroles->[0] eq 'cc') && ($reqcrs)) {
                   1023:             $info{'lti.reqcrs'} = 1;
                   1024:             $info{'lti.reqrole'} = 'cc';
                   1025:             $info{'lti.sourcecrs'} = $sourcecrs;
                   1026:         }
                   1027:         if ($selfenrollrole) {
                   1028:             $info{'lti.selfenrollrole'} = $selfenrollrole;
1.1       raeburn  1029:         }
1.6       raeburn  1030:         if ($ltihash->{'passback'}) {
1.1       raeburn  1031:             if ($params->{'lis_result_sourcedid'}) {
                   1032:                 $info{'lti.passbackid'} = $params->{'lis_result_sourcedid'}
                   1033:             }
                   1034:             if ($params->{'lis_outcome_service_url'}) {
                   1035:                 $info{'lti.passbackurl'} = $params->{'lis_outcome_service_url'}
                   1036:             }
                   1037:         }
1.6       raeburn  1038:         if (($ltihash->{'roster'}) && (grep(/^Instructor$/,@{$ltiroles}))) {
1.1       raeburn  1039:             if ($params->{'ext_ims_lis_memberships_id'}) {
                   1040:                 $info{'lti.rosterid'} = $params->{'ext_ims_lis_memberships_id'};
                   1041:             }
                   1042:             if ($params->{'ext_ims_lis_memberships_url'}) {
                   1043:                 $info{'lti.rosterurl'} = $params->{'ext_ims_lis_memberships_url'};
                   1044:             }
                   1045:         }
1.8       raeburn  1046:         if ($params->{'launch_presentation_document_target'}) {
                   1047:             $info{'lti.target'} = $params->{'launch_presentation_document_target'};
                   1048:         }
                   1049: 
1.1       raeburn  1050:         unless ($info{'symb'}) {
                   1051:             if ($mapurl) {
                   1052:                 $info{'origurl'} = $mapurl;
1.6       raeburn  1053:             } elsif ($tail =~ m{^\Q/tiny/$cdom/\E\w+$}) {
                   1054:                 $info{'origurl'} = $tail;
1.1       raeburn  1055:             } else {
                   1056:                 unless ($tail eq '/adm/roles') {
1.26      raeburn  1057:                     if ($cnum) {
                   1058:                         $info{'origurl'} = '/adm/navmaps';
                   1059:                     }
1.1       raeburn  1060:                 }
                   1061:             }
                   1062:         }
                   1063:         if (($is_balancer) && ($hosthere)) {
                   1064:             $info{'noloadbalance'} = $hosthere;
                   1065:         }
                   1066:         my $token = &Apache::lonnet::tmpput(\%info,$lonhost);
                   1067:         $env{'form.token'} = $token;
                   1068:         $r->internal_redirect('/adm/migrateuser');
                   1069:         $r->set_handlers('PerlHandler'=> undef);
                   1070:     }
1.6       raeburn  1071:     return;
1.1       raeburn  1072: }
                   1073: 
1.32      raeburn  1074: sub linkprot_session {
1.39    ! raeburn  1075:     my ($r,$uname,$cnum,$cdom,$uhome,$itemid,$ltitype,$dest,$lonhost,$exiturl) = @_;
1.32      raeburn  1076:     $r->user($uname);
                   1077:     if ($ltitype eq 'c') {
1.34      raeburn  1078:         &Apache::lonnet::logthis("Course Link Protector ($itemid) authorized student: $uname:$cdom, course: $cdom\_$cnum");
1.32      raeburn  1079:     } elsif ($ltitype eq 'd') {
1.34      raeburn  1080:         &Apache::lonnet::logthis("Domain LTI for link protection ($itemid) authorized student: $uname:$cdom, course: $cdom\_$cnum");
1.32      raeburn  1081:     }
                   1082:     my ($is_balancer,$otherserver,$hosthere) = &check_balancer($r,$uname,$cdom);
                   1083:     if (($is_balancer) && (!$hosthere)) {
                   1084:         # login but immediately go to switch server
1.33      raeburn  1085:         &Apache::lonauth::success($r,$uname,$cdom,$uhome,'noredirect');
1.32      raeburn  1086:         $env{'form.origurl'} = $dest;
                   1087:         $env{'request.linkprot'} = $itemid.$ltitype.':'.$dest;
1.38      raeburn  1088:         $env{'request.linkprotuser'} = $uname.':'.$cdom;
1.32      raeburn  1089:         $env{'request.deeplink.login'} = $dest;
1.39    ! raeburn  1090:         if ($exiturl ne '') {
        !          1091:             $env{'request.linkprotexit'} = $exiturl;
        !          1092:         }
1.32      raeburn  1093:         my $redirecturl = '/adm/switchserver';
                   1094:         if ($otherserver ne '') {
                   1095:             $redirecturl .= '?otherserver='.$otherserver;
                   1096:         }
                   1097:         $r->internal_redirect($redirecturl);
                   1098:         $r->set_handlers('PerlHandler'=> undef);
                   1099:     } else {
                   1100:         # need to login them in, so generate the data migrate expects to do login
1.37      raeburn  1101:         my $ip = &Apache::lonnet::get_requestor_ip($r,REMOTE_NOLOOKUP);
1.32      raeburn  1102:         my %info=('ip'             => $ip,
                   1103:                   'domain'         => $cdom,
                   1104:                   'username'       => $uname,
                   1105:                   'server'         => $lonhost,
                   1106:                   'linkprot'       => $itemid.$ltitype.':'.$dest,
1.38      raeburn  1107:                   'linkprotuser'   => $uname.':'.$cdom,
1.32      raeburn  1108:                   'home'           => $uhome,
                   1109:                   'origurl'        => $dest,
                   1110:                   'deeplink.login' => $dest,
                   1111:                  );
1.39    ! raeburn  1112:         if ($exiturl ne '') {
        !          1113:             $info{'linkprotexit'} = $exiturl; 
        !          1114:         }
1.32      raeburn  1115:         my $token = &Apache::lonnet::tmpput(\%info,$lonhost);
                   1116:         $env{'form.token'} = $token;
                   1117:         $r->internal_redirect('/adm/migrateuser');
                   1118:         $r->set_handlers('PerlHandler'=> undef);
                   1119:     }
                   1120:     return;
                   1121: }
                   1122: 
                   1123: sub check_balancer {
                   1124:     my ($r,$uname,$udom) = @_;
                   1125:     my ($is_balancer,$otherserver,$hosthere);
                   1126:     ($is_balancer,$otherserver) =
                   1127:         &Apache::lonnet::check_loadbalancing($uname,$udom,'login');
                   1128:     if ($is_balancer) {
                   1129:         if ($otherserver eq '') {
                   1130:             my $lowest_load;
                   1131:             ($otherserver,undef,undef,undef,$lowest_load) = &Apache::lonnet::choose_server($udom);
                   1132:             if ($lowest_load > 100) {
                   1133:                 $otherserver = &Apache::lonnet::spareserver($r,$lowest_load,$lowest_load,1,$udom);
                   1134:             }
                   1135:         }
                   1136:         if ($otherserver ne '') {
                   1137:             my @hosts = &Apache::lonnet::current_machine_ids();
                   1138:             if (grep(/^\Q$otherserver\E$/,@hosts)) {
                   1139:                 $hosthere = $otherserver;
                   1140:             }
                   1141:         }
                   1142:     }
                   1143:     return ($is_balancer,$otherserver,$hosthere);
                   1144: }
                   1145: 
1.1       raeburn  1146: sub invalid_request {
1.32      raeburn  1147:     my ($r,$msg) = @_;
1.1       raeburn  1148:     &Apache::loncommon::content_type($r,'text/html');
                   1149:     $r->send_http_header;
                   1150:     if ($r->header_only) {
                   1151:         return;
                   1152:     }
                   1153:     &Apache::lonlocal::get_language_handle($r);
                   1154:     $r->print(
1.10      raeburn  1155:         &Apache::loncommon::start_page('Invalid LTI call','',{ 'only_body' => 1,}).
1.32      raeburn  1156:         '<h3>'.&mt('Invalid LTI launch request').'</h3>'.
                   1157:         '<p class="LC_warning">'.
                   1158:         &mt('Launch of LON-CAPA is unavailable from the "external tool" link you had followed in another web application.').
1.36      raeburn  1159:         ' '.&mt('Launch failed for the following reason:').
1.32      raeburn  1160:         '</p>'.
1.33      raeburn  1161:         '<p class="LC_error">'.$msg.'</p>'.
1.1       raeburn  1162:         &Apache::loncommon::end_page());
                   1163:     return;
                   1164: }
                   1165: 
1.20      raeburn  1166: sub course_from_tinyurl {
                   1167:     my ($tail) = @_;
                   1168:     my ($urlcdom,$urlcnum);
                   1169:     if ($tail =~ m{^/tiny/($match_domain)/(\w+)$}) {
1.21      raeburn  1170:         ($urlcdom,my $key) = ($1,$2);
1.20      raeburn  1171:         my $tinyurl;
                   1172:         my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$urlcdom."\0".$key);
                   1173:         if (defined($cached)) {
                   1174:             $tinyurl = $result;
                   1175:         } else {
                   1176:             my $configuname = &Apache::lonnet::get_domainconfiguser($urlcdom);
                   1177:             my %currtiny = &Apache::lonnet::get('tiny',[$key],$urlcdom,$configuname);
                   1178:             if ($currtiny{$key} ne '') {
                   1179:                 $tinyurl = $currtiny{$key};
                   1180:                 &Apache::lonnet::do_cache_new('tiny',$urlcdom."\0".$key,$currtiny{$key},600);
                   1181:             }
                   1182:         }
                   1183:         if ($tinyurl ne '') {
                   1184:             $urlcnum = (split(/\&/,$tinyurl))[0];
                   1185:         }
                   1186:     }
                   1187:     return ($urlcdom,$urlcnum);
                   1188: }
                   1189: 
1.1       raeburn  1190: 1;

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