--- loncom/lti/ltiutils.pm 2018/01/04 12:09:42 1.4
+++ loncom/lti/ltiutils.pm 2022/01/20 00:35:00 1.17.2.2
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Utility functions for managing LON-CAPA LTI interactions
#
-# $Id: ltiutils.pm,v 1.4 2018/01/04 12:09:42 raeburn Exp $
+# $Id: ltiutils.pm,v 1.17.2.2 2022/01/20 00:35:00 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,7 +31,8 @@ package LONCAPA::ltiutils;
use strict;
use Net::OAuth;
use Digest::SHA;
-use UUID::Tiny ':std';
+use Digest::MD5 qw(md5_hex);
+use LWP::UserAgent();
use Apache::lonnet;
use Apache::loncommon;
use LONCAPA qw(:DEFAULT :match);
@@ -88,226 +89,35 @@ sub check_nonce {
#
# LON-CAPA as LTI Consumer
#
-# Determine the domain and the courseID of the LON-CAPA course
-# for which access is needed by a Tool Provider -- either to
-# retrieve a roster or store the grade for an instance of an
-# external tool in the course.
-#
-
-sub get_loncapa_course {
- my ($lonhost,$cid,$errors) = @_;
- return unless (ref($errors) eq 'HASH');
- my ($cdom,$cnum);
- if ($cid =~ /^($match_domain)_($match_courseid)$/) {
- my ($posscdom,$posscnum) = ($1,$2);
- my $cprimary_id = &Apache::lonnet::domain($posscdom,'primary');
- if ($cprimary_id eq '') {
- $errors->{5} = 1;
- return;
- } else {
- my @intdoms;
- my $internet_names = &Apache::lonnet::get_internet_names($lonhost);
- if (ref($internet_names) eq 'ARRAY') {
- @intdoms = @{$internet_names};
- }
- my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);
- if (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {
- $cdom = $posscdom;
- } else {
- $errors->{6} = 1;
- return;
- }
- }
- my $chome = &Apache::lonnet::homeserver($posscnum,$posscdom);
- if ($chome =~ /(con_lost|no_host|no_such_host)/) {
- $errors->{7} = 1;
- return;
- } else {
- $cnum = $posscnum;
- }
- } else {
- $errors->{8} = 1;
- return;
- }
- return ($cdom,$cnum);
-}
-
-#
-# LON-CAPA as LTI Consumer
-#
-# Determine the symb and (optionally) LON-CAPA user for an
-# instance of an external tool in a course -- either to
-# to retrieve a roster or store a grade.
-#
-# Use the digested symb to lookup the real symb in exttools.db
-# and the digested userID to lookup the real userID (if needed).
-# and extract the exttool instance and symb.
-#
-
-sub get_tool_instance {
- my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_;
- return unless (ref($errors) eq 'HASH');
- my ($marker,$symb,$uname,$udom);
- my @keys = ($digsymb);
- if ($diguser) {
- push(@keys,$diguser);
- }
- my %digesthash = &Apache::lonnet::get('exttools',\@keys,$cdom,$cnum);
- if ($digsymb) {
- $symb = $digesthash{$digsymb};
- if ($symb) {
- my ($map,$id,$url) = split(/___/,$symb);
- $marker = (split(m{/},$url))[3];
- $marker=~s/\D//g;
- } else {
- $errors->{9} = 1;
- }
- }
- if ($diguser) {
- if ($digesthash{$diguser} =~ /^($match_username):($match_domain)$/) {
- ($uname,$udom) = ($1,$2);
- } else {
- $errors->{10} = 1;
- }
- return ($marker,$symb,$uname,$udom);
- } else {
- return ($marker,$symb);
- }
-}
-
-#
-# LON-CAPA as LTI Consumer
-#
-# Retrieve data needed to validate a request from a Tool Provider
-# for a roster or to store a grade for an instance of an external
-# tool in a LON-CAPA course.
-#
-# Retrieve the Consumer key and Consumer secret from the domain
-# configuration or the Tool Provider ID stored in the
-# exttool_$marker db file and compare the Consumer key with the
-# one in the POSTed data.
-#
-# Side effect is to populate the $toolsettings hashref with the
-# contents of the .db file (instance of tool in course) and the
-# $ltitools hashref with the configuration for the tool (at
-# domain level).
-#
-
-sub get_tool_secret {
- my ($key,$marker,$symb,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;
- return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&
- (ref($errors) eq 'HASH'));
- my ($consumer_secret,$nonce_lifetime);
- if ($marker) {
- %{$toolsettings}=&Apache::lonnet::dump('exttool_'.$marker,$cdom,$cnum);
- if ($toolsettings->{'id'}) {
- my $idx = $toolsettings->{'id'};
- my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');
- if (ref($lti{$idx}) eq 'HASH') {
- %{$ltitools} = %{$lti{$idx}};
- if ($ltitools->{'key'} eq $key) {
- $consumer_secret = $ltitools->{'secret'};
- $nonce_lifetime = $ltitools->{'lifetime'};
- } else {
- $errors->{11} = 1;
- return;
- }
- } else {
- $errors->{12} = 1;
- return;
- }
- } else {
- $errors->{13} = 1;
- return;
- }
- } else {
- $errors->{14};
- return;
- }
- return ($consumer_secret,$nonce_lifetime);
-}
-
-#
-# LON-CAPA as LTI Consumer
-#
# Verify a signed request using the consumer_key and
# secret for the specific LTI Provider.
#
sub verify_request {
- my ($params,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$errors) = @_;
- return unless (ref($errors) eq 'HASH');
- my $request = Net::OAuth->request('request token')->from_hash($params,
- request_url => $protocol.'://'.$hostname.$requri,
- request_method => $reqmethod,
- consumer_secret => $consumer_secret,);
- unless ($request->verify()) {
+ my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
+ $authheaders,$errors) = @_;
+ unless (ref($errors) eq 'HASH') {
$errors->{15} = 1;
return;
}
-}
-
-#
-# LON-CAPA as LTI Consumer
-#
-# Verify that an item identifier (either roster request:
-# ext_ims_lis_memberships_id, or grade store:
-# lis_result_sourcedid) has not been tampered with, and
-# the secret used to create the unique identifier has not
-# expired.
-#
-# Prepending the current secret (if still valid),
-# or the previous secret (if current one is no longer valid),
-# to a string composed of the :::-separated components
-# must generate the result signature in the lis item ID
-# sent by the Tool Provider.
-#
-
-sub verify_lis_item {
- my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;
- return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&
- (ref($errors) eq 'HASH'));
- my ($has_action, $valid_for);
- if ($context eq 'grade') {
- $has_action = $ltitools->{'passback'};
- $valid_for = $ltitools->{'passbackvalid'}
- } elsif ($context eq 'roster') {
- $has_action = $ltitools->{'roster'};
- $valid_for = $ltitools->{'rostervalid'};
- }
- if ($has_action) {
- my $secret;
- if (($toolsettings->{$context.'secretdate'} + $valid_for) > time) {
- $secret = $toolsettings->{$context.'secret'};
- } else {
- $secret = $toolsettings->{'old'.$context.'secret'};
- }
- if ($secret) {
- my $expected_sig;
- if ($context eq 'grade') {
- my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;
- $expected_sig = &get_service_id($secret,$uniqid);
- if ($expected_sig eq $sigrec) {
- return 1;
- } else {
- $errors->{17} = 1;
- }
- } elsif ($context eq 'roster') {
- my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;
- $expected_sig = &get_service_id($secret,$uniqid);
- if ($expected_sig eq $sigrec) {
- return 1;
- } else {
- $errors->{18} = 1;
- }
- }
- } else {
- $errors->{19} = 1;
- }
+ my $request;
+ if ($oauthtype eq 'consumer') {
+ my $oauthreq = Net::OAuth->request('consumer');
+ $oauthreq->add_required_message_params('body_hash');
+ $request = $oauthreq->from_authorization_header($authheaders,
+ request_url => $protocol.'://'.$hostname.$requri,
+ request_method => $reqmethod,
+ consumer_secret => $consumer_secret,);
} else {
- $errors->{20} = 1;
+ $request = Net::OAuth->request('request token')->from_hash($params,
+ request_url => $protocol.'://'.$hostname.$requri,
+ request_method => $reqmethod,
+ consumer_secret => $consumer_secret,);
+ }
+ unless ($request->verify()) {
+ $errors->{15} = 1;
+ return;
}
- return;
}
#
@@ -319,13 +129,20 @@ sub verify_lis_item {
#
sub sign_params {
- my ($url,$key,$secret,$sigmethod,$paramsref) = @_;
+ my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_;
return unless (ref($paramsref) eq 'HASH');
if ($sigmethod eq '') {
$sigmethod = 'HMAC-SHA1';
}
+ if ($type eq '') {
+ $type = 'request token';
+ }
+ if ($callback eq '') {
+ $callback = 'about:blank',
+ }
+ srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
- my $request = Net::OAuth->request("request token")->new(
+ my $request = Net::OAuth->request($type)->new(
consumer_key => $key,
consumer_secret => $secret,
request_url => $url,
@@ -333,129 +150,396 @@ sub sign_params {
signature_method => $sigmethod,
timestamp => time,
nonce => $nonce,
- callback => 'about:blank',
+ callback => $callback,
extra_params => $paramsref,
version => '1.0',
);
- $request->sign;
- return $request->to_hash();
+ $request->sign();
+ if ($post) {
+ return $request->to_post_body();
+ } else {
+ return $request->to_hash();
+ }
}
#
-# LON-CAPA as LTI Consumer
-#
-# Generate a signature for a unique identifier (roster request:
-# ext_ims_lis_memberships_id, or grade store: lis_result_sourcedid)
+# LON-CAPA as LTI Provider
#
-
-sub get_service_id {
- my ($secret,$id) = @_;
- my $sig = Digest::SHA::sha1_hex($secret.':::'.$id);
- return $sig.':::'.$id;
-}
-
+# Use the part of the launch URL after /adm/lti to determine
+# the scope for the current session (i.e., restricted to a
+# single resource, to a single folder/map, or to an entire
+# course).
#
-# LON-CAPA as LTI Consumer
+# Returns an array containing scope: resource, map, or course
+# and the LON-CAPA URL that is displayed post-launch, including
+# accommodation of URL encryption, and translation of a tiny URL
+# to the actual URL
#
-# Generate and store the time-limited secret used to create the
-# signature in a service request identifier (roster request or
-# grade store). An existing secret past its expiration date
-# will be stored as old<service name>secret, and a new secret
-# <service name>secret will be stored.
-#
-# Secrets are specific to service name and to the tool instance
-# (and are stored in the exttool_$marker db file).
-# The time period a secret remains valid is determined by the
-# domain configuration for the specific tool and the service.
-#
-sub set_service_secret {
- my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_;
- return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH'));
- my $warning;
- my ($needsnew,$oldsecret,$lifetime);
- if ($name eq 'grade') {
- $lifetime = $ltitools->{'passbackvalid'}
- } elsif ($name eq 'roster') {
- $lifetime = $ltitools->{'rostervalid'};
- }
- if ($toolsettings->{$name} eq '') {
- $needsnew = 1;
- } elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) {
- $oldsecret = $toolsettings->{$name.'secret'};
- $needsnew = 1;
- }
- if ($needsnew) {
- if (&get_tool_lock($cdom,$cnum,$marker,$name,$now) eq 'ok') {
- my $secret = UUID::Tiny::create_uuid_as_string(UUID_V4);
- $toolsettings->{$name.'secret'} = $secret;
- my %secrethash = (
- $name.'secret' => $secret,
- $name.'secretdate' => $now,
- );
- if ($oldsecret ne '') {
- $secrethash{'old'.$name.'secret'} = $oldsecret;
- }
- my $putres = &Apache::lonnet::put('exttool_'.$marker,
- \%secrethash,$cdom,$cnum);
- my $delresult = &release_tool_lock($cdom,$cnum,$marker,$name);
- if ($delresult ne 'ok') {
- $warning = $delresult ;
+sub lti_provider_scope {
+ my ($tail,$cdom,$cnum,$getunenc) = @_;
+ my ($scope,$realuri,$passkey,$unencsymb);
+ if ($tail =~ m{^/?uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {
+ my $rest = $1;
+ if ($rest eq '') {
+ $scope = 'map';
+ $realuri = $tail;
+ } else {
+ my $symb = $tail;
+ $symb =~ s{^/}{};
+ my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
+ $realuri = &Apache::lonnet::clutter($url);
+ if ($url =~ /\.sequence$/) {
+ $scope = 'map';
+ } else {
+ $scope = 'resource';
+ $realuri .= '?symb='.$symb;
+ $passkey = $symb;
+ if ($getunenc) {
+ $unencsymb = $symb;
+ }
}
- if ($putres eq 'ok') {
- return 'ok';
+ }
+ } elsif ($tail =~ m{^/?res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) {
+ my $rest = $1;
+ if ($rest eq '') {
+ $scope = 'map';
+ $realuri = $tail;
+ } else {
+ my $symb = $tail;
+ $symb =~ s{^/?res/}{};
+ my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
+ $realuri = &Apache::lonnet::clutter($url);
+ if ($url =~ /\.sequence$/) {
+ $scope = 'map';
+ } else {
+ $scope = 'resource';
+ $realuri .= '?symb='.$symb;
+ $passkey = $symb;
+ if ($getunenc) {
+ $unencsymb = $symb;
+ }
}
+ }
+ } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) {
+ my $key = $1;
+ my $tinyurl;
+ my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
+ if (defined($cached)) {
+ $tinyurl = $result;
} else {
- $warning = 'Could not obtain exclusive lock';
+ my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
+ my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
+ if ($currtiny{$key} ne '') {
+ $tinyurl = $currtiny{$key};
+ &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
+ }
+ }
+ if ($tinyurl ne '') {
+ my ($cnum,$symb) = split(/\&/,$tinyurl,2);
+ my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
+ if ($url =~ /\.(page|sequence)$/) {
+ $scope = 'map';
+ } else {
+ $scope = 'resource';
+ }
+ $passkey = $symb;
+ if ((&Apache::lonnet::EXT('resource.0.encrypturl',$symb) =~ /^yes$/i) &&
+ (!$env{'request.role.adv'})) {
+ $realuri = &Apache::lonenc::encrypted(&Apache::lonnet::clutter($url));
+ if ($scope eq 'resource') {
+ $realuri .= '?symb='.&Apache::lonenc::encrypted($symb);
+ }
+ } else {
+ $realuri = &Apache::lonnet::clutter($url);
+ if ($scope eq 'resource') {
+ $realuri .= '?symb='.$symb;
+ }
+ }
+ if ($getunenc) {
+ $unencsymb = $symb;
+ }
}
+ } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) {
+ $scope = 'course';
+ $realuri = '/adm/navmaps';
+ $passkey = '';
+ }
+ if ($scope eq 'map') {
+ $passkey = $realuri;
+ }
+ if (wantarray) {
+ return ($scope,$realuri,$unencsymb);
} else {
- return 'ok';
+ return $passkey;
+ }
+}
+
+sub setup_logout_callback {
+ my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;
+ if ($service_url =~ m{^https?://[^/]+/}) {
+ my $digest_user = &Encode::decode_utf8($uname.':'.$udom);
+ my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));
+ if ((-d $idsdir) && (open(my $fh,'>',"$idsdir/$loginfile"))) {
+ print $fh "$uname,$udom,$server\n";
+ close($fh);
+ my $callback = 'http://'.$hostname.'/adm/service/logout/'.$loginfile;
+ my %ltiparams = (
+ callback => $callback,
+ );
+ my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
+ '','','',1);
+
+ my $ua=new LWP::UserAgent;
+ $ua->timeout(10);
+ my $request=new HTTP::Request('POST',$service_url);
+ $request->content($post);
+ my $response=$ua->request($request);
+ }
}
return;
}
#
-# LON-CAPA as LTI Consumer
+# LON-CAPA as LTI Provider
#
-# Add a lock key to exttools.db for the instance of an external tool
-# when generating and storing a service secret.
+# Create a new user in LON-CAPA. If the domain's configuration
+# includes rules for format of "official" usernames, those rules
+# will apply when determining if a user is to be created. In
+# additional if institutional user information is available that
+# will be used when creating a new user account.
+#
+
+sub create_user {
+ my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results,
+ $curr_rules,$got_rules) = @_;
+ return unless (ref($ltiref) eq 'HASH');
+ my $checkhash = { "$uname:$udom" => { 'newuser' => 1, }, };
+ my $checks = { 'username' => 1, };
+ my ($lcauth,$lcauthparm);
+ &Apache::loncommon::user_rule_check($checkhash,$checks,$alerts,$rulematch,
+ $inst_results,$curr_rules,$got_rules);
+ my ($userchkmsg,$lcauth,$lcauthparm);
+ my $allowed = 1;
+ if (ref($alerts->{'username'}) eq 'HASH') {
+ if (ref($alerts->{'username'}{$udom}) eq 'HASH') {
+ if ($alerts->{'username'}{$udom}{$uname}) {
+ if (ref($curr_rules->{$udom}) eq 'HASH') {
+ $userchkmsg =
+ &Apache::loncommon::instrule_disallow_msg('username',$domdesc,1).
+ &Apache::loncommon::user_rule_formats($udom,$domdesc,
+ $curr_rules->{$udom}{'username'},
+ 'username');
+ }
+ $allowed = 0;
+ }
+ }
+ }
+ if ($allowed) {
+ if (ref($rulematch->{$uname.':'.$udom}) eq 'HASH') {
+ my $matchedrule = $rulematch->{$uname.':'.$udom}{'username'};
+ my ($rules,$ruleorder) =
+ &Apache::lonnet::inst_userrules($udom,'username');
+ if (ref($rules) eq 'HASH') {
+ if (ref($rules->{$matchedrule}) eq 'HASH') {
+ $lcauth = $rules->{$matchedrule}{'authtype'};
+ $lcauthparm = $rules->{$matchedrule}{'authparm'};
+ }
+ }
+ }
+ if ($lcauth eq '') {
+ $lcauth = $ltiref->{'lcauth'};
+ if ($lcauth eq 'internal') {
+ $lcauthparm = &create_passwd();
+ } else {
+ $lcauthparm = $ltiref->{'lcauthparm'};
+ }
+ }
+ } else {
+ return 'notallowed';
+ }
+ my @userinfo = ('firstname','middlename','lastname','generation','permanentemail','id');
+ my (%useinstdata,%info);
+ if (ref($ltiref->{'instdata'}) eq 'ARRAY') {
+ map { $useinstdata{$_} = 1; } @{$ltiref->{'instdata'}};
+ }
+ foreach my $item (@userinfo) {
+ if (($useinstdata{$item}) && (ref($inst_results->{$uname.':'.$udom}) eq 'HASH') &&
+ ($inst_results->{$uname.':'.$udom}{$item} ne '')) {
+ $info{$item} = $inst_results->{$uname.':'.$udom}{$item};
+ } else {
+ if ($item eq 'permanentemail') {
+ if ($data->{'permanentemail'} =~/^[^\@]+\@[^@]+$/) {
+ $info{$item} = $data->{'permanentemail'};
+ }
+ } elsif (($item eq 'firstname') || ($item eq 'lastname')) {
+ $info{$item} = $data->{$item};
+ }
+ }
+ }
+ if (($info{'middlename'} eq '') && ($data->{'fullname'} ne '')) {
+ unless ($useinstdata{'middlename'}) {
+ my $fullname = $data->{'fullname'};
+ if ($info{'firstname'}) {
+ $fullname =~ s/^\s*\Q$info{'firstname'}\E\s*//i;
+ }
+ if ($info{'lastname'}) {
+ $fullname =~ s/\s*\Q$info{'lastname'}\E\s*$//i;
+ }
+ if ($fullname ne '') {
+ $fullname =~ s/^\s+|\s+$//g;
+ if ($fullname ne '') {
+ $info{'middlename'} = $fullname;
+ }
+ }
+ }
+ }
+ if (ref($inst_results->{$uname.':'.$udom}{'inststatus'}) eq 'ARRAY') {
+ my @inststatuses = @{$inst_results->{$uname.':'.$udom}{'inststatus'}};
+ $info{'inststatus'} = join(':',map { &escape($_); } @inststatuses);
+ }
+ my $result =
+ &Apache::lonnet::modifyuser($udom,$uname,$info{'id'},
+ $lcauth,$lcauthparm,$info{'firstname'},
+ $info{'middlename'},$info{'lastname'},
+ $info{'generation'},undef,undef,
+ $info{'permanentemail'},$info{'inststatus'});
+ return $result;
+}
+
#
+# LON-CAPA as LTI Provider
+#
+# Create a password for a new user if the authentication
+# type to assign to new users created following LTI launch is
+# to be LON-CAPA "internal".
+#
+
+sub create_passwd {
+ my $passwd = '';
+ srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
+ my @letts = ("a".."z");
+ for (my $i=0; $i<8; $i++) {
+ my $lettnum = int(rand(2));
+ my $item = '';
+ if ($lettnum) {
+ $item = $letts[int(rand(26))];
+ my $uppercase = int(rand(2));
+ if ($uppercase) {
+ $item =~ tr/a-z/A-Z/;
+ }
+ } else {
+ $item = int(rand(10));
+ }
+ $passwd .= $item;
+ }
+ return ($passwd);
+}
-sub get_tool_lock {
- my ($cdom,$cnum,$marker,$name,$now) = @_;
- # get lock for tool for which secret is being set
- my $lockhash = {
- $name."\0".$marker."\0".'lock' => $now.':'.$env{'user.name'}.
- ':'.$env{'user.domain'},
- };
- my $tries = 0;
- my $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);
-
- while (($gotlock ne 'ok') && $tries <3) {
- $tries ++;
- sleep(1);
- $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);
+#
+# LON-CAPA as LTI Provider
+#
+# Enroll a user in a LON-CAPA course, with the specified role and (optional)
+# section. If this is a self-enroll case, i.e., a user launched the LTI tool
+# in the Consumer, user privs will be added to the user's environment for
+# the new role.
+#
+# If this is a self-enroll case, a Course Coordinator role will only be assigned
+# if the current user is also the course owner.
+#
+
+sub enrolluser {
+ my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end,$selfenroll) = @_;
+ my $enrollresult;
+ my $area = "/$cdom/$cnum";
+ if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) {
+ $area .= '/'.$sec;
+ }
+ my $spec = $role.'.'.$area;
+ my $instcid;
+ if ($role eq 'st') {
+ $enrollresult =
+ &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,
+ undef,undef,$sec,$end,$start,
+ 'ltienroll',undef,$cdom.'_'.$cnum,
+ $selfenroll,'ltienroll','',$instcid);
+ } elsif ($role =~ /^(cc|in|ta|ep)$/) {
+ $enrollresult =
+ &Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start,
+ undef,$selfenroll,'ltienroll');
+ }
+ if ($enrollresult eq 'ok') {
+ if ($selfenroll) {
+ my (%userroles,%newrole,%newgroups);
+ &Apache::lonnet::standard_roleprivs(\%newrole,$role,$cdom,$spec,$cnum,
+ $area);
+ &Apache::lonnet::set_userprivs(\%userroles,\%newrole,\%newgroups);
+ $userroles{'user.role.'.$spec} = $start.'.'.$end;
+ &Apache::lonnet::appenv(\%userroles,[$role,'cm']);
+ }
}
- return $gotlock;
+ return $enrollresult;
}
#
-# LON-CAPA as LTI Consumer
+# LON-CAPA as LTI Provider
+#
+# Gather a list of available LON-CAPA roles derived
+# from a comma separated list of LTI roles.
+#
+# Which LON-CAPA roles are assignable by the current user
+# and how LTI roles map to LON-CAPA roles (as defined in
+# the domain configuration for the specific Consumer) are
+# factored in when compiling the list of available roles.
+#
+# Inputs: 3
+# $rolestr - comma separated list of LTI roles.
+# $allowedroles - reference to array of assignable LC roles
+# $maproles - ref to HASH of mapping of LTI roles to LC roles
#
-# Remove a lock key from exttools.db for the instance of an external
-# tool created when generating and storing a service secret.
+# Outputs: 2
+# (a) reference to array of available LC roles.
+# (b) reference to array of LTI roles.
#
-sub release_tool_lock {
- my ($cdom,$cnum,$marker,$name) = @_;
- # remove lock
- my @del_lock = ($name."\0".$marker."\0".'lock');
- my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);
- if ($dellockoutcome ne 'ok') {
- return 'Warning: failed to release lock for exttool';
+sub get_lc_roles {
+ my ($rolestr,$allowedroles,$maproles) = @_;
+ my (@ltiroles,@lcroles);
+ my @ltiroleorder = ('Instructor','TeachingAssistant','Mentor','Learner');
+ if ($rolestr =~ /,/) {
+ my @possltiroles = split(/\s*,\s*/,$rolestr);
+ foreach my $ltirole (@ltiroleorder) {
+ if (grep(/^\Q$ltirole\E$/,@possltiroles)) {
+ push(@ltiroles,$ltirole);
+ }
+ }
} else {
- return 'ok';
+ my $singlerole = $rolestr;
+ $singlerole =~ s/^\s|\s+$//g;
+ if ($singlerole ne '') {
+ if (grep(/^\Q$singlerole\E$/,@ltiroleorder)) {
+ @ltiroles = ($singlerole);
+ }
+ }
+ }
+ if (@ltiroles) {
+ my %possroles;
+ map { $possroles{$maproles->{$_}} = 1; } @ltiroles;
+ if (keys(%possroles) > 0) {
+ if (ref($allowedroles) eq 'ARRAY') {
+ foreach my $item (@{$allowedroles}) {
+ if (($item eq 'co') || ($item eq 'cc')) {
+ if ($possroles{'cc'}) {
+ push(@lcroles,$item);
+ }
+ } elsif ($possroles{$item}) {
+ push(@lcroles,$item);
+ }
+ }
+ }
+ }
}
+ return (\@lcroles,\@ltiroles);
}
1;