Annotation of loncom/lti/ltiutils.pm, revision 1.20

1.1       raeburn     1: # The LearningOnline Network with CAPA
                      2: # Utility functions for managing LON-CAPA LTI interactions 
                      3: #
1.20    ! raeburn     4: # $Id: ltiutils.pm,v 1.19 2023/06/02 01:20:28 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 LONCAPA::ltiutils;
                     30: 
                     31: use strict;
                     32: use Net::OAuth;
                     33: use Digest::SHA;
1.17      raeburn    34: use Digest::MD5 qw(md5_hex);
1.18      raeburn    35: use Encode;
1.1       raeburn    36: use UUID::Tiny ':std';
                     37: use Apache::lonnet;
                     38: use Apache::loncommon;
1.11      raeburn    39: use Apache::loncoursedata;
                     40: use Apache::lonuserutils;
                     41: use Apache::lonenc();
                     42: use Apache::longroup();
1.12      raeburn    43: use Apache::lonlocal;
1.10      raeburn    44: use Math::Round();
1.19      raeburn    45: use LONCAPA::Lond;
1.1       raeburn    46: use LONCAPA qw(:DEFAULT :match);
                     47: 
                     48: #
                     49: # LON-CAPA as LTI Consumer or LTI Provider
                     50: #
                     51: # Determine if a nonce in POSTed data has expired.
                     52: # If unexpired, confirm it has not already been used.
                     53: #
                     54: # When LON-CAPA is operating as a Consumer, nonce checking
                     55: # occurs when a Tool Provider launched from an instance of
                     56: # an external tool in a LON-CAPA course makes a request to
                     57: # (a) /adm/service/roster or (b) /adm/service/passback to, 
                     58: # respectively, retrieve a roster or store the grade for 
                     59: # the original launch by a specific user.
                     60: #
                     61: # When LON-CAPA is operating as a Provider, nonce checking 
                     62: # occurs when a user in course context in another LMS (the 
1.4       raeburn    63: # Consumer) launches an external tool to access a LON-CAPA URL: 
1.1       raeburn    64: # /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.
                     65: #
                     66: 
                     67: sub check_nonce {
                     68:     my ($nonce,$timestamp,$lifetime,$domain,$ltidir) = @_;
                     69:     if (($ltidir eq '') || ($timestamp eq '') || ($timestamp =~ /^\D/) ||
                     70:         ($lifetime eq '') || ($lifetime =~ /\D/) || ($domain eq '')) {
                     71:         return;
                     72:     }
                     73:     my $now = time;
                     74:     if (($timestamp) && ($timestamp < ($now - $lifetime))) {
                     75:         return;
                     76:     }
                     77:     if ($nonce eq '') {
                     78:         return;
                     79:     }
                     80:     if (-e "$ltidir/$domain/$nonce") {
                     81:         return;
                     82:     } else  {
                     83:         unless (-e "$ltidir/$domain") {
                     84:             unless (mkdir("$ltidir/$domain",0755)) {
                     85:                 return;
                     86:             }
                     87:         }
                     88:         if (open(my $fh,'>',"$ltidir/$domain/$nonce")) {
                     89:             print $fh $now;
                     90:             close($fh);
                     91:             return 1;
                     92:         }
                     93:     }
                     94:     return;
                     95: }
                     96: 
                     97: #
                     98: # LON-CAPA as LTI Consumer
                     99: #
                    100: # Determine the domain and the courseID of the LON-CAPA course
                    101: # for which access is needed by a Tool Provider -- either to 
                    102: # retrieve a roster or store the grade for an instance of an 
                    103: # external tool in the course.
                    104: #
                    105: 
                    106: sub get_loncapa_course {
                    107:     my ($lonhost,$cid,$errors) = @_;
                    108:     return unless (ref($errors) eq 'HASH');
                    109:     my ($cdom,$cnum);
                    110:     if ($cid =~ /^($match_domain)_($match_courseid)$/) {
                    111:         my ($posscdom,$posscnum) = ($1,$2);
                    112:         my $cprimary_id = &Apache::lonnet::domain($posscdom,'primary');
                    113:         if ($cprimary_id eq '') {
                    114:             $errors->{5} = 1;
                    115:             return;
                    116:         } else {
                    117:             my @intdoms;
                    118:             my $internet_names = &Apache::lonnet::get_internet_names($lonhost);
                    119:             if (ref($internet_names) eq 'ARRAY') {
                    120:                 @intdoms = @{$internet_names};
                    121:             }
                    122:             my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);
                    123:             if  (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {
                    124:                 $cdom = $posscdom;
                    125:             } else {
                    126:                 $errors->{6} = 1;
                    127:                 return;
                    128:             }
                    129:         }
                    130:         my $chome = &Apache::lonnet::homeserver($posscnum,$posscdom);
                    131:         if ($chome =~ /(con_lost|no_host|no_such_host)/) {
                    132:             $errors->{7} = 1;
                    133:             return;
                    134:         } else {
                    135:             $cnum = $posscnum;
                    136:         }
                    137:     } else {
                    138:         $errors->{8} = 1;
                    139:         return;
                    140:     }
                    141:     return ($cdom,$cnum);
                    142: }
                    143: 
                    144: #
                    145: # LON-CAPA as LTI Consumer
                    146: #
                    147: # Determine the symb and (optionally) LON-CAPA user for an 
                    148: # instance of an external tool in a course -- either to 
                    149: # to retrieve a roster or store a grade.
                    150: #
                    151: # Use the digested symb to lookup the real symb in exttools.db
                    152: # and the digested userID to lookup the real userID (if needed).
                    153: # and extract the exttool instance and symb.
                    154: #
                    155: 
                    156: sub get_tool_instance {
                    157:     my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_;
                    158:     return unless (ref($errors) eq 'HASH');
                    159:     my ($marker,$symb,$uname,$udom);
                    160:     my @keys = ($digsymb); 
                    161:     if ($diguser) {
                    162:         push(@keys,$diguser);
                    163:     }
                    164:     my %digesthash = &Apache::lonnet::get('exttools',\@keys,$cdom,$cnum);
                    165:     if ($digsymb) {
                    166:         $symb = $digesthash{$digsymb};
                    167:         if ($symb) {
                    168:             my ($map,$id,$url) = split(/___/,$symb);
                    169:             $marker = (split(m{/},$url))[3];
                    170:             $marker=~s/\D//g;
                    171:         } else {
                    172:             $errors->{9} = 1;
                    173:         }
                    174:     }
                    175:     if ($diguser) {
                    176:         if ($digesthash{$diguser} =~ /^($match_username):($match_domain)$/) {
                    177:             ($uname,$udom) = ($1,$2);
                    178:         } else {
                    179:             $errors->{10} = 1;
                    180:         }
                    181:         return ($marker,$symb,$uname,$udom);
                    182:     } else {
                    183:         return ($marker,$symb);
                    184:     }
                    185: }
                    186: 
                    187: #
                    188: # LON-CAPA as LTI Consumer
                    189: #
                    190: # Retrieve data needed to validate a request from a Tool Provider
                    191: # for a roster or to store a grade for an instance of an external 
                    192: # tool in a LON-CAPA course.
                    193: #
                    194: # Retrieve the Consumer key and Consumer secret from the domain 
                    195: # configuration or the Tool Provider ID stored in the
                    196: # exttool_$marker db file and compare the Consumer key with the
                    197: # one in the POSTed data.
                    198: #
                    199: # Side effect is to populate the $toolsettings hashref with the 
                    200: # contents of the .db file (instance of tool in course) and the
                    201: # $ltitools hashref with the configuration for the tool (at
                    202: # domain level).
                    203: #
                    204: 
                    205: sub get_tool_secret {
                    206:     my ($key,$marker,$symb,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;
                    207:     return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&
                    208:                    (ref($errors) eq 'HASH'));
                    209:     my ($consumer_secret,$nonce_lifetime);
                    210:     if ($marker) {
                    211:         %{$toolsettings}=&Apache::lonnet::dump('exttool_'.$marker,$cdom,$cnum);
                    212:         if ($toolsettings->{'id'}) {
                    213:             my $idx = $toolsettings->{'id'};
1.19      raeburn   214:             my ($crsdef,$ltinum);
                    215:             if ($idx =~ /^c(\d+)$/) {
                    216:                 $ltinum = $1;
                    217:                 $crsdef = 1;
                    218:                 my %crslti = &Apache::lonnet::get_course_lti($cnum,$cdom,'consumer');
                    219:                 if (ref($crslti{$ltinum}) eq 'HASH') {
                    220:                     %{$ltitools} = %{$crslti{$ltinum}};
                    221:                 } else {
                    222:                     undef($ltinum);
                    223:                 }
                    224:             } elsif ($idx =~ /^\d+$/) {
                    225:                 my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');
                    226:                 if (ref($lti{$idx}) eq 'HASH') {
                    227:                     %{$ltitools} = %{$lti{$idx}};
                    228:                     $ltinum = $idx;
                    229:                 }
                    230:             }
                    231:             if ($ltinum ne '') {
                    232:                 my $loncaparev = &Apache::lonnet::get_server_loncaparev($cdom);
                    233:                 my $keynum = $ltitools->{'cipher'};
                    234:                 my ($poss_key,$poss_secret) =
                    235:                     &LONCAPA::Lond::get_lti_credentials($cdom,$cnum,$crsdef,'tools',$ltinum,$keynum,$loncaparev);
                    236:                 if ($poss_key eq $key) {
                    237:                     $consumer_secret = $poss_secret;
1.1       raeburn   238:                     $nonce_lifetime = $ltitools->{'lifetime'};
                    239:                 } else {
                    240:                     $errors->{11} = 1;
                    241:                     return;
                    242:                 }
                    243:             } else {
                    244:                 $errors->{12} = 1;
                    245:                 return;
                    246:             }
                    247:         } else {
                    248:             $errors->{13} = 1;
                    249:             return;
                    250:         }
                    251:     } else {
                    252:         $errors->{14};
                    253:         return;
                    254:     }
                    255:     return ($consumer_secret,$nonce_lifetime);
                    256: }
                    257: 
                    258: #
                    259: # LON-CAPA as LTI Consumer
                    260: #
                    261: # Verify a signed request using the consumer_key and
                    262: # secret for the specific LTI Provider.
                    263: #
                    264: 
1.19      raeburn   265: # FIXME Move to Lond.pm and perform on course's homeserver
                    266: 
1.1       raeburn   267: sub verify_request {
1.15      raeburn   268:     my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
                    269:         $authheaders,$errors) = @_;
                    270:     unless (ref($errors) eq 'HASH') {
                    271:         $errors->{15} = 1;
                    272:         return;
                    273:     }
                    274:     my $request;
                    275:     if ($oauthtype eq 'consumer') {
                    276:         my $oauthreq = Net::OAuth->request('consumer');
                    277:         $oauthreq->add_required_message_params('body_hash');
                    278:         $request = $oauthreq->from_authorization_header($authheaders,
                    279:                                   request_url => $protocol.'://'.$hostname.$requri,
                    280:                                   request_method => $reqmethod,
                    281:                                   consumer_secret => $consumer_secret,);
                    282:     } else {
                    283:         $request = Net::OAuth->request('request token')->from_hash($params,
                    284:                                   request_url => $protocol.'://'.$hostname.$requri,
                    285:                                   request_method => $reqmethod,
                    286:                                   consumer_secret => $consumer_secret,);
                    287:     }
1.1       raeburn   288:     unless ($request->verify()) {
                    289:         $errors->{15} = 1;
                    290:         return;
                    291:     }
                    292: }
                    293: 
                    294: #
                    295: # LON-CAPA as LTI Consumer
                    296: #
                    297: # Verify that an item identifier (either roster request:
                    298: # ext_ims_lis_memberships_id, or grade store:
                    299: # lis_result_sourcedid) has not been tampered with, and
                    300: # the secret used to create the unique identifier has not
                    301: # expired.
                    302: #
                    303: # Prepending the current secret (if still valid),
                    304: # or the previous secret (if current one is no longer valid),
                    305: # to a string composed of the :::-separated components
                    306: # must generate the result signature in the lis item ID
                    307: # sent by the Tool Provider.
                    308: #
                    309: 
                    310: sub verify_lis_item {
                    311:     my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;
                    312:     return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') && 
                    313:                    (ref($errors) eq 'HASH'));
                    314:     my ($has_action, $valid_for);
                    315:     if ($context eq 'grade') {
                    316:         $has_action = $ltitools->{'passback'};
1.14      raeburn   317:         $valid_for = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
1.1       raeburn   318:     } elsif ($context eq 'roster') {
                    319:         $has_action = $ltitools->{'roster'};
                    320:         $valid_for = $ltitools->{'rostervalid'};
                    321:     }
                    322:     if ($has_action) {
                    323:         my $secret;
                    324:         if (($toolsettings->{$context.'secretdate'} + $valid_for) > time) {
                    325:             $secret = $toolsettings->{$context.'secret'};
                    326:         } else {
                    327:             $secret = $toolsettings->{'old'.$context.'secret'};
                    328:         }
                    329:         if ($secret) {
                    330:             my $expected_sig;
                    331:             if ($context eq 'grade') {
                    332:                 my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;
1.5       raeburn   333:                 $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
1.1       raeburn   334:                 if ($expected_sig eq $sigrec) {
                    335:                     return 1;
                    336:                 } else {
1.15      raeburn   337:                     $errors->{18} = 1;
1.1       raeburn   338:                 }
                    339:             } elsif ($context eq 'roster') {
                    340:                 my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;
1.5       raeburn   341:                 $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
1.1       raeburn   342:                 if ($expected_sig eq $sigrec) {
                    343:                     return 1;
                    344:                 } else {
1.15      raeburn   345:                     $errors->{19} = 1;
1.1       raeburn   346:                 }
                    347:             }
                    348:         } else {
1.15      raeburn   349:             $errors->{20} = 1;
1.1       raeburn   350:         }
                    351:     } else {
1.15      raeburn   352:         $errors->{21} = 1;
1.1       raeburn   353:     }
                    354:     return;
                    355: }
                    356: 
                    357: #
                    358: # LON-CAPA as LTI Consumer
                    359: #
                    360: # Sign a request used to launch an instance of an external
1.4       raeburn   361: # tool in a LON-CAPA course, using the key and secret supplied 
1.1       raeburn   362: # by the Tool Provider.
                    363: # 
                    364: 
                    365: sub sign_params {
1.17      raeburn   366:     my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_;
1.1       raeburn   367:     return unless (ref($paramsref) eq 'HASH');
1.3       raeburn   368:     if ($sigmethod eq '') {
                    369:         $sigmethod = 'HMAC-SHA1';
                    370:     }
1.17      raeburn   371:     if ($type eq '') {
                    372:         $type = 'request token';
                    373:     }
                    374:     if ($callback eq '') {
                    375:         $callback = 'about:blank',
                    376:     }
1.9       raeburn   377:     srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
1.1       raeburn   378:     my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
1.17      raeburn   379:     my $request = Net::OAuth->request($type)->new(
1.1       raeburn   380:             consumer_key => $key,
                    381:             consumer_secret => $secret,
                    382:             request_url => $url,
                    383:             request_method => 'POST',
1.3       raeburn   384:             signature_method => $sigmethod,
1.1       raeburn   385:             timestamp => time,
                    386:             nonce => $nonce,
1.17      raeburn   387:             callback => $callback,
1.1       raeburn   388:             extra_params => $paramsref,
                    389:             version      => '1.0',
                    390:             );
1.15      raeburn   391:     $request->sign();
1.17      raeburn   392:     if ($post) {
                    393:         return $request->to_post_body();
                    394:     } else {
                    395:         return $request->to_hash();
                    396:     }
1.1       raeburn   397: }
                    398: 
                    399: #
                    400: # LON-CAPA as LTI Consumer
                    401: #
                    402: # Generate a signature for a unique identifier (roster request:
                    403: # ext_ims_lis_memberships_id, or grade store: lis_result_sourcedid)
                    404: #
                    405: 
                    406: sub get_service_id {
                    407:     my ($secret,$id) = @_;
                    408:     my $sig = Digest::SHA::sha1_hex($secret.':::'.$id);
                    409:     return $sig.':::'.$id;
                    410: }
                    411: 
                    412: #
                    413: # LON-CAPA as LTI Consumer
                    414: #
                    415: # Generate and store the time-limited secret used to create the
                    416: # signature in a service request identifier (roster request or
                    417: # grade store). An existing secret past its expiration date
                    418: # will be stored as old<service name>secret, and a new secret
                    419: # <service name>secret will be stored.
                    420: # 
                    421: # Secrets are specific to service name and to the tool instance 
                    422: # (and are stored in the exttool_$marker db file).
                    423: # The time period a secret remains valid is determined by the 
                    424: # domain configuration for the specific tool and the service.
                    425: # 
                    426: 
                    427: sub set_service_secret {
                    428:     my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_;
                    429:     return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH'));
                    430:     my $warning;
                    431:     my ($needsnew,$oldsecret,$lifetime);
                    432:     if ($name eq 'grade') {
1.14      raeburn   433:         $lifetime = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
1.1       raeburn   434:     } elsif ($name eq 'roster') {
                    435:         $lifetime = $ltitools->{'rostervalid'};
                    436:     }
1.14      raeburn   437:     if ($toolsettings->{$name.'secret'} eq '') {
1.1       raeburn   438:         $needsnew = 1;
1.14      raeburn   439:     } elsif (($toolsettings->{$name.'secretdate'} + $lifetime) < $now) {
1.1       raeburn   440:         $oldsecret = $toolsettings->{$name.'secret'};
                    441:         $needsnew = 1;
                    442:     }
                    443:     if ($needsnew) {
                    444:         if (&get_tool_lock($cdom,$cnum,$marker,$name,$now) eq 'ok') {
                    445:             my $secret = UUID::Tiny::create_uuid_as_string(UUID_V4);
                    446:             $toolsettings->{$name.'secret'} = $secret;
                    447:             my %secrethash = (
                    448:                            $name.'secret' => $secret,
                    449:                            $name.'secretdate' => $now,
                    450:                           );
                    451:             if ($oldsecret ne '') {
                    452:                 $secrethash{'old'.$name.'secret'} = $oldsecret;
                    453:             }
                    454:             my $putres = &Apache::lonnet::put('exttool_'.$marker,
                    455:                                               \%secrethash,$cdom,$cnum);
                    456:             my $delresult = &release_tool_lock($cdom,$cnum,$marker,$name);
                    457:             if ($delresult ne 'ok') {
                    458:                 $warning = $delresult ;
                    459:             }
                    460:             if ($putres eq 'ok') {
                    461:                 return 'ok';
                    462:             }
                    463:         } else {
                    464:             $warning = 'Could not obtain exclusive lock';
                    465:         }
                    466:     } else {
                    467:         return 'ok';
                    468:     }
                    469:     return;
                    470: }
                    471: 
                    472: #
                    473: # LON-CAPA as LTI Consumer
                    474: #
                    475: # Add a lock key to exttools.db for the instance of an external tool 
                    476: # when generating and storing a service secret.
                    477: #
                    478: 
                    479: sub get_tool_lock {
                    480:     my ($cdom,$cnum,$marker,$name,$now) = @_;
                    481:     # get lock for tool for which secret is being set
                    482:     my $lockhash = {
                    483:                      $name."\0".$marker."\0".'lock' => $now.':'.$env{'user.name'}.
                    484:                                                        ':'.$env{'user.domain'},
                    485:                    };
                    486:     my $tries = 0;
                    487:     my $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);
                    488: 
                    489:     while (($gotlock ne 'ok') && $tries <3) {
                    490:         $tries ++;
                    491:         sleep(1);
                    492:         $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);
                    493:     }
                    494:     return $gotlock;
                    495: }
                    496: 
                    497: #
                    498: # LON-CAPA as LTI Consumer
                    499: #
                    500: # Remove a lock key from exttools.db for the instance of an external
                    501: # tool created when generating and storing a service secret.
                    502: #
                    503: 
                    504: sub release_tool_lock {
1.3       raeburn   505:     my ($cdom,$cnum,$marker,$name) = @_;
1.1       raeburn   506:     #  remove lock
                    507:     my @del_lock = ($name."\0".$marker."\0".'lock');
                    508:     my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);
                    509:     if ($dellockoutcome ne 'ok') {
                    510:         return 'Warning: failed to release lock for exttool';
                    511:     } else {
                    512:         return 'ok';
                    513:     }
                    514: }
                    515: 
1.6       raeburn   516: #
1.15      raeburn   517: # LON-CAPA as LTI Consumer
                    518: #
                    519: # Parse XML containing grade data sent by an LTI Provider
                    520: #
                    521: 
                    522: sub parse_grade_xml {
                    523:     my ($xml) = @_;
                    524:     my %data = ();
                    525:     my $count = 0;
                    526:     my @state = ();
                    527:     my $p = HTML::Parser->new(
                    528:         xml_mode => 1,
                    529:         start_h =>
                    530:             [sub {
                    531:                 my ($tagname, $attr) = @_;
                    532:                 push(@state,$tagname);
                    533:                 if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord") {
                    534:                     $count ++;
                    535:                 }
                    536:             }, "tagname, attr"],
                    537:         text_h =>
                    538:             [sub {
                    539:                 my ($text) = @_;
                    540:                 if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord sourcedGUID sourcedId") {
                    541:                     $data{$count}{sourcedid} = $text;
                    542:                 } elsif ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord result resultScore textString") {                               
                    543:                     $data{$count}{score} = $text;
                    544:                 }
                    545:             }, "dtext"],
                    546:         end_h =>
                    547:             [sub {
                    548:                  my ($tagname) = @_;
                    549:                  pop @state;
                    550:                 }, "tagname"],
                    551:     );
                    552:     $p->parse($xml);
                    553:     $p->eof;
                    554:     return %data;
                    555: }
                    556: 
                    557: #
1.6       raeburn   558: # LON-CAPA as LTI Provider
                    559: #
                    560: # Use the part of the launch URL after /adm/lti to determine
                    561: # the scope for the current session (i.e., restricted to a
                    562: # single resource, to a single folder/map, or to an entire
                    563: # course).
                    564: #
                    565: # Returns an array containing scope: resource, map, or course
                    566: # and the LON-CAPA URL that is displayed post-launch, including
                    567: # accommodation of URL encryption, and translation of a tiny URL
                    568: # to the actual URL
                    569: #
                    570: 
                    571: sub lti_provider_scope {
1.10      raeburn   572:     my ($tail,$cdom,$cnum,$getunenc) = @_;
                    573:     my ($scope,$realuri,$passkey,$unencsymb);
                    574:     if ($tail =~ m{^/?uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {
1.6       raeburn   575:         my $rest = $1;
                    576:         if ($rest eq '') {
                    577:             $scope = 'map';
                    578:             $realuri = $tail;
                    579:         } else {
1.13      raeburn   580:             my $symb = $tail;
                    581:             $symb =~ s{^/}{};
                    582:             my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
1.6       raeburn   583:             $realuri = &Apache::lonnet::clutter($url);
1.7       raeburn   584:             if ($url =~ /\.sequence$/) {
                    585:                 $scope = 'map';
1.6       raeburn   586:             } else {
1.7       raeburn   587:                 $scope = 'resource';
1.13      raeburn   588:                 $realuri .= '?symb='.$symb;
                    589:                 $passkey = $symb;
1.10      raeburn   590:                 if ($getunenc) {
1.13      raeburn   591:                     $unencsymb = $symb;
1.10      raeburn   592:                 }
1.6       raeburn   593:             }
                    594:         }
1.10      raeburn   595:     } elsif ($tail =~ m{^/?res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) {
1.8       raeburn   596:         my $rest = $1;
                    597:         if ($rest eq '') {
                    598:             $scope = 'map';
                    599:             $realuri = $tail;
                    600:         } else {
1.13      raeburn   601:             my $symb = $tail;
                    602:             $symb =~ s{^/?res/}{};
                    603:             my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
1.8       raeburn   604:             $realuri = &Apache::lonnet::clutter($url);
                    605:             if ($url =~ /\.sequence$/) {
                    606:                 $scope = 'map';
                    607:             } else {
                    608:                 $scope = 'resource';
1.13      raeburn   609:                 $realuri .= '?symb='.$symb;
                    610:                 $passkey = $symb;
1.10      raeburn   611:                 if ($getunenc) {
1.13      raeburn   612:                     $unencsymb = $symb;
1.10      raeburn   613:                 }
1.8       raeburn   614:             }
                    615:         }
1.6       raeburn   616:     } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) {
                    617:         my $key = $1;
                    618:         my $tinyurl;
                    619:         my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
                    620:         if (defined($cached)) {
                    621:             $tinyurl = $result;
                    622:         } else {
                    623:             my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
                    624:             my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
                    625:             if ($currtiny{$key} ne '') {
                    626:                 $tinyurl = $currtiny{$key};
                    627:                 &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
                    628:             }
                    629:         }
                    630:         if ($tinyurl ne '') {
                    631:             my ($cnum,$symb) = split(/\&/,$tinyurl,2);
                    632:             my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
                    633:             if ($url =~ /\.(page|sequence)$/) {
                    634:                 $scope = 'map';
                    635:             } else {
                    636:                 $scope = 'resource';
                    637:             }
1.10      raeburn   638:             $passkey = $symb;
1.6       raeburn   639:             if ((&Apache::lonnet::EXT('resource.0.encrypturl',$symb) =~ /^yes$/i) &&
                    640:                 (!$env{'request.role.adv'})) {
                    641:                 $realuri = &Apache::lonenc::encrypted(&Apache::lonnet::clutter($url));
1.7       raeburn   642:                 if ($scope eq 'resource') {
1.6       raeburn   643:                     $realuri .= '?symb='.&Apache::lonenc::encrypted($symb);
                    644:                 }
                    645:             } else {
                    646:                 $realuri = &Apache::lonnet::clutter($url);
1.7       raeburn   647:                 if ($scope eq 'resource') {
1.6       raeburn   648:                     $realuri .= '?symb='.$symb;
                    649:                 }
                    650:             }
1.10      raeburn   651:             if ($getunenc) {
                    652:                 $unencsymb = $symb;
                    653:             }
1.6       raeburn   654:         }
1.10      raeburn   655:     } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) {
1.6       raeburn   656:         $scope = 'course';
                    657:         $realuri = '/adm/navmaps';
1.13      raeburn   658:         $passkey = '';
1.10      raeburn   659:     }
                    660:     if ($scope eq 'map') {
                    661:         $passkey = $realuri;
                    662:     }
                    663:     if (wantarray) {
                    664:         return ($scope,$realuri,$unencsymb);
                    665:     } else {
                    666:         return $passkey;
                    667:     }
                    668: }
                    669: 
1.12      raeburn   670: #
                    671: # LON-CAPA as LTI Provider
                    672: #
                    673: # Obtain a list of course personnel and students from
                    674: # the LTI Consumer which launched this instance.
                    675: #
                    676: 
1.11      raeburn   677: sub get_roster {
1.19      raeburn   678:     my ($cdom,$cnum,$ltinum,$keynum,$id,$url) = @_;
1.11      raeburn   679:     my %ltiparams = (
                    680:         lti_version                => 'LTI-1p0',
                    681:         lti_message_type           => 'basic-lis-readmembershipsforcontext',
                    682:         ext_ims_lis_memberships_id => $id,
                    683:     );
1.19      raeburn   684:     my %info = ();
                    685:     my ($status,$hashref) =
                    686:         &Apache::lonnet::sign_lti($cdom,$cnum,'','lti','roster',$url,$ltinum,$keynum,\%ltiparams,\%info);
                    687:     if (($status eq 'ok') && (ref($hashref) eq 'HASH')) {
1.11      raeburn   688:         my $request=new HTTP::Request('POST',$url);
                    689:         $request->content(join('&',map {
                    690:                           my $name = escape($_);
                    691:                           "$name=" . ( ref($hashref->{$_}) eq 'ARRAY'
                    692:                           ? join("&$name=", map {escape($_) } @{$hashref->{$_}})
                    693:                           : &escape($hashref->{$_}) );
                    694:         } keys(%{$hashref})));
                    695:         my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
                    696:         my $message=$response->status_line;
                    697:         if (($response->is_success) && ($response->content ne '')) {
                    698:             my %data = ();
                    699:             my $count = 0;
                    700:             my @state = ();
                    701:             my @items = ('user_id','roles','person_sourcedid','person_name_given','person_name_family',
                    702:                          'person_contact_email_primary','person_name_full','lis_result_sourcedid');
                    703:             my $p = HTML::Parser->new
                    704:             (
                    705:              xml_mode => 1,
                    706:              start_h =>
                    707:                  [sub {
                    708:                      my ($tagname, $attr) = @_;
                    709:                      push(@state,$tagname);
                    710:                      if ("@state" eq "message_response memberships member") {
                    711:                          $count ++;
                    712:                      }
                    713:                  }, "tagname, attr"],
                    714:              text_h =>
                    715:                 [sub {
                    716:                      my ($text) = @_;
                    717:                      foreach my $item (@items) {
                    718:                          if ("@state" eq "message_response memberships member $item") {
                    719:                              $data{$count}{$item} = $text;
                    720:                          }
                    721:                      }
                    722:                    }, "dtext"],
                    723:              end_h =>
                    724:                  [sub {
                    725:                      my ($tagname) = @_;
                    726:                      pop @state;
                    727:                     }, "tagname"],
                    728:             );
                    729:             $p->parse($response->content);
                    730:             $p->eof;
                    731:             return %data;
                    732:         }
                    733:     }
                    734:     return;
                    735: }
                    736: 
1.12      raeburn   737: #
                    738: # LON-CAPA as LTI Provider
                    739: #
                    740: # Passback a grade for a user to the LTI Consumer which originally
                    741: # provided the lis_result_sourcedid
                    742: #
                    743: 
1.10      raeburn   744: sub send_grade {
1.19      raeburn   745:     my ($cdom,$cnum,$crsdef,$type,$ltinum,$keynum,$id,$url,$scoretype,$sigmethod,$msgformat,$total,$possible) = @_;
1.10      raeburn   746:     my $score;
                    747:     if ($possible > 0) {
                    748:         if ($scoretype eq 'ratio') {
                    749:             $score = Math::Round::round($total).'/'.Math::Round::round($possible);
                    750:         } elsif ($scoretype eq 'percentage') {
                    751:             $score = (100.0*$total)/$possible;
                    752:             $score = Math::Round::round($score);
                    753:         } else {
                    754:             $score = $total/$possible;
1.20    ! raeburn   755:             $score = sprintf("%.4f",$score);
1.10      raeburn   756:         }
                    757:     }
1.15      raeburn   758:     if ($sigmethod eq '') {
                    759:         $sigmethod = 'HMAC-SHA1';
                    760:     }
                    761:     my $request;
                    762:     if ($msgformat eq '1.0') {
                    763:         my $date = &Apache::loncommon::utc_string(time);
                    764:         my %ltiparams = (
                    765:             lti_version                   => 'LTI-1p0',
                    766:             lti_message_type              => 'basic-lis-updateresult',
                    767:             sourcedid                     => $id,
                    768:             result_resultscore_textstring => $score,
                    769:             result_resultscore_language   => 'en-US',
                    770:             result_resultvaluesourcedid   => $scoretype,
                    771:             result_statusofresult         => 'final',
                    772:             result_date                   => $date,
                    773:         );
1.19      raeburn   774:         my %info = (
                    775:                         method => $sigmethod,
                    776:                    ); 
                    777:         my ($status,$hashref) =
                    778:             &Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,
                    779:                                       \%ltiparams,\%info);   
                    780:         if (($status eq 'ok') && (ref($hashref) eq 'HASH')) {
1.15      raeburn   781:             $request=new HTTP::Request('POST',$url);
                    782:             $request->content(join('&',map {
                    783:                               my $name = escape($_);
                    784:                               "$name=" . ( ref($hashref->{$_}) eq 'ARRAY'
                    785:                               ? join("&$name=", map {escape($_) } @{$hashref->{$_}})
                    786:                               : &escape($hashref->{$_}) );
                    787:                               } keys(%{$hashref})));
1.19      raeburn   788: #FIXME Need to handle case where passback failed.
1.15      raeburn   789:         }
                    790:     } else {
                    791:         srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
                    792:         my $uniqmsgid = int(rand(2**32));
                    793:         my $gradexml = <<END;
                    794: <?xml version = "1.0" encoding = "UTF-8"?>
                    795: <imsx_POXEnvelopeRequest xmlns = "http://www.imsglobal.org/services/ltiv1p1/xsd/imsoms_v1p0">
                    796:   <imsx_POXHeader>
                    797:     <imsx_POXRequestHeaderInfo>
                    798:       <imsx_version>V1.0</imsx_version>
                    799:       <imsx_messageIdentifier>$uniqmsgid</imsx_messageIdentifier>
                    800:     </imsx_POXRequestHeaderInfo>
                    801:   </imsx_POXHeader>
                    802:   <imsx_POXBody>
                    803:     <replaceResultRequest>
                    804:       <resultRecord>
                    805: 	<sourcedGUID>
                    806: 	  <sourcedId>$id</sourcedId>
                    807: 	</sourcedGUID>
                    808: 	<result>
                    809: 	  <resultScore>
                    810: 	    <language>en</language>
                    811: 	    <textString>$score</textString>
                    812: 	  </resultScore>
                    813: 	</result>
                    814:       </resultRecord>
                    815:     </replaceResultRequest>
                    816:   </imsx_POXBody>
                    817: </imsx_POXEnvelopeRequest>
                    818: END
                    819:         chomp($gradexml);
                    820:         my $bodyhash = Digest::SHA::sha1_base64($gradexml);
                    821:         while (length($bodyhash) % 4) {
                    822:             $bodyhash .= '=';
                    823:         }
1.19      raeburn   824:         my $reqmethod = 'POST';
                    825:         my %info = (
                    826:                       body_hash => $bodyhash,
                    827:                       method => $sigmethod,
                    828:                       reqtype => 'consumer',
                    829:                       reqmethod => $reqmethod,
                    830:                       respfmt => 'to_authorization_header',
                    831:                    );
                    832:         my %params;
                    833:         my ($status,$authheader) =
                    834:             &Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,\%params,\%info);
                    835:         if (($status eq 'ok') && ($authheader ne '')) {
                    836:             $request = HTTP::Request->new(
                    837: 	                   $reqmethod,
                    838: 	                   $url,
                    839: 	                   [
                    840: 		              'Authorization' => $authheader,
                    841: 		              'Content-Type'  => 'application/xml',
                    842: 	                   ],
                    843: 	                   $gradexml,
                    844:             );
                    845:             my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
                    846:             my $message=$response->status_line;
                    847: #FIXME Handle case where pass back of score to LTI Consumer failed.
                    848:         }
1.15      raeburn   849:     }
1.6       raeburn   850: }
                    851: 
1.17      raeburn   852: sub setup_logout_callback {
1.19      raeburn   853:     my ($cdom,$cnum,$crstool,$idx,$keynum,$uname,$udom,$server,$service_url,$idsdir,$protocol,$hostname) = @_;
1.17      raeburn   854:     if ($service_url =~ m{^https?://[^/]+/}) {
1.18      raeburn   855:         my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);
1.17      raeburn   856:         my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));
                    857:         if ((-d $idsdir) && (open(my $fh,'>',"$idsdir/$loginfile"))) {
                    858:             print $fh "$uname,$udom,$server\n";
                    859:             close($fh);
                    860:             my $callback = 'http://'.$hostname.'/adm/service/logout/'.$loginfile;
                    861:             my %ltiparams = (
                    862:                 callback   => $callback,
                    863:             );
1.19      raeburn   864:             my %info = (
                    865:                 respfmt => 'to_post_body',
                    866:             );
                    867:             my ($status,$post) = 
                    868:                 &Apache::lonnet::sign_lti($cdom,$cnum,$crstool,'lti','logout',$service_url,$idx,
                    869:                                           $keynum,\%ltiparams,\%info);
                    870:             if (($status eq 'ok') && ($post ne '')) {
                    871:                 my $request=new HTTP::Request('POST',$service_url);
                    872:                 $request->content($post);
                    873:                 my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
                    874:             }
1.17      raeburn   875:         }
                    876:     }
                    877:     return;
                    878: }
                    879: 
1.12      raeburn   880: #
                    881: # LON-CAPA as LTI Provider
                    882: #
                    883: # Create a new user in LON-CAPA. If the domain's configuration 
                    884: # includes rules for format of "official" usernames, those rules
                    885: # will apply when determining if a user is to be created.  In
                    886: # additional if institutional user information is available that
                    887: # will be used when creating a new user account.
                    888: #
                    889: 
1.11      raeburn   890: sub create_user {
                    891:     my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results,
                    892:         $curr_rules,$got_rules) = @_;
                    893:     return unless (ref($ltiref) eq 'HASH');
                    894:     my $checkhash = { "$uname:$udom" => { 'newuser' => 1, }, };
                    895:     my $checks = { 'username' => 1, };
                    896:     my ($lcauth,$lcauthparm);
                    897:     &Apache::loncommon::user_rule_check($checkhash,$checks,$alerts,$rulematch,
                    898:                                         $inst_results,$curr_rules,$got_rules);
                    899:     my ($userchkmsg,$lcauth,$lcauthparm);
                    900:     my $allowed = 1;
                    901:     if (ref($alerts->{'username'}) eq 'HASH') {
                    902:          if (ref($alerts->{'username'}{$udom}) eq 'HASH') {
                    903:              if ($alerts->{'username'}{$udom}{$uname}) {
                    904:                  if (ref($curr_rules->{$udom}) eq 'HASH') {
                    905:                      $userchkmsg =
                    906:                          &Apache::loncommon::instrule_disallow_msg('username',$domdesc,1).
                    907:                          &Apache::loncommon::user_rule_formats($udom,$domdesc,
                    908:                                                                $curr_rules->{$udom}{'username'},
                    909:                                                                'username');
                    910:                  }
                    911:                  $allowed = 0;
                    912:              }
                    913:          }
                    914:     }
                    915:     if ($allowed) {
                    916:         if (ref($rulematch->{$uname.':'.$udom}) eq 'HASH') {
                    917:             my $matchedrule = $rulematch->{$uname.':'.$udom}{'username'};
                    918:             my ($rules,$ruleorder) =
                    919:                 &Apache::lonnet::inst_userrules($udom,'username');
                    920:             if (ref($rules) eq 'HASH') {
                    921:                 if (ref($rules->{$matchedrule}) eq 'HASH') {
                    922:                     $lcauth = $rules->{$matchedrule}{'authtype'};
                    923:                     $lcauthparm = $rules->{$matchedrule}{'authparm'};
                    924:                 }
                    925:             }
                    926:         }
                    927:         if ($lcauth eq '') {
                    928:             $lcauth = $ltiref->{'lcauth'};
                    929:             if ($lcauth eq 'internal') {
                    930:                 $lcauthparm = &create_passwd();
                    931:             } else {
                    932:                 $lcauthparm = $ltiref->{'lcauthparm'};
                    933:             }
                    934:         }
                    935:     } else {
                    936:         return 'notallowed';
                    937:     }
                    938:     my @userinfo = ('firstname','middlename','lastname','generation','permanentemail','id');
                    939:     my (%useinstdata,%info);
                    940:     if (ref($ltiref->{'instdata'}) eq 'ARRAY') {
                    941:         map { $useinstdata{$_} = 1; } @{$ltiref->{'instdata'}};
                    942:     }
                    943:     foreach my $item (@userinfo) {
                    944:         if (($useinstdata{$item}) && (ref($inst_results->{$uname.':'.$udom}) eq 'HASH') &&
                    945:             ($inst_results->{$uname.':'.$udom}{$item} ne '')) {
                    946:             $info{$item} = $inst_results->{$uname.':'.$udom}{$item};
                    947:         } else {
                    948:             if ($item eq 'permanentemail') {
                    949:                 if ($data->{'permanentemail'} =~/^[^\@]+\@[^@]+$/) {
                    950:                     $info{$item} = $data->{'permanentemail'};
                    951:                 }
                    952:             } elsif (($item eq 'firstname') || ($item eq 'lastname')) {
                    953:                 $info{$item} = $data->{$item};
                    954:             }
                    955:         }
                    956:     }
                    957:     if (($info{'middlename'} eq '') && ($data->{'fullname'} ne '')) {
                    958:         unless ($useinstdata{'middlename'}) {
                    959:             my $fullname = $data->{'fullname'};
                    960:             if ($info{'firstname'}) {
                    961:                 $fullname =~ s/^\s*\Q$info{'firstname'}\E\s*//i;
                    962:             }
                    963:             if ($info{'lastname'}) {
                    964:                 $fullname =~ s/\s*\Q$info{'lastname'}\E\s*$//i;
                    965:             }
                    966:             if ($fullname ne '') {
                    967:                 $fullname =~ s/^\s+|\s+$//g;
                    968:                 if ($fullname ne '') {
                    969:                     $info{'middlename'} = $fullname;
                    970:                 }
                    971:             }
                    972:         }
                    973:     }
                    974:     if (ref($inst_results->{$uname.':'.$udom}{'inststatus'}) eq 'ARRAY') {
                    975:         my @inststatuses = @{$inst_results->{$uname.':'.$udom}{'inststatus'}};
                    976:         $info{'inststatus'} = join(':',map { &escape($_); } @inststatuses);
                    977:     }
                    978:     my $result =
                    979:         &Apache::lonnet::modifyuser($udom,$uname,$info{'id'},
                    980:                                     $lcauth,$lcauthparm,$info{'firstname'},
                    981:                                     $info{'middlename'},$info{'lastname'},
                    982:                                     $info{'generation'},undef,undef,
                    983:                                     $info{'permanentemail'},$info{'inststatus'});
                    984:     return $result;
                    985: }
                    986: 
1.12      raeburn   987: #
                    988: # LON-CAPA as LTI Provider
                    989: #
                    990: # Create a password for a new user if the authentication
                    991: # type to assign to new users created following LTI launch is
                    992: # to be LON-CAPA "internal".
                    993: #
                    994: 
1.11      raeburn   995: sub create_passwd {
                    996:     my $passwd = '';
1.12      raeburn   997:     srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
1.11      raeburn   998:     my @letts = ("a".."z");
                    999:     for (my $i=0; $i<8; $i++) {
                   1000:         my $lettnum = int(rand(2));
                   1001:         my $item = '';
                   1002:         if ($lettnum) {
                   1003:             $item = $letts[int(rand(26))];
                   1004:             my $uppercase = int(rand(2));
                   1005:             if ($uppercase) {
                   1006:                 $item =~ tr/a-z/A-Z/;
                   1007:             }
                   1008:         } else {
                   1009:             $item = int(rand(10));
                   1010:         }
                   1011:         $passwd .= $item;
                   1012:     }
                   1013:     return ($passwd);
                   1014: }
                   1015: 
1.12      raeburn  1016: #
                   1017: # LON-CAPA as LTI Provider
                   1018: #
                   1019: # Enroll a user in a LON-CAPA course, with the specified role and (optional)
                   1020: # section.  If this is a self-enroll case, i.e., a user launched the LTI tool
                   1021: # in the Consumer, user privs will be added to the user's environment for
                   1022: # the new role.
                   1023: #
                   1024: # If this is a self-enroll case, a Course Coordinator role will only be assigned 
                   1025: # if the current user is also the course owner.
                   1026: #
                   1027: 
1.11      raeburn  1028: sub enrolluser {
1.12      raeburn  1029:     my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end,$selfenroll) = @_;
1.11      raeburn  1030:     my $enrollresult;
                   1031:     my $area = "/$cdom/$cnum";
                   1032:     if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) {
                   1033:         $area .= '/'.$sec;
                   1034:     }
                   1035:     my $spec = $role.'.'.$area;
                   1036:     my $instcid;
                   1037:     if ($role eq 'st') {
                   1038:         $enrollresult =
                   1039:             &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,
                   1040:                                                        undef,undef,$sec,$end,$start,
1.12      raeburn  1041:                                                        'ltienroll',undef,$cdom.'_'.$cnum,
                   1042:                                                        $selfenroll,'ltienroll','',$instcid);
1.11      raeburn  1043:     } elsif ($role =~ /^(cc|in|ta|ep)$/) {
                   1044:         $enrollresult =
                   1045:             &Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start,
1.12      raeburn  1046:                                         undef,$selfenroll,'ltienroll');
                   1047:     }
                   1048:     if ($enrollresult eq 'ok') {
                   1049:         if ($selfenroll) {
                   1050:             my (%userroles,%newrole,%newgroups);
                   1051:             &Apache::lonnet::standard_roleprivs(\%newrole,$role,$cdom,$spec,$cnum,
                   1052:                                                 $area);
                   1053:             &Apache::lonnet::set_userprivs(\%userroles,\%newrole,\%newgroups);
                   1054:             $userroles{'user.role.'.$spec} = $start.'.'.$end;
                   1055:             &Apache::lonnet::appenv(\%userroles,[$role,'cm']);
                   1056:         }
1.11      raeburn  1057:     }
                   1058:     return $enrollresult;
                   1059: }
                   1060: 
1.12      raeburn  1061: #
                   1062: # LON-CAPA as LTI Provider
                   1063: #
                   1064: # Batch addition of users following LTI launch by a user
                   1065: # with LTI Instructor status.
                   1066: #
                   1067: # A list of users is obtained by a call to get_roster()
                   1068: # if the calling Consumer support the LTI extension: 
                   1069: # Context Memberships Service. 
                   1070: #
                   1071: # If a user included in the retrieved list does not currently
                   1072: # have a user account in LON-CAPA, an account will be created.
                   1073: #
                   1074: # If a user already has an account, and the same role and
                   1075: # section assigned (currently active), then no change will
                   1076: # be made for that user.
                   1077: #
                   1078: # Information available for new users (besides username and)
                   1079: # role) may include: first name, last name, full name (from
                   1080: # which middle name will be extracted), permanent e-mail address,
                   1081: # and lis_result_sourcedid (for passback of grades).
                   1082: #
                   1083: # If grades are to be passed back, the passback url will be
                   1084: # the same as for the current user's session.
                   1085: #
                   1086: # The roles which may be assigned will be determined from the
                   1087: # LTI roles included in the retrieved roster, and the mapping
                   1088: # of LTI roles to LON-CAPA roles configured for this LTI Consumer
                   1089: # in the domain configuration.
                   1090: #
                   1091: # Course Coordinator roles will only be assigned if the current
                   1092: # user is also the course owner.
                   1093: #
                   1094: # The domain configuration for the corresponding Consumer can include
                   1095: # a section to assign to LTI users. If the roster includes students
                   1096: # any existing student roles with a different section will be expired,
                   1097: # and a role in the LTI section will be assigned.
                   1098: #
                   1099: # For non-student rules (excluding Course Coordinator) a role will be
                   1100: # assigned with the LTI section )or no section, if one is not rquired.
                   1101: #
                   1102: 
1.11      raeburn  1103: sub batchaddroster {
                   1104:     my ($item) = @_;
1.19      raeburn  1105:     return unless((ref($item) eq 'HASH') &&
                   1106:                   (ref($item->{'ltiref'}) eq 'HASH'));
1.11      raeburn  1107:     my ($cdom,$cnum) = split(/_/,$item->{'cid'});
1.19      raeburn  1108:     return if (($cdom eq '') || ($cnum eq ''));
1.11      raeburn  1109:     my $udom = $cdom;
                   1110:     my $id = $item->{'id'};
                   1111:     my $url = $item->{'url'};
1.19      raeburn  1112:     my $ltinum = $item->{'lti'};
                   1113:     my $keynum = $item->{'ltiref'}->{'cipher'};
1.11      raeburn  1114:     my @intdoms;
                   1115:     my $intdomsref = $item->{'intdoms'};
                   1116:     if (ref($intdomsref) eq 'ARRAY') {
                   1117:         @intdoms = @{$intdomsref};
                   1118:     }
                   1119:     my $uriscope = $item->{'uriscope'};
                   1120:     my $section = $item->{'ltiref'}->{'section'};
                   1121:     $section =~ s/\W//g;
                   1122:     if ($section eq 'none') {
                   1123:         undef($section);
                   1124:     } elsif ($section ne '') {
                   1125:         my %curr_groups =
                   1126:             &Apache::longroup::coursegroups($cdom,$cnum);
                   1127:         if (exists($curr_groups{$section})) {
                   1128:             undef($section);
                   1129:         }
                   1130:     }
                   1131:     my (%maproles,@possroles);
                   1132:     if (ref($item->{'ltiref'}->{'maproles'}) eq 'HASH') {
                   1133:         %maproles = %{$item->{'ltiref'}->{'maproles'}};
                   1134:     }
                   1135:     if (ref($item->{'possroles'}) eq 'ARRAY') {
                   1136:         @possroles = @{$item->{'possroles'}};
                   1137:     }
1.19      raeburn  1138:     if (($id ne '') && ($url ne '')) {
                   1139:         my %data = &get_roster($cdom,$cnum,$ltinum,$keynum,$id,$url);
1.11      raeburn  1140:         if (keys(%data) > 0) {
                   1141:             my (%rulematch,%inst_results,%curr_rules,%got_rules,%alerts,%info);
                   1142:             my %coursehash = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);
                   1143:             my $start = $coursehash{'default_enrollment_start_date'};
                   1144:             my $end = $coursehash{'default_enrollment_end_date'};
                   1145:             my $domdesc = &Apache::lonnet::domain($udom,'description');
                   1146:             my $roster = &Apache::loncoursedata::get_classlist($cdom,$cnum);
                   1147:             my $status = &Apache::loncoursedata::CL_STATUS;
                   1148:             my $cend = &Apache::loncoursedata::CL_END;
                   1149:             my $cstart = &Apache::loncoursedata::CL_START;
                   1150:             my $lockedtype=&Apache::loncoursedata::CL_LOCKEDTYPE;
                   1151:             my $sec=&Apache::loncoursedata::CL_SECTION;
                   1152:             my (@activestudents,@futurestudents,@excludedstudents,@localstudents,%currlist,%advroles);
                   1153:             if (grep(/^st$/,@possroles)) {
                   1154:                 foreach my $user (keys(%{$roster})) {
                   1155:                     if ($user =~ m/^(.+):$cdom$/) {
                   1156:                         my $stuname = $1;
                   1157:                         if ($roster->{$user}[$status] eq "Active") {
                   1158:                             push(@activestudents,$stuname);
                   1159:                             @{$currlist{$stuname}} = @{$roster->{$user}};
                   1160:                             push(@localstudents,$stuname);
                   1161:                         } elsif (($roster->{$user}[$cstart] > time)  && ($roster->{$user}[$cend] > time ||
                   1162:                                   $roster->{$user}[$cend] == 0 || $roster->{$user}[$cend] eq '')) {
                   1163:                             push(@futurestudents,$stuname);
                   1164:                             @{$currlist{$stuname}} = @{$roster->{$user}};
                   1165:                             push(@localstudents,$stuname);
                   1166:                         } elsif ($roster->{$user}[$lockedtype] == 1) {
                   1167:                             push(@excludedstudents,$stuname);
                   1168:                         }
                   1169:                     }
                   1170:                 }
                   1171:             }
                   1172:             if ((@possroles > 1) || ((@possroles == 1) && (!grep(/^st$/,@possroles)))) {
                   1173:                 my %personnel = &Apache::lonnet::get_course_adv_roles($item->{'cid'},1);
                   1174:                 foreach my $item (keys(%personnel)) {
                   1175:                     my ($role,$currsec) = split(/:/,$item);
                   1176:                     if ($currsec eq '') {
                   1177:                         $currsec = 'none';
                   1178:                     }
                   1179:                     foreach my $user (split(/,/,$personnel{$item})) {
                   1180:                         push(@{$advroles{$user}{$role}},$currsec);
                   1181:                     }
                   1182:                 }
                   1183:             }
                   1184:             if (($end == 0) || ($end > time) || (@localstudents > 0)) {
                   1185:                 my (%passback,$pbnum,$numadv);
                   1186:                 $numadv = 0;
                   1187:                 foreach my $i (sort { $a <=> $b } keys(%data)) {
                   1188:                     if (ref($data{$i}) eq 'HASH') {
                   1189:                         my $entry = $data{$i};
                   1190:                         my $user = $entry->{'person_sourcedid'};
                   1191:                         my $uname;
                   1192:                         if ($user =~ /^($match_username):($match_domain)$/) {
                   1193:                             $uname = $1;
                   1194:                             my $possudom = $2;
                   1195:                             if ($possudom ne $udom) {
                   1196:                                 my $uintdom = &Apache::lonnet::domain($possudom,'primary');
                   1197:                                 if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) {
                   1198:                                     $udom = $possudom;
                   1199:                                 }
                   1200:                             }
                   1201:                         } elsif ($uname =~ /^match_username$/) {
                   1202:                             $uname = $user;
                   1203:                         } else {
                   1204:                             next;
                   1205:                         }
                   1206:                         my $uhome = &Apache::lonnet::homeserver($uname,$udom);
                   1207:                         if ($uhome eq 'no_host') {
                   1208:                             my %data;
                   1209:                             $data{'permanentemail'} = $entry->{'person_contact_email_primary'};
                   1210:                             $data{'lastname'} = $entry->{'person_name_family'};
                   1211:                             $data{'firstname'} = $entry->{'person_name_given'};
                   1212:                             $data{'fullname'} = $entry->{'person_name_full'};
                   1213:                             my $addresult =
                   1214:                                 &create_user($item->{'ltiref'},$uname,$udom,
                   1215:                                              $domdesc,\%data,\%alerts,\%rulematch,
                   1216:                                              \%inst_results,\%curr_rules,\%got_rules);
                   1217:                             next unless ($addresult eq 'ok');
                   1218:                         }
                   1219:                         if ($env{'request.lti.passbackurl'}) {
                   1220:                             if ($entry->{'lis_result_sourcedid'} ne '') {
                   1221:                                 unless ($pbnum) {
                   1222:                                     ($pbnum,my $error) = &store_passbackurl($env{'request.lti.login'},
                   1223:                                                                             $env{'request.lti.passbackurl'},
                   1224:                                                                             $cdom,$cnum);
                   1225:                                     if ($pbnum eq '') {
                   1226:                                         $pbnum = $env{'request.lti.passbackurl'};
                   1227:                                     }
                   1228:                                 }
                   1229:                                 $passback{$uname."\0".$uriscope."\0".$env{'request.lti.sourcecrs'}."\0".$env{'request.lti.login'}} =
                   1230:                                           $pbnum."\0".$entry->{'lis_result_sourcedid'};
                   1231:                             }
                   1232:                         }
                   1233:                         my $rolestr = $entry->{'roles'};
                   1234:                         my ($lcrolesref) = &get_lc_roles($rolestr,\@possroles,\%maproles);
                   1235:                         my @lcroles = @{$lcrolesref};
                   1236:                         if (@lcroles) {
                   1237:                             if (grep(/^st$/,@lcroles)) {
                   1238:                                 my $addstu;
                   1239:                                 if (!grep(/^\Q$uname\E$/,@excludedstudents)) {
                   1240:                                     if (grep(/^\Q$uname\E$/,@localstudents)) {
                   1241: # Check for section changes
                   1242:                                         if ($currlist{$uname}[$sec] ne $section) {
                   1243:                                             $addstu = 1;
                   1244:                                             &Apache::lonuserutils::modifystudent($udom,$uname,$cdom.'_'.$cnum,
                   1245:                                                                                  undef,undef,'course');
                   1246:                                         } elsif (grep(/^\Q$uname\E$/,@futurestudents)) {
                   1247: # Check for access date changes for students with access starting in the future.
                   1248:                                             my $datechange = &datechange_check($currlist{$uname}[$cstart],
                   1249:                                                                                $currlist{$uname}[$cend],
                   1250:                                                                                $start,$end);
                   1251:                                             if ($datechange) {
                   1252:                                                 $addstu = 1;
                   1253:                                             }
                   1254:                                         }
                   1255:                                     } else {
                   1256:                                         $addstu = 1;
                   1257:                                     }
                   1258:                                 }
                   1259:                                 unless ($addstu) {
                   1260:                                     pop(@lcroles);
                   1261:                                 }
                   1262:                             }
                   1263:                             my @okroles;
                   1264:                             if (@lcroles) {
                   1265:                                 foreach my $role (@lcroles) {
                   1266:                                     unless (($role eq 'st') || (keys(%advroles) == 0)) {
                   1267:                                         if (exists($advroles{$uname.':'.$udom})) {
                   1268:                                             if ((ref($advroles{$uname.':'.$udom}) eq 'HASH') &&
                   1269:                                                 (ref($advroles{$uname.':'.$udom}{$role}) eq 'ARRAY')) {
                   1270:                                                 if (($section eq '') || ($role eq 'cc') || ($role eq 'co')) {
                   1271:                                                     next if (grep(/^none$/,@{$advroles{$uname.':'.$udom}{$role}}));
                   1272:                                                 } else {
                   1273:                                                     next if (grep(/^\Q$sec\E$/,@{$advroles{$uname.':'.$udom}{$role}}));
                   1274:                                                 }
                   1275:                                             }
                   1276:                                         }
                   1277:                                     }
                   1278:                                     push(@okroles,$role);
                   1279:                                 }
                   1280:                             }
                   1281:                             if (@okroles) {
                   1282:                                 my $permanentemail = $entry->{'person_contact_email_primary'};
                   1283:                                 my $lastname = $entry->{'person_name_family'};
                   1284:                                 my $firstname = $entry->{'person_name_given'};
                   1285:                                 foreach my $role (@okroles) {
                   1286:                                     my $enrollresult = &enrolluser($udom,$uname,$role,$cdom,$cnum,
                   1287:                                                                    $section,$start,$end);
                   1288:                                     if (($enrollresult eq 'ok') && ($role ne 'st')) {
                   1289:                                         $numadv ++;
                   1290:                                     }
                   1291:                                 }
                   1292:                             }
                   1293:                         }
                   1294:                     }
                   1295:                 }
                   1296:                 if (keys(%passback)) {
                   1297:                     &Apache::lonnet::put('nohist_lti_passback',\%passback,$cdom,$cnum);
                   1298:                 }
                   1299:                 if ($numadv) {
                   1300:                     &Apache::lonnet::flushcourselogs();
                   1301:                 }
                   1302:             }
                   1303:         }
                   1304:     }
                   1305:     return;
                   1306: }
                   1307: 
1.12      raeburn  1308: #
                   1309: # LON-CAPA as LTI Provider
                   1310: #
                   1311: # Gather a list of available LON-CAPA roles derived
                   1312: # from a comma separated list of LTI roles.
                   1313: #
                   1314: # Which LON-CAPA roles are assignable by the current user
                   1315: # and how LTI roles map to LON-CAPA roles (as defined in
                   1316: # the domain configuration for the specific Consumer) are 
                   1317: # factored in when compiling the list of available roles.
                   1318: #
                   1319: # Inputs: 3
                   1320: #  $rolestr - comma separated list of LTI roles.
                   1321: #  $allowedroles - reference to array of assignable LC roles
                   1322: #  $maproles - ref to HASH of mapping of LTI roles to LC roles
                   1323: #
                   1324: # Outputs: 2
                   1325: # (a) reference to array of available LC roles.
                   1326: # (b) reference to array of LTI roles.
                   1327: #
                   1328: 
1.11      raeburn  1329: sub get_lc_roles {
                   1330:     my ($rolestr,$allowedroles,$maproles) = @_;
                   1331:     my (@ltiroles,@lcroles);
                   1332:     my @ltiroleorder = ('Instructor','TeachingAssistant','Mentor','Learner');
                   1333:     if ($rolestr =~ /,/) {
                   1334:         my @possltiroles = split(/\s*,\s*/,$rolestr);
                   1335:         foreach my $ltirole (@ltiroleorder) {
                   1336:             if (grep(/^\Q$ltirole\E$/,@possltiroles)) {
                   1337:                 push(@ltiroles,$ltirole);
                   1338:             }
                   1339:         }
                   1340:     } else {
                   1341:         my $singlerole = $rolestr;
                   1342:         $singlerole =~ s/^\s|\s+$//g;
                   1343:         if ($singlerole ne '') {
                   1344:             if (grep(/^\Q$singlerole\E$/,@ltiroleorder)) {
                   1345:                 @ltiroles = ($singlerole);
                   1346:             }
                   1347:         }
                   1348:     }
                   1349:     if (@ltiroles) {
                   1350:         my %possroles;
                   1351:         map { $possroles{$maproles->{$_}} = 1; } @ltiroles;
                   1352:         if (keys(%possroles) > 0) {
                   1353:             if (ref($allowedroles) eq 'ARRAY') {
                   1354:                 foreach my $item (@{$allowedroles}) {
                   1355:                     if (($item eq 'co') || ($item eq 'cc')) {
                   1356:                         if ($possroles{'cc'}) {
                   1357:                             push(@lcroles,$item);
                   1358:                         }
                   1359:                     } elsif ($possroles{$item}) {
                   1360:                         push(@lcroles,$item);
                   1361:                     }
                   1362:                 }
                   1363:             }
                   1364:         }
                   1365:     }
                   1366:     return (\@lcroles,\@ltiroles);
                   1367: }
                   1368: 
1.12      raeburn  1369: #
                   1370: # LON-CAPA as LTI Provider
                   1371: #
                   1372: # Compares current start and dates for a user's role
                   1373: # with dates to apply for the same user/role to 
                   1374: # determine if there is a change between the current
                   1375: # ones and the updated ones.
                   1376: # 
                   1377: 
1.11      raeburn  1378: sub datechange_check {
                   1379:     my ($oldstart,$oldend,$startdate,$enddate) = @_;
                   1380:     my $datechange = 0;
                   1381:     unless ($oldstart eq $startdate) {
                   1382:         $datechange = 1;
                   1383:     }
                   1384:     if (!$datechange) {
                   1385:         if (!$oldend) {
                   1386:             if ($enddate) {
                   1387:                 $datechange = 1;
                   1388:             }
                   1389:         } elsif ($oldend ne $enddate) {
                   1390:             $datechange = 1;
                   1391:         }
                   1392:     }
                   1393:     return $datechange;
                   1394: }
                   1395: 
1.12      raeburn  1396: #
                   1397: # LON-CAPA as LTI Provider
                   1398: #
                   1399: # Store the URL used by a specific LTI Consumer to process grades passed back
                   1400: # by an LTI Provider.
                   1401: #
                   1402: 
1.11      raeburn  1403: sub store_passbackurl {
                   1404:     my ($ltinum,$pburl,$cdom,$cnum) = @_;
                   1405:     my %history = &Apache::lonnet::restore($ltinum,'passbackurl',$cdom,$cnum);
                   1406:     my ($pbnum,$version,$error);
                   1407:     if ($history{'version'}) {
                   1408:         $version = $history{'version'};
                   1409:         for (my $i=1; $i<=$version; $i++) {
                   1410:             if ($history{$i.':pburl'} eq $pburl) {
                   1411:                 $pbnum = $i;
                   1412:                 last;
                   1413:             }
                   1414:         }
                   1415:     } else {
                   1416:         $version = 0;
                   1417:     }
                   1418:     if ($pbnum eq '') {
                   1419:         # get lock on passbackurl db
                   1420:         my $now = time;
                   1421:         my $lockhash = {
                   1422:             'lock'."\0".$ltinum."\0".$now => $env{'user.name'}.':'.$env{'user.domain'},
                   1423:         };
                   1424:         my $tries = 0;
                   1425:         my $gotlock = &Apache::lonnet::newput('passbackurl',$lockhash,$cdom,$cnum);
                   1426:         while (($gotlock ne 'ok') && ($tries<3)) {
                   1427:             $tries ++;
                   1428:             sleep 1;
                   1429:             $gotlock = &Apache::lonnet::newput('passbackurl',$lockhash,$cdom.$cnum);
                   1430:         }
                   1431:         if ($gotlock eq 'ok') {
                   1432:             if (&Apache::lonnet::store_userdata({pburl => $pburl},
                   1433:                                                  $ltinum,'passbackurl',$cdom,$cnum) eq 'ok') {
                   1434:                 $pbnum = 1+$version;
                   1435:             }
                   1436:             my $dellock = &Apache::lonnet::del('passbackurl',['lock'."\0".$ltinum."\0".$now],$cdom,$cnum);
                   1437:             unless ($dellock eq 'ok') {
                   1438:                 $error = &mt('error: could not release lockfile');
                   1439:             }
                   1440:         } else {
                   1441:             $error = &mt('error: could not obtain lockfile');
                   1442:         }
                   1443:     }
                   1444:     return ($pbnum,$error);
                   1445: }
                   1446: 
1.1       raeburn  1447: 1;

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