# The LearningOnline Network with CAPA
# Utility functions for managing LON-CAPA LTI interactions
#
# $Id: ltiutils.pm,v 1.17.2.1 2022/01/03 18:35:27 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
package LONCAPA::ltiutils;
use strict;
use Net::OAuth;
use Digest::SHA;
use Apache::lonnet;
use Apache::loncommon;
use LONCAPA qw(:DEFAULT :match);
#
# 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.
#
# When LON-CAPA is operating as a Consumer, nonce checking
# occurs when a Tool Provider launched from an instance of
# an external tool in a LON-CAPA course makes a request to
# (a) /adm/service/roster or (b) /adm/service/passback to,
# 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) = @_;
if (($ltidir eq '') || ($timestamp eq '') || ($timestamp =~ /^\D/) ||
($lifetime eq '') || ($lifetime =~ /\D/) || ($domain eq '')) {
return;
}
my $now = time;
if (($timestamp) && ($timestamp < ($now - $lifetime))) {
return;
}
if ($nonce eq '') {
return;
}
if (-e "$ltidir/$domain/$nonce") {
return;
} else {
unless (-e "$ltidir/$domain") {
unless (mkdir("$ltidir/$domain",0755)) {
return;
}
}
if (open(my $fh,'>',"$ltidir/$domain/$nonce")) {
print $fh $now;
close($fh);
return 1;
}
}
return;
}
#
# LON-CAPA as LTI Consumer
#
# Verify a signed request using the consumer_key and
# secret for the specific LTI Provider.
#
sub verify_request {
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;
}
}
#
# LON-CAPA as LTI Consumer
#
# Sign a request used to launch an instance of an external
# tool in a LON-CAPA course, using the key and secret supplied
# by the Tool Provider.
#
sub sign_params {
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($type)->new(
consumer_key => $key,
consumer_secret => $secret,
request_url => $url,
request_method => 'POST',
signature_method => $sigmethod,
timestamp => time,
nonce => $nonce,
callback => $callback,
extra_params => $paramsref,
version => '1.0',
);
$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_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 $request=new HTTP::Request('POST',$service_url);
$request->content($post);
my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
}
}
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;
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