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