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