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