--- loncom/lti/ltiutils.pm 2020/04/09 23:17:19 1.9.2.1
+++ loncom/lti/ltiutils.pm 2023/01/23 18:39:46 1.17.2.3
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Utility functions for managing LON-CAPA LTI interactions
#
-# $Id: ltiutils.pm,v 1.9.2.1 2020/04/09 23:17:19 raeburn Exp $
+# $Id: ltiutils.pm,v 1.17.2.3 2023/01/23 18:39:46 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,12 +31,15 @@ package LONCAPA::ltiutils;
use strict;
use Net::OAuth;
use Digest::SHA;
+use Digest::MD5 qw(md5_hex);
+use Encode;
+use LWP::UserAgent();
use Apache::lonnet;
use Apache::loncommon;
use LONCAPA qw(:DEFAULT :match);
#
-# LON-CAPA as LTI Consumer
+# LON-CAPA as LTI Consumer or LTI Provider
#
# Determine if a nonce in POSTed data has expired.
# If unexpired, confirm it has not already been used.
@@ -48,6 +51,11 @@ use LONCAPA qw(:DEFAULT :match);
# respectively, retrieve a roster or store the grade for
# the original launch by a specific user.
#
+# When LON-CAPA is operating as a Provider, nonce checking
+# occurs when a user in course context in another LMS (the
+# Consumer) launches an external tool to access a LON-CAPA URL:
+# /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.
+#
sub check_nonce {
my ($nonce,$timestamp,$lifetime,$domain,$ltidir) = @_;
@@ -82,107 +90,31 @@ 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
-#
# 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,);
+ my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
+ $authheaders,$errors) = @_;
+ unless (ref($errors) eq 'HASH') {
+ $errors->{15} = 1;
+ return;
+ }
+ 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 {
+ $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;
@@ -198,14 +130,20 @@ sub verify_request {
#
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,
@@ -213,12 +151,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 Provider
+#
+# 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).
+#
+# 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
+#
+
+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;
+ }
+ }
+ }
+ } 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 {
+ 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 $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('UTF-8',$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 Provider
+#
+# 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);
+}
+
+#
+# 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 $enrollresult;
+}
+
+#
+# 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
+#
+# Outputs: 2
+# (a) reference to array of available LC roles.
+# (b) reference to array of LTI roles.
+#
+
+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 {
+ 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;