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

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

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