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

1.1     ! raeburn     1: # The LearningOnline Network
        !             2: # Basic LTI Authentication Module
        !             3: #
        !             4: # $Id: ltiauth.pm,v 1.1 2017/12/05 15:14:51 raeburn Exp $
        !             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);
        !            33: use Apache::Constants qw(:common :http);
        !            34: use Net::OAuth;
        !            35: use Apache::lonlocal;
        !            36: use Apache::lonnet;
        !            37: use Apache::loncommon;
        !            38: use Apache::lonacc;
        !            39: 
        !            40: sub handler {
        !            41:     my $r = shift;
        !            42:     my $requri = $r->uri;
        !            43: #
        !            44: # Retrieve data POSTed by LTI Consumer on launch  
        !            45: #
        !            46:     &Apache::lonacc::get_posted_cgi($r);
        !            47:     my $params = {};
        !            48:     foreach my $key (sort(keys(%env))) {
        !            49:         if ($key =~ /^form\.(.+)$/) {
        !            50:             $params->{$1} = $env{$key};
        !            51:         }
        !            52:     }
        !            53: 
        !            54:     unless (keys(%{$params})) {
        !            55:         &invalid_request($r,1);
        !            56:         return OK;
        !            57:     }
        !            58: 
        !            59:     unless ($params->{'oauth_consumer_key'} &&
        !            60:             $params->{'oauth_nonce'} &&
        !            61:             $params->{'oauth_timestamp'} &&
        !            62:             $params->{'oauth_version'} &&
        !            63:             $params->{'oauth_signature'} &&
        !            64:             $params->{'oauth_signature_method'}) {
        !            65:         &invalid_request($r,2);
        !            66:         return OK;
        !            67:     }
        !            68: 
        !            69: #
        !            70: # Retrieve "internet domains" for all this institution's LON-CAPA
        !            71: # nodes.
        !            72: #
        !            73:     my ($udom,$uname,$uhome,$cdom,$cnum,$symb,$mapurl,@intdoms);
        !            74:     my $lonhost = $r->dir_config('lonHostID');
        !            75:     my $internet_names = &Apache::lonnet::get_internet_names($lonhost);
        !            76:     if (ref($internet_names) eq 'ARRAY') {
        !            77:         @intdoms = @{$internet_names};
        !            78:     }
        !            79: 
        !            80: #
        !            81: # For user who launched LTI in Consumer, determine user's domain in 
        !            82: # LON-CAPA.
        !            83: #
        !            84: # Order is:
        !            85: #
        !            86: # (a) from custom_userdomain item in POSTed data
        !            87: # (b) from lis_person_sourcedid in POSTed data
        !            88: # (c) from default "log-in" domain for node
        !            89: #     (can support multidomain servers, where specific domain is 
        !            90: #      first part of hostname).
        !            91: #
        !            92: # Note: "internet domain" for user's domain must be one of the
        !            93: # "internet domain(s)" for the institution's LON-CAPA servers.
        !            94: #
        !            95:     if (exists($params->{'custom_userdomain'})) {
        !            96:         if ($params->{'custom_userdomain'} =~ /^$match_domain$/) {
        !            97:             my $uprimary_id = &Apache::lonnet::domain($params->{'custom_userdomain'},'primary');
        !            98:             if ($uprimary_id ne '') {
        !            99:                 my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
        !           100:                 if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) {
        !           101:                     $udom = $params->{'custom_userdomain'};
        !           102:                 }
        !           103:             }
        !           104:         }
        !           105:     }
        !           106:     my $defdom = &Apache::lonnet::default_login_domain();
        !           107:     my ($domain,$possuname,$possudom,$possmapuser);
        !           108:     if ($env{'form.lis_person_sourcedid'} =~ /^($match_username)\:($match_domain)$/) {
        !           109:         ($possuname,$possudom) = ($1,$2);
        !           110:         if ($udom eq '') {
        !           111:             my $uintdom = &Apache::lonnet::domain($possudom,'primary');
        !           112:             if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) {
        !           113:                 $udom = $possudom;
        !           114:                 $possmapuser = 'lis_person_sourcedid';
        !           115:             } else {
        !           116:                 $udom = $defdom;
        !           117:             }
        !           118:         } elsif ($udom eq $possudom) {
        !           119:             $possmapuser = 'lis_person_sourcedid';
        !           120:         }
        !           121:     }
        !           122:     unless ($possuname) {
        !           123:         if ($env{'form.lis_person_sourcedid'} =~ /^$match_username$/) {
        !           124:             $possuname = $env{'form.lis_person_sourcedid'};
        !           125:             $possmapuser = 'lis_person_sourcedid';
        !           126:         } elsif ($env{'form.lis_person_contact_email_primary'} =~ /^$match_username$/) {
        !           127:             $possuname = $env{'form.lis_person_contact_email_primary'};
        !           128:             $possmapuser = 'lis_person_contact_email_primary';
        !           129:         }
        !           130:         unless ($udom) {
        !           131:             $udom = $defdom;
        !           132:         }
        !           133:     }
        !           134: 
        !           135: #
        !           136: # Determine course's domain in LON-CAPA
        !           137: #
        !           138: # Order is:
        !           139: #
        !           140: # (a) from custom_coursedomain item in POSTed data
        !           141: # (b) from tail of requested URL (after /adm/lti) if it has format of a symb  
        !           142: # (c) from tail of requested URL (after /adm/lti) if it has format of a map 
        !           143: # (d) from tail of requested URL (after /adm/lti) if it has format /domain/courseID
        !           144: # (e) from tail of requested URL (after /adm/lti) if it has format /tiny/domain/...
        !           145: # i.e., a shortened URL (see bug #6400) -- not implemented yet.   
        !           146: # (f) same as user's domain 
        !           147: #
        !           148: # Request invalid if custom_coursedomain is defined and is inconsistent with
        !           149: # domain contained in requested URL.
        !           150: #
        !           151: # Note: "internet domain" for course's domain must be one of the
        !           152: # internet domains for the institution's LON-CAPA servers.
        !           153: #
        !           154: 
        !           155:     if (exists($params->{'custom_coursedomain'})) {
        !           156:         if ($params->{'custom_coursedomain'} =~ /^$match_domain$/) {
        !           157:             my $cprimary_id = &Apache::lonnet::domain($params->{'custom_coursedomain'},'primary');
        !           158:             if ($cprimary_id ne '') {
        !           159:                 my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);
        !           160:                 if (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {
        !           161:                     $cdom = $params->{'custom_coursedomain'};
        !           162:                 }
        !           163:             }
        !           164:         }
        !           165:     }
        !           166: 
        !           167:     my ($tail) = ($requri =~ m{^/adm/lti(|/.*)$});
        !           168:     my $urlcnum;
        !           169:     if ($tail ne '') {
        !           170:         my $urlcdom;
        !           171:         if ($tail =~ m{^/uploaded/($match_domain)/($match_courseid)/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {
        !           172:             ($urlcdom,$urlcnum,my $rest) = ($1,$2,$3);
        !           173:             if (($cdom ne '') && ($cdom ne $urlcdom)) {
        !           174:                 &invalid_request($r,3);
        !           175:                 return OK;
        !           176:             }
        !           177:             if ($rest eq '') {
        !           178:                 $mapurl = $tail;
        !           179:             } else {
        !           180:                 $symb = $tail;
        !           181:                 $symb =~ s{^/+}{};
        !           182:             }
        !           183: #FIXME Need to handle encrypted URLs 
        !           184:         } elsif ($tail =~ m{^/($match_domain)/($match_courseid)$}) {
        !           185:             ($urlcdom,$urlcnum) = ($1,$2);
        !           186:             if (($cdom ne '') && ($cdom ne $urlcdom)) {
        !           187:                 &invalid_request($r,4);
        !           188:                 return OK;
        !           189:             }
        !           190:         }
        !           191:         if (($cdom eq '') && ($urlcdom ne '')) { 
        !           192:             my $cprimary_id = &Apache::lonnet::domain($urlcdom,'primary');
        !           193:             if ($cprimary_id ne '') {
        !           194:                 my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);
        !           195:                 if (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {
        !           196:                     $cdom = $urlcdom;
        !           197:                 }
        !           198:             } else {
        !           199:                 $urlcnum = '';
        !           200:             }
        !           201:         }
        !           202:     }
        !           203:     if ($cdom eq '') {
        !           204:         if ($udom ne '') {
        !           205:             $cdom = $udom;
        !           206:         } else {
        !           207:             $cdom = $defdom;
        !           208:         }
        !           209:     }
        !           210: 
        !           211: #
        !           212: # Retrieve information for LTI Consumers in course domain
        !           213: # and populate hash --  %lti_by_key -- for which keys
        !           214: # are those defined in domain configuration for LTI.
        !           215: #
        !           216:  
        !           217:     my %lti = &Apache::lonnet::get_domain_lti($cdom,'provider');
        !           218:     unless (keys(%lti) > 0) {
        !           219:         &invalid_request($r,5);
        !           220:         return OK;
        !           221:     }
        !           222:     my %lti_by_key;
        !           223:     if (keys(%lti)) {
        !           224:         foreach my $id (keys(%lti)) {
        !           225:             if (ref($lti{$id}) eq 'HASH') {
        !           226:                 my $key = $lti{$id}{'key'};
        !           227:                 push(@{$lti_by_key{$key}},$id);
        !           228:             }
        !           229:         }
        !           230:     }
        !           231: 
        !           232: #
        !           233: # Verify the signed request using the secret for those
        !           234: # Consumers for which the key in the POSTed data matches 
        !           235: # keys in the domain configuration for LTI.
        !           236: #
        !           237:     my $hostname = $r->hostname;
        !           238:     my $protocol = 'http';
        !           239:     if ($ENV{'SERVER_PORT'} == 443) {
        !           240:         $protocol = 'https';
        !           241:     }
        !           242: 
        !           243:     my $itemid;
        !           244:     my $key = $params->{'oauth_consumer_key'};
        !           245:     my @ltiroles;
        !           246:     if (ref($lti_by_key{$key}) eq 'ARRAY') {
        !           247:         foreach my $id (@{$lti_by_key{$key}}) {
        !           248:             if (ref($lti{$id}) eq 'HASH') {
        !           249:                 my $secret = $lti{$id}{'secret'};
        !           250:                 my $request = Net::OAuth->request('request token')->from_hash($params,
        !           251:                                                    request_url => $protocol.'://'.$hostname.$requri,
        !           252:                                                    request_method => $env{'request.method'},
        !           253:                                                    consumer_secret => $secret,);
        !           254:                 if ($request->verify()) {
        !           255:                     $itemid = $id;
        !           256:                     last;
        !           257:                 }
        !           258:             }
        !           259:         }
        !           260:     }
        !           261: 
        !           262: #
        !           263: # Request is invalid if the signed request could not be verified
        !           264: # for the Consumer key and Consumer secret from the domain
        !           265: # configuration in LON-CAPA for that LTI Consumer.
        !           266: #
        !           267:     unless (($itemid) && (ref($lti{$itemid}) eq 'HASH')) {
        !           268:         &invalid_request($r,6);
        !           269:         return OK;
        !           270:     }
        !           271: 
        !           272: #
        !           273: # Determine if nonce in POSTed data has expired.
        !           274: # If unexpired, confirm it has not already been used.
        !           275: #
        !           276:     unless (&check_nonce($r,$params->{'oauth_nonce'},$params->{'oauth_timestamp'},$lti{$itemid}{'lifetime'},$cdom)) {
        !           277:         &invalid_request($r,7);
        !           278:         return OK;
        !           279:     }
        !           280: 
        !           281: #
        !           282: # Determinine if source of username matches requirement from the 
        !           283: # domain configuration for the specific LTI Consumer.
        !           284: # 
        !           285: 
        !           286:     if ($lti{$itemid}{'mapuser'} eq $possmapuser) {
        !           287:         $uname = $possuname;
        !           288:     } elsif ($lti{$itemid}{'mapuser'} eq 'lis_person_sourcedid') {
        !           289:         if ($params->{'lis_person_sourcedid'} =~ /^$match_username$/) {
        !           290:             $uname = $possuname;
        !           291:         }
        !           292:     } elsif ($lti{$itemid}{'mapuser'} eq 'lis_person_contact_email_primary') {
        !           293:         if ($params->{'lis_person_contact_email_primary'} =~ /^$match_username$/) {
        !           294:             $uname = $params->{'lis_person_contact_email_primary'};
        !           295:         }
        !           296:     } elsif (exists($params->{$lti{$itemid}{'mapuser'}})) {
        !           297:         if ($params->{$lti{$itemid}{'mapuser'}} =~ /^$match_username$/) {
        !           298:             $uname = $params->{$lti{$itemid}{'mapuser'}};
        !           299:         }
        !           300:     }
        !           301: 
        !           302: #
        !           303: # Determine the courseID of the LON-CAPA course to which the
        !           304: # launch of LON-CAPA should provide access.
        !           305: #
        !           306: # Order is:
        !           307: #
        !           308: # (a) from course mapping (if the link between Consumer "course" and 
        !           309: # Provider "course" has been established previously).
        !           310: # (b) from tail of requested URL (after /adm/lti) if it has format of a symb
        !           311: # (c) from tail of requested URL (after /adm/lti) if it has format of a map
        !           312: # (d) from tail of requested URL (after /adm/lti) if it has format /domain/courseID
        !           313: # (e) from tail of requested URL (after /adm/lti) if it has format /tiny/domain/...
        !           314: # i.e., a shortened URL (see bug #6400) -- not implemented yet.
        !           315: #
        !           316: # If Consumer course included in POSTed data points as a target course which
        !           317: # has a format which matches a LON-CAPA courseID, but the course does not
        !           318: # exist, the request is invalid.
        !           319: # 
        !           320: 
        !           321:     my ($sourcecrs,%consumers);
        !           322:     if ($lti{$itemid}{'mapcrs'} eq 'course_offering_sourcedid') {
        !           323:         $sourcecrs = $params->{'course_offering_sourcedid'};
        !           324:     } elsif ($lti{$itemid}{'mapcrs'} eq 'context_id') {
        !           325:         $sourcecrs = $params->{'context_id'};
        !           326:     } elsif ($lti{$itemid}{'mapcrs'} ne '') {
        !           327:         $sourcecrs = $params->{$lti{$itemid}{'mapcrs'}};
        !           328:     }
        !           329: 
        !           330:     my $posscnum;
        !           331:     if ($sourcecrs ne '') {
        !           332:         %consumers = &Apache::lonnet::get_dom('lticonsumers',[$sourcecrs],$cdom);
        !           333:         if (exists($consumers{$sourcecrs})) {
        !           334:             if ($consumers{$sourcecrs} =~ /^$match_courseid$/) {
        !           335:                 my $crshome = &Apache::lonnet::homeserver($consumers{$sourcecrs},$cdom);
        !           336:                 if ($crshome =~ /(con_lost|no_host|no_such_host)/) {
        !           337:                     &invalid_request($r,8);
        !           338:                     return OK;
        !           339:                 } else {
        !           340:                     $posscnum = $consumers{$sourcecrs};
        !           341:                 }
        !           342:             }
        !           343:         }
        !           344:     }
        !           345: 
        !           346:     if ($urlcnum ne '') {
        !           347:         if ($posscnum ne '') {
        !           348:             if ($posscnum ne $urlcnum) {
        !           349:                 &invalid_request($r,9);
        !           350:                 return OK;
        !           351:             } else {
        !           352:                 $cnum = $posscnum;
        !           353:             }
        !           354:         } else {
        !           355:             my $crshome = &Apache::lonnet::homeserver($urlcnum,$cdom);
        !           356:             if ($crshome =~ /(con_lost|no_host|no_such_host)/) {
        !           357:                 &invalid_request($r,10);
        !           358:                 return OK;
        !           359:             } else {
        !           360:                 $cnum = $urlcnum;
        !           361:             }
        !           362:         }
        !           363:     } elsif ($posscnum ne '') {
        !           364:         $cnum = $posscnum;
        !           365:     }
        !           366: 
        !           367: #
        !           368: # Get LON-CAPA role to use from role-mapping of Consumer roles
        !           369: # defined in domain configuration for the appropriate LTI
        !           370: # Consumer.
        !           371: #
        !           372: # If multiple LON-CAPA roles are indicated, choose based
        !           373: # on the order: cc, in, ta, ep, st
        !           374: #
        !           375: 
        !           376:     my $reqrole;
        !           377: 
        !           378:     my @roleorder = ('cc','in','ta','ep','st');
        !           379:     if ($params->{'roles'} =~ /,/) {
        !           380:         @ltiroles = split(/\s*,\s*/,$params->{'role'});
        !           381:     } else {
        !           382:         my $singlerole = $params->{'roles'};
        !           383:         $singlerole =~ s/^\s|\s+$//g;
        !           384:         @ltiroles = ($singlerole);
        !           385:     }
        !           386:     if (@ltiroles) {
        !           387:         if (ref($lti{$itemid}{maproles}) eq 'HASH') {
        !           388:             my %possroles;
        !           389:             map { $possroles{$lti{$itemid}{maproles}{$_}} = 1; } @ltiroles;
        !           390:             my @possibles = keys(%possroles);
        !           391:             if (@possibles == 1) {
        !           392:                 if (grep(/^\Q$possibles[0]\E$/,@roleorder)) {
        !           393:                     $reqrole = $possibles[0];
        !           394: 
        !           395:                 }
        !           396:             } elsif (@possibles > 1) {
        !           397:                 foreach my $item (@roleorder) {
        !           398:                     if ($possroles{$item}) {
        !           399:                         $reqrole = $item;
        !           400:                         last;
        !           401:                     }
        !           402:                 }
        !           403:             }
        !           404:         }
        !           405:     }
        !           406: 
        !           407: #
        !           408: # If no LON-CAPA username  -- is user allowed to create one?
        !           409: #
        !           410: 
        !           411:     my $selfcreate;
        !           412:     if (($uname ne '') && ($udom ne '')) {
        !           413:         $uhome = &Apache::lonnet::homeserver($uname,$udom);
        !           414:         if ($uhome =~ /(con_lost|no_host|no_such_host)/) {
        !           415:             &Apache::lonnet::logthis(" LTI authorized unknown user $uname:$udom ");
        !           416:             if (ref($lti{$itemid}{'makeuser'}) eq 'ARRAY') {
        !           417:                 if (@{$lti{$itemid}{'makeuser'}} > 0) {
        !           418:                     foreach my $ltirole (@ltiroles) {
        !           419:                         if (grep(/^\Q$ltirole\E$/,@{$lti{$itemid}{'makeuser'}})) {
        !           420:                             $selfcreate = 1;
        !           421:                         }
        !           422:                     }
        !           423:                 }
        !           424:             }
        !           425:             if ($selfcreate) {
        !           426: #FIXME Do user creation here.
        !           427:                 return OK
        !           428:             } else {
        !           429:                 &invalid_request($r,11);
        !           430:                 return OK;
        !           431:             } 
        !           432:         } 
        !           433:     } else {
        !           434:         &invalid_request($r,12);
        !           435:         return OK;
        !           436:     }
        !           437: 
        !           438: #
        !           439: # If no LON-CAPA course available, check if domain's configuration
        !           440: # for the specific LTI Consumer allows a new course to be created 
        !           441: # (requires role in Consumer to be: Instructor).
        !           442: #
        !           443: 
        !           444:     if ($cnum eq '') {
        !           445:         if ((@ltiroles) && (grep(/^Instructor$/,@ltiroles)) &&
        !           446:             ($lti{$itemid}{'mapcrs'})) {
        !           447: #FIXME Create a new LON-CAPA course here.
        !           448:             return OK;
        !           449:         } else {
        !           450:             &invalid_request($r,13);
        !           451:             return OK; 
        !           452:         }
        !           453:     }
        !           454: 
        !           455: #
        !           456: # If LON-CAPA course is a Community, and LON-CAPA role
        !           457: # indicated is cc, change role indicated to co.
        !           458: # 
        !           459: 
        !           460:     if ($reqrole eq 'cc') {
        !           461:         if (($cdom ne '') && ($cnum ne '')) {
        !           462:             my %crsenv = &Apache::lonnet::coursedescription($cnum.'_'.$cdom,{ 'one_time' => 1,});
        !           463:             if ($crsenv{'type'} eq 'Community') {
        !           464:                 $reqrole = 'co'; 
        !           465:             }
        !           466:         }
        !           467:     }
        !           468: 
        !           469: #
        !           470: # Determine if user has required LON-CAPA role
        !           471: # in the mapped LON-CAPA course.
        !           472: #
        !           473: 
        !           474:     my $role;
        !           475:     my %crsroles = &Apache::lonnet::get_my_roles($uname,$udom,'userroles',undef,[$reqrole],[$cdom]);
        !           476:     if (exists($crsroles{$cnum.':'.$cdom.':'.$reqrole})) {
        !           477:         $role = $reqrole.'./'.$cdom.'/'.$cnum;
        !           478: #FIXME Need to accommodate sections
        !           479:     } elsif (ref($lti{$itemid}{'selfenroll'}) eq 'ARRAY') {
        !           480:         if (grep(/^\Q$reqrole\E$/,@{$lti{$itemid}{'selfenroll'}})) {
        !           481: #FIXME Do self-enrollment here
        !           482:             return OK;
        !           483:         } else {
        !           484:             &invalid_request($r,14);
        !           485:         }
        !           486:     }
        !           487: 
        !           488: #
        !           489: # Store consumer-to-LON-CAPA course mapping
        !           490: #
        !           491:     if (($sourcecrs ne '')  && ($consumers{$sourcecrs} eq '') && ($cnum ne '')) {
        !           492:         &Apache::lonnet::put_dom('lticonsumers',{ $sourcecrs => $cnum },$cdom);
        !           493:     }
        !           494: 
        !           495: #
        !           496: # Check if user should be hosted here or switched to another server.
        !           497: #
        !           498: 
        !           499:     &Apache::lonnet::logthis(" LTI authorized user: $uname:$udom role: $role course: $cnum:$cdom");
        !           500:     $r->user($uname);
        !           501:     my ($is_balancer,$otherserver,$hosthere);
        !           502:     ($is_balancer,$otherserver) =
        !           503:         &Apache::lonnet::check_loadbalancing($uname,$udom,'login');
        !           504:     if ($is_balancer) {
        !           505:         if ($otherserver eq '') {
        !           506:             my $lowest_load;
        !           507:             ($otherserver,undef,undef,undef,$lowest_load) = &Apache::lonnet::choose_server($udom);
        !           508:             if ($lowest_load > 100) {
        !           509:                 $otherserver = &Apache::lonnet::spareserver($lowest_load,$lowest_load,1,$udom);
        !           510:             }
        !           511:         }
        !           512:         if ($otherserver ne '') {
        !           513:             my @hosts = &Apache::lonnet::current_machine_ids();
        !           514:             if (grep(/^\Q$otherserver\E$/,@hosts)) {
        !           515:                 $hosthere = $otherserver;
        !           516:             }
        !           517:         }
        !           518:     }
        !           519:     if (($is_balancer) && (!$hosthere)) {
        !           520:         # login but immediately go to switch server.
        !           521:         &Apache::lonauth::success($r,$uname,$udom,$uhome,'noredirect');
        !           522:         if ($symb) {
        !           523:             $env{'form.symb'} = $symb;
        !           524:         }
        !           525:         if ($role) {
        !           526:             $env{'form.role'} = $role;
        !           527:         }
        !           528:         if ($lti{$itemid}{'passback'}) {
        !           529:             if ($params->{'lis_result_sourcedid'}) {
        !           530:                 $env{'request.lti.passbackid'} = $params->{'lis_result_sourcedid'};
        !           531:             }
        !           532:             if ($params->{'lis_outcome_service_url'}) {
        !           533:                 $env{'request.lti.passbackurl'} = $params->{'lis_outcome_service_url'};
        !           534:             }
        !           535:         }
        !           536:         if (($lti{$itemid}{'roster'}) && (grep(/^Instructor$/,@ltiroles))) {
        !           537:             if ($params->{'ext_ims_lis_memberships_id'}) {
        !           538:                 $env{'request.lti.rosterid'} = $params->{'ext_ims_lis_memberships_id'}; 
        !           539:             }
        !           540:             if ($params->{'ext_ims_lis_memberships_url'}) {
        !           541:                 $env{'request.lti.rosterurl'} = $params->{'ext_ims_lis_memberships_url'};
        !           542:             }
        !           543:         }
        !           544:         $env{'request.lti.login'} = 1;
        !           545:         foreach my $key (%{$params}) {
        !           546:             delete($env{'form.'.$key});
        !           547:         }
        !           548:         my $redirecturl = '/adm/switchserver';
        !           549:         if ($otherserver ne '') {
        !           550:             $redirecturl .= '?otherserver='.$otherserver;
        !           551:         }
        !           552:         $r->internal_redirect($redirecturl);
        !           553:         $r->set_handlers('PerlHandler'=> undef);
        !           554:     } else {
        !           555:         # need to login them in, so generate the need data that
        !           556:         # migrate expects to do login
        !           557:         foreach my $key (%{$params}) {
        !           558:             delete($env{'form.'.$key});
        !           559:         }
        !           560:         my $ip = $r->get_remote_host();
        !           561:         my %info=('ip'        => $ip,
        !           562:                   'domain'    => $udom,
        !           563:                   'username'  => $uname,
        !           564:                   'server'    => $lonhost,
        !           565:                   'lti.login' => 1,
        !           566:                  );
        !           567:         if ($role) {
        !           568:             $info{'role'} = $role;
        !           569:         }
        !           570:         if ($symb) {
        !           571:             $info{'symb'} = $symb; 
        !           572:         }
        !           573:         if ($lti{$itemid}{'passback'}) {
        !           574:             if ($params->{'lis_result_sourcedid'}) {
        !           575:                 $info{'lti.passbackid'} = $params->{'lis_result_sourcedid'}
        !           576:             }
        !           577:             if ($params->{'lis_outcome_service_url'}) {
        !           578:                 $info{'lti.passbackurl'} = $params->{'lis_outcome_service_url'}
        !           579:             }
        !           580:         }
        !           581:         if (($lti{$itemid}{'roster'}) && (grep(/^Instructor$/,@ltiroles))) {
        !           582:             if ($params->{'ext_ims_lis_memberships_id'}) {
        !           583:                 $info{'lti.rosterid'} = $params->{'ext_ims_lis_memberships_id'};
        !           584:             }
        !           585:             if ($params->{'ext_ims_lis_memberships_url'}) {
        !           586:                 $info{'lti.rosterurl'} = $params->{'ext_ims_lis_memberships_url'};
        !           587:             }
        !           588:         }
        !           589:         unless ($info{'symb'}) {
        !           590:             if ($mapurl) {
        !           591:                 $info{'origurl'} = $mapurl;
        !           592:                 if ($mapurl =~ m{/default_\d+\.sequence$}) {
        !           593:                     $info{'origurl'} .=  (($mapurl =~/\?/)?'&':'?').'navmap=1';
        !           594:                 }
        !           595:             } else {
        !           596:                 unless ($tail eq '/adm/roles') {
        !           597:                     $info{'origurl'} = '/adm/navmaps';
        !           598:                 }
        !           599:             }
        !           600:         }
        !           601:         if (($is_balancer) && ($hosthere)) {
        !           602:             $info{'noloadbalance'} = $hosthere;
        !           603:         }
        !           604:         my $token = &Apache::lonnet::tmpput(\%info,$lonhost);
        !           605:         $env{'form.token'} = $token;
        !           606:         $r->internal_redirect('/adm/migrateuser');
        !           607:         $r->set_handlers('PerlHandler'=> undef);
        !           608:     }
        !           609:     return OK;
        !           610: }
        !           611: 
        !           612: sub check_nonce {
        !           613:     my ($r,$nonce,$timestamp,$lifetime,$domain) = @_;
        !           614:     if (($timestamp eq '') || ($timestamp =~ /^\D/) || ($lifetime eq '') || ($lifetime =~ /\D/) || ($domain eq '')) {
        !           615:         return 0;
        !           616:     }
        !           617:     my $now = time;
        !           618:     if (($timestamp) && ($timestamp < ($now - $lifetime))) {
        !           619:         return 0;
        !           620:     }
        !           621:     if ($nonce eq '') {
        !           622:         return 0;
        !           623:     }
        !           624:     my $lonltidir = $r->dir_config('lonLTIDir');
        !           625:     if (-e "$lonltidir/$domain/$nonce") {
        !           626:         return 0;
        !           627:     } else {
        !           628:         unless (-e "$lonltidir/$domain") {
        !           629:             mkdir("$lonltidir/$domain",0755);
        !           630:         }  
        !           631:         if (open(my $fh,'>',"$lonltidir/$domain/$nonce")) {
        !           632:             print $fh $now;
        !           633:             close($fh);
        !           634:         } else {
        !           635:             return 0;
        !           636:         }
        !           637:     }
        !           638:     return 1;
        !           639: }
        !           640: 
        !           641: sub invalid_request {
        !           642:     my ($r,$num) = @_;
        !           643:     &Apache::loncommon::content_type($r,'text/html');
        !           644:     $r->send_http_header;
        !           645:     if ($r->header_only) {
        !           646:         return;
        !           647:     }
        !           648:     &Apache::lonlocal::get_language_handle($r);
        !           649:     $r->print(
        !           650:         &Apache::loncommon::start_page('Invalid LTI call').
        !           651:         &mt('Invalid LTI call [_1]',$num).
        !           652:         &Apache::loncommon::end_page());
        !           653:     return;
        !           654: }
        !           655: 
        !           656: 1;

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