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