Annotation of loncom/lti/ltiutils.pm, revision 1.17.2.3
1.1 raeburn 1: # The LearningOnline Network with CAPA
2: # Utility functions for managing LON-CAPA LTI interactions
3: #
1.17.2.3! raeburn 4: # $Id: ltiutils.pm,v 1.17.2.2 2022/01/20 00:35:00 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.2 raeburn 36: use LWP::UserAgent();
1.1 raeburn 37: use Apache::lonnet;
38: use Apache::loncommon;
39: use LONCAPA qw(:DEFAULT :match);
40:
41: #
42: # LON-CAPA as LTI Consumer or LTI Provider
43: #
44: # Determine if a nonce in POSTed data has expired.
45: # If unexpired, confirm it has not already been used.
46: #
47: # When LON-CAPA is operating as a Consumer, nonce checking
48: # occurs when a Tool Provider launched from an instance of
49: # an external tool in a LON-CAPA course makes a request to
50: # (a) /adm/service/roster or (b) /adm/service/passback to,
51: # respectively, retrieve a roster or store the grade for
52: # the original launch by a specific user.
53: #
54: # When LON-CAPA is operating as a Provider, nonce checking
55: # occurs when a user in course context in another LMS (the
1.4 raeburn 56: # Consumer) launches an external tool to access a LON-CAPA URL:
1.1 raeburn 57: # /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.
58: #
59:
60: sub check_nonce {
61: my ($nonce,$timestamp,$lifetime,$domain,$ltidir) = @_;
62: if (($ltidir eq '') || ($timestamp eq '') || ($timestamp =~ /^\D/) ||
63: ($lifetime eq '') || ($lifetime =~ /\D/) || ($domain eq '')) {
64: return;
65: }
66: my $now = time;
67: if (($timestamp) && ($timestamp < ($now - $lifetime))) {
68: return;
69: }
70: if ($nonce eq '') {
71: return;
72: }
73: if (-e "$ltidir/$domain/$nonce") {
74: return;
75: } else {
76: unless (-e "$ltidir/$domain") {
77: unless (mkdir("$ltidir/$domain",0755)) {
78: return;
79: }
80: }
81: if (open(my $fh,'>',"$ltidir/$domain/$nonce")) {
82: print $fh $now;
83: close($fh);
84: return 1;
85: }
86: }
87: return;
88: }
89:
90: #
91: # LON-CAPA as LTI Consumer
92: #
93: # Verify a signed request using the consumer_key and
94: # secret for the specific LTI Provider.
95: #
96:
97: sub verify_request {
1.15 raeburn 98: my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
99: $authheaders,$errors) = @_;
100: unless (ref($errors) eq 'HASH') {
101: $errors->{15} = 1;
102: return;
103: }
104: my $request;
105: if ($oauthtype eq 'consumer') {
106: my $oauthreq = Net::OAuth->request('consumer');
107: $oauthreq->add_required_message_params('body_hash');
108: $request = $oauthreq->from_authorization_header($authheaders,
109: request_url => $protocol.'://'.$hostname.$requri,
110: request_method => $reqmethod,
111: consumer_secret => $consumer_secret,);
112: } else {
113: $request = Net::OAuth->request('request token')->from_hash($params,
114: request_url => $protocol.'://'.$hostname.$requri,
115: request_method => $reqmethod,
116: consumer_secret => $consumer_secret,);
117: }
1.1 raeburn 118: unless ($request->verify()) {
119: $errors->{15} = 1;
120: return;
121: }
122: }
123:
124: #
125: # LON-CAPA as LTI Consumer
126: #
127: # Sign a request used to launch an instance of an external
1.4 raeburn 128: # tool in a LON-CAPA course, using the key and secret supplied
1.1 raeburn 129: # by the Tool Provider.
130: #
131:
132: sub sign_params {
1.17 raeburn 133: my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_;
1.1 raeburn 134: return unless (ref($paramsref) eq 'HASH');
1.3 raeburn 135: if ($sigmethod eq '') {
136: $sigmethod = 'HMAC-SHA1';
137: }
1.17 raeburn 138: if ($type eq '') {
139: $type = 'request token';
140: }
141: if ($callback eq '') {
142: $callback = 'about:blank',
143: }
1.9 raeburn 144: srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
1.1 raeburn 145: my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
1.17 raeburn 146: my $request = Net::OAuth->request($type)->new(
1.1 raeburn 147: consumer_key => $key,
148: consumer_secret => $secret,
149: request_url => $url,
150: request_method => 'POST',
1.3 raeburn 151: signature_method => $sigmethod,
1.1 raeburn 152: timestamp => time,
153: nonce => $nonce,
1.17 raeburn 154: callback => $callback,
1.1 raeburn 155: extra_params => $paramsref,
156: version => '1.0',
157: );
1.15 raeburn 158: $request->sign();
1.17 raeburn 159: if ($post) {
160: return $request->to_post_body();
161: } else {
162: return $request->to_hash();
163: }
1.1 raeburn 164: }
165:
166: #
1.6 raeburn 167: # LON-CAPA as LTI Provider
168: #
169: # Use the part of the launch URL after /adm/lti to determine
170: # the scope for the current session (i.e., restricted to a
171: # single resource, to a single folder/map, or to an entire
172: # course).
173: #
174: # Returns an array containing scope: resource, map, or course
175: # and the LON-CAPA URL that is displayed post-launch, including
176: # accommodation of URL encryption, and translation of a tiny URL
177: # to the actual URL
178: #
179:
180: sub lti_provider_scope {
1.10 raeburn 181: my ($tail,$cdom,$cnum,$getunenc) = @_;
182: my ($scope,$realuri,$passkey,$unencsymb);
183: if ($tail =~ m{^/?uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {
1.6 raeburn 184: my $rest = $1;
185: if ($rest eq '') {
186: $scope = 'map';
187: $realuri = $tail;
188: } else {
1.13 raeburn 189: my $symb = $tail;
190: $symb =~ s{^/}{};
191: my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
1.6 raeburn 192: $realuri = &Apache::lonnet::clutter($url);
1.7 raeburn 193: if ($url =~ /\.sequence$/) {
194: $scope = 'map';
1.6 raeburn 195: } else {
1.7 raeburn 196: $scope = 'resource';
1.13 raeburn 197: $realuri .= '?symb='.$symb;
198: $passkey = $symb;
1.10 raeburn 199: if ($getunenc) {
1.13 raeburn 200: $unencsymb = $symb;
1.10 raeburn 201: }
1.6 raeburn 202: }
203: }
1.10 raeburn 204: } elsif ($tail =~ m{^/?res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) {
1.8 raeburn 205: my $rest = $1;
206: if ($rest eq '') {
207: $scope = 'map';
208: $realuri = $tail;
209: } else {
1.13 raeburn 210: my $symb = $tail;
211: $symb =~ s{^/?res/}{};
212: my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
1.8 raeburn 213: $realuri = &Apache::lonnet::clutter($url);
214: if ($url =~ /\.sequence$/) {
215: $scope = 'map';
216: } else {
217: $scope = 'resource';
1.13 raeburn 218: $realuri .= '?symb='.$symb;
219: $passkey = $symb;
1.10 raeburn 220: if ($getunenc) {
1.13 raeburn 221: $unencsymb = $symb;
1.10 raeburn 222: }
1.8 raeburn 223: }
224: }
1.6 raeburn 225: } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) {
226: my $key = $1;
227: my $tinyurl;
228: my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
229: if (defined($cached)) {
230: $tinyurl = $result;
231: } else {
232: my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
233: my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
234: if ($currtiny{$key} ne '') {
235: $tinyurl = $currtiny{$key};
236: &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
237: }
238: }
239: if ($tinyurl ne '') {
240: my ($cnum,$symb) = split(/\&/,$tinyurl,2);
241: my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
242: if ($url =~ /\.(page|sequence)$/) {
243: $scope = 'map';
244: } else {
245: $scope = 'resource';
246: }
1.10 raeburn 247: $passkey = $symb;
1.6 raeburn 248: if ((&Apache::lonnet::EXT('resource.0.encrypturl',$symb) =~ /^yes$/i) &&
249: (!$env{'request.role.adv'})) {
250: $realuri = &Apache::lonenc::encrypted(&Apache::lonnet::clutter($url));
1.7 raeburn 251: if ($scope eq 'resource') {
1.6 raeburn 252: $realuri .= '?symb='.&Apache::lonenc::encrypted($symb);
253: }
254: } else {
255: $realuri = &Apache::lonnet::clutter($url);
1.7 raeburn 256: if ($scope eq 'resource') {
1.6 raeburn 257: $realuri .= '?symb='.$symb;
258: }
259: }
1.10 raeburn 260: if ($getunenc) {
261: $unencsymb = $symb;
262: }
1.6 raeburn 263: }
1.10 raeburn 264: } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) {
1.6 raeburn 265: $scope = 'course';
266: $realuri = '/adm/navmaps';
1.13 raeburn 267: $passkey = '';
1.10 raeburn 268: }
269: if ($scope eq 'map') {
270: $passkey = $realuri;
271: }
272: if (wantarray) {
273: return ($scope,$realuri,$unencsymb);
274: } else {
275: return $passkey;
276: }
277: }
278:
1.17 raeburn 279: sub setup_logout_callback {
280: my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;
281: if ($service_url =~ m{^https?://[^/]+/}) {
1.17.2.3! raeburn 282: my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);
1.17 raeburn 283: my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));
284: if ((-d $idsdir) && (open(my $fh,'>',"$idsdir/$loginfile"))) {
285: print $fh "$uname,$udom,$server\n";
286: close($fh);
287: my $callback = 'http://'.$hostname.'/adm/service/logout/'.$loginfile;
288: my %ltiparams = (
289: callback => $callback,
290: );
291: my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
292: '','','',1);
1.17.2.2 raeburn 293:
294: my $ua=new LWP::UserAgent;
295: $ua->timeout(10);
1.17 raeburn 296: my $request=new HTTP::Request('POST',$service_url);
297: $request->content($post);
1.17.2.2 raeburn 298: my $response=$ua->request($request);
1.17 raeburn 299: }
300: }
301: return;
302: }
303:
1.12 raeburn 304: #
305: # LON-CAPA as LTI Provider
306: #
307: # Create a new user in LON-CAPA. If the domain's configuration
308: # includes rules for format of "official" usernames, those rules
309: # will apply when determining if a user is to be created. In
310: # additional if institutional user information is available that
311: # will be used when creating a new user account.
312: #
313:
1.11 raeburn 314: sub create_user {
315: my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results,
316: $curr_rules,$got_rules) = @_;
317: return unless (ref($ltiref) eq 'HASH');
318: my $checkhash = { "$uname:$udom" => { 'newuser' => 1, }, };
319: my $checks = { 'username' => 1, };
320: my ($lcauth,$lcauthparm);
321: &Apache::loncommon::user_rule_check($checkhash,$checks,$alerts,$rulematch,
322: $inst_results,$curr_rules,$got_rules);
323: my ($userchkmsg,$lcauth,$lcauthparm);
324: my $allowed = 1;
325: if (ref($alerts->{'username'}) eq 'HASH') {
326: if (ref($alerts->{'username'}{$udom}) eq 'HASH') {
327: if ($alerts->{'username'}{$udom}{$uname}) {
328: if (ref($curr_rules->{$udom}) eq 'HASH') {
329: $userchkmsg =
330: &Apache::loncommon::instrule_disallow_msg('username',$domdesc,1).
331: &Apache::loncommon::user_rule_formats($udom,$domdesc,
332: $curr_rules->{$udom}{'username'},
333: 'username');
334: }
335: $allowed = 0;
336: }
337: }
338: }
339: if ($allowed) {
340: if (ref($rulematch->{$uname.':'.$udom}) eq 'HASH') {
341: my $matchedrule = $rulematch->{$uname.':'.$udom}{'username'};
342: my ($rules,$ruleorder) =
343: &Apache::lonnet::inst_userrules($udom,'username');
344: if (ref($rules) eq 'HASH') {
345: if (ref($rules->{$matchedrule}) eq 'HASH') {
346: $lcauth = $rules->{$matchedrule}{'authtype'};
347: $lcauthparm = $rules->{$matchedrule}{'authparm'};
348: }
349: }
350: }
351: if ($lcauth eq '') {
352: $lcauth = $ltiref->{'lcauth'};
353: if ($lcauth eq 'internal') {
354: $lcauthparm = &create_passwd();
355: } else {
356: $lcauthparm = $ltiref->{'lcauthparm'};
357: }
358: }
359: } else {
360: return 'notallowed';
361: }
362: my @userinfo = ('firstname','middlename','lastname','generation','permanentemail','id');
363: my (%useinstdata,%info);
364: if (ref($ltiref->{'instdata'}) eq 'ARRAY') {
365: map { $useinstdata{$_} = 1; } @{$ltiref->{'instdata'}};
366: }
367: foreach my $item (@userinfo) {
368: if (($useinstdata{$item}) && (ref($inst_results->{$uname.':'.$udom}) eq 'HASH') &&
369: ($inst_results->{$uname.':'.$udom}{$item} ne '')) {
370: $info{$item} = $inst_results->{$uname.':'.$udom}{$item};
371: } else {
372: if ($item eq 'permanentemail') {
373: if ($data->{'permanentemail'} =~/^[^\@]+\@[^@]+$/) {
374: $info{$item} = $data->{'permanentemail'};
375: }
376: } elsif (($item eq 'firstname') || ($item eq 'lastname')) {
377: $info{$item} = $data->{$item};
378: }
379: }
380: }
381: if (($info{'middlename'} eq '') && ($data->{'fullname'} ne '')) {
382: unless ($useinstdata{'middlename'}) {
383: my $fullname = $data->{'fullname'};
384: if ($info{'firstname'}) {
385: $fullname =~ s/^\s*\Q$info{'firstname'}\E\s*//i;
386: }
387: if ($info{'lastname'}) {
388: $fullname =~ s/\s*\Q$info{'lastname'}\E\s*$//i;
389: }
390: if ($fullname ne '') {
391: $fullname =~ s/^\s+|\s+$//g;
392: if ($fullname ne '') {
393: $info{'middlename'} = $fullname;
394: }
395: }
396: }
397: }
398: if (ref($inst_results->{$uname.':'.$udom}{'inststatus'}) eq 'ARRAY') {
399: my @inststatuses = @{$inst_results->{$uname.':'.$udom}{'inststatus'}};
400: $info{'inststatus'} = join(':',map { &escape($_); } @inststatuses);
401: }
402: my $result =
403: &Apache::lonnet::modifyuser($udom,$uname,$info{'id'},
404: $lcauth,$lcauthparm,$info{'firstname'},
405: $info{'middlename'},$info{'lastname'},
406: $info{'generation'},undef,undef,
407: $info{'permanentemail'},$info{'inststatus'});
408: return $result;
409: }
410:
1.12 raeburn 411: #
412: # LON-CAPA as LTI Provider
413: #
414: # Create a password for a new user if the authentication
415: # type to assign to new users created following LTI launch is
416: # to be LON-CAPA "internal".
417: #
418:
1.11 raeburn 419: sub create_passwd {
420: my $passwd = '';
1.12 raeburn 421: srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
1.11 raeburn 422: my @letts = ("a".."z");
423: for (my $i=0; $i<8; $i++) {
424: my $lettnum = int(rand(2));
425: my $item = '';
426: if ($lettnum) {
427: $item = $letts[int(rand(26))];
428: my $uppercase = int(rand(2));
429: if ($uppercase) {
430: $item =~ tr/a-z/A-Z/;
431: }
432: } else {
433: $item = int(rand(10));
434: }
435: $passwd .= $item;
436: }
437: return ($passwd);
438: }
439:
1.12 raeburn 440: #
441: # LON-CAPA as LTI Provider
442: #
443: # Enroll a user in a LON-CAPA course, with the specified role and (optional)
444: # section. If this is a self-enroll case, i.e., a user launched the LTI tool
445: # in the Consumer, user privs will be added to the user's environment for
446: # the new role.
447: #
448: # If this is a self-enroll case, a Course Coordinator role will only be assigned
449: # if the current user is also the course owner.
450: #
451:
1.11 raeburn 452: sub enrolluser {
1.12 raeburn 453: my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end,$selfenroll) = @_;
1.11 raeburn 454: my $enrollresult;
455: my $area = "/$cdom/$cnum";
456: if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) {
457: $area .= '/'.$sec;
458: }
459: my $spec = $role.'.'.$area;
460: my $instcid;
461: if ($role eq 'st') {
462: $enrollresult =
463: &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,
464: undef,undef,$sec,$end,$start,
1.12 raeburn 465: 'ltienroll',undef,$cdom.'_'.$cnum,
466: $selfenroll,'ltienroll','',$instcid);
1.11 raeburn 467: } elsif ($role =~ /^(cc|in|ta|ep)$/) {
468: $enrollresult =
469: &Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start,
1.12 raeburn 470: undef,$selfenroll,'ltienroll');
471: }
472: if ($enrollresult eq 'ok') {
473: if ($selfenroll) {
474: my (%userroles,%newrole,%newgroups);
475: &Apache::lonnet::standard_roleprivs(\%newrole,$role,$cdom,$spec,$cnum,
476: $area);
477: &Apache::lonnet::set_userprivs(\%userroles,\%newrole,\%newgroups);
478: $userroles{'user.role.'.$spec} = $start.'.'.$end;
479: &Apache::lonnet::appenv(\%userroles,[$role,'cm']);
480: }
1.11 raeburn 481: }
482: return $enrollresult;
483: }
484:
1.12 raeburn 485: #
486: # LON-CAPA as LTI Provider
487: #
488: # Gather a list of available LON-CAPA roles derived
489: # from a comma separated list of LTI roles.
490: #
491: # Which LON-CAPA roles are assignable by the current user
492: # and how LTI roles map to LON-CAPA roles (as defined in
493: # the domain configuration for the specific Consumer) are
494: # factored in when compiling the list of available roles.
495: #
496: # Inputs: 3
497: # $rolestr - comma separated list of LTI roles.
498: # $allowedroles - reference to array of assignable LC roles
499: # $maproles - ref to HASH of mapping of LTI roles to LC roles
500: #
501: # Outputs: 2
502: # (a) reference to array of available LC roles.
503: # (b) reference to array of LTI roles.
504: #
505:
1.11 raeburn 506: sub get_lc_roles {
507: my ($rolestr,$allowedroles,$maproles) = @_;
508: my (@ltiroles,@lcroles);
509: my @ltiroleorder = ('Instructor','TeachingAssistant','Mentor','Learner');
510: if ($rolestr =~ /,/) {
511: my @possltiroles = split(/\s*,\s*/,$rolestr);
512: foreach my $ltirole (@ltiroleorder) {
513: if (grep(/^\Q$ltirole\E$/,@possltiroles)) {
514: push(@ltiroles,$ltirole);
515: }
516: }
517: } else {
518: my $singlerole = $rolestr;
519: $singlerole =~ s/^\s|\s+$//g;
520: if ($singlerole ne '') {
521: if (grep(/^\Q$singlerole\E$/,@ltiroleorder)) {
522: @ltiroles = ($singlerole);
523: }
524: }
525: }
526: if (@ltiroles) {
527: my %possroles;
528: map { $possroles{$maproles->{$_}} = 1; } @ltiroles;
529: if (keys(%possroles) > 0) {
530: if (ref($allowedroles) eq 'ARRAY') {
531: foreach my $item (@{$allowedroles}) {
532: if (($item eq 'co') || ($item eq 'cc')) {
533: if ($possroles{'cc'}) {
534: push(@lcroles,$item);
535: }
536: } elsif ($possroles{$item}) {
537: push(@lcroles,$item);
538: }
539: }
540: }
541: }
542: }
543: return (\@lcroles,\@ltiroles);
544: }
545:
1.1 raeburn 546: 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