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