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