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