loncom/lti/ltiutils.pm - diff

Return to ltiutils.pm CVS log

Up to [LON-CAPA] / loncom / lti

Diff for /loncom/lti/ltiutils.pm between versions 1.11 and 1.17.2.6

version 1.11, 2018/05/28 23:26:04	version 1.17.2.6, 2025/01/16 21:52:05
Line 31 package LONCAPA::ltiutils;	Line 31 package LONCAPA::ltiutils;
use strict;	use strict;
use Net::OAuth;	use Net::OAuth;
use Digest::SHA;	use Digest::SHA;
	use Digest::MD5 qw(md5_hex);
	use Encode;
use UUID::Tiny ':std';	use UUID::Tiny ':std';
	use HTTP::Status;
	use LWP::UserAgent();
use Apache::lonnet;	use Apache::lonnet;
use Apache::loncommon;	use Apache::loncommon;
use Apache::loncoursedata;	use Apache::loncoursedata;
use Apache::lonuserutils;	use Apache::lonuserutils;
use Apache::lonenc();	use Apache::lonenc();
use Apache::longroup();	use Apache::longroup();
	use Apache::lonlocal;
use Math::Round();	use Math::Round();
	use LONCAPA::Lond;
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);

#	#
Line 94 sub check_nonce {	Line 100 sub check_nonce {
# LON-CAPA as LTI Consumer	# LON-CAPA as LTI Consumer
#	#
# Determine the domain and the courseID of the LON-CAPA course	# Determine the domain and the courseID of the LON-CAPA course
# for which access is needed by a Tool Provider -- either to	# for which access is needed by a Tool Provider -- either to
# retrieve a roster or store the grade for an instance of an	# retrieve a roster or store the grade for an instance of an
# external tool in the course.	# external tool in the course.
#	#

Line 140 sub get_loncapa_course {	Line 146 sub get_loncapa_course {
#	#
# LON-CAPA as LTI Consumer	# LON-CAPA as LTI Consumer
#	#
# Determine the symb and (optionally) LON-CAPA user for an	# Determine the symb and (optionally) LON-CAPA user for an
# instance of an external tool in a course -- either to	# instance of an external tool in a course -- either to
# to retrieve a roster or store a grade.	# to retrieve a roster or store a grade.
#	#
# Use the digested symb to lookup the real symb in exttools.db	# Use the digested symb to lookup the real symb in exttools.db
Line 153 sub get_tool_instance {	Line 159 sub get_tool_instance {
my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_;	my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_;
return unless (ref($errors) eq 'HASH');	return unless (ref($errors) eq 'HASH');
my ($marker,$symb,$uname,$udom);	my ($marker,$symb,$uname,$udom);
my @keys = ($digsymb);	my @keys = ($digsymb);
if ($diguser) {	if ($diguser) {
push(@keys,$diguser);	push(@keys,$diguser);
}	}
Line 184 sub get_tool_instance {	Line 190 sub get_tool_instance {
# LON-CAPA as LTI Consumer	# LON-CAPA as LTI Consumer
#	#
# Retrieve data needed to validate a request from a Tool Provider	# 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	# for a roster or to store a grade for an instance of an external
# tool in a LON-CAPA course.	# tool in a LON-CAPA course.
#	#
# Retrieve the Consumer key and Consumer secret from the domain	# Retrieve the Consumer key and Consumer secret from the domain
# configuration or the Tool Provider ID stored in the	# configuration or the Tool Provider ID stored in the
# exttool_$marker db file and compare the Consumer key with the	# exttool_$marker db file and compare the Consumer key with the
# one in the POSTed data.	# one in the POSTed data.
#	#
# Side effect is to populate the $toolsettings hashref with the	# Side effect is to populate the $toolsettings hashref with the
# contents of the .db file (instance of tool in course) and the	# contents of the .db file (instance of tool in course) and the
# $ltitools hashref with the configuration for the tool (at	# $ltitools hashref with the configuration for the tool (at
# domain level).	# domain level).
Line 207 sub get_tool_secret {	Line 213 sub get_tool_secret {
%{$toolsettings}=&Apache::lonnet::dump('exttool_'.$marker,$cdom,$cnum);	%{$toolsettings}=&Apache::lonnet::dump('exttool_'.$marker,$cdom,$cnum);
if ($toolsettings->{'id'}) {	if ($toolsettings->{'id'}) {
my $idx = $toolsettings->{'id'};	my $idx = $toolsettings->{'id'};
my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');	my ($crsdef,$ltinum);
if (ref($lti{$idx}) eq 'HASH') {	if ($idx =~ /^c(\d+)$/) {
%{$ltitools} = %{$lti{$idx}};	$ltinum = $1;
if ($ltitools->{'key'} eq $key) {	$crsdef = 1;
$consumer_secret = $ltitools->{'secret'};	my %crslti = &Apache::lonnet::get_course_lti($cnum,$cdom,'consumer');
	if (ref($crslti{$ltinum}) eq 'HASH') {
	%{$ltitools} = %{$crslti{$ltinum}};
	} else {
	undef($ltinum);
	}
	} elsif ($idx =~ /^\d+$/) {
	my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');
	if (ref($lti{$idx}) eq 'HASH') {
	%{$ltitools} = %{$lti{$idx}};
	$ltinum = $idx;
	}
	}
	if ($ltinum ne '') {
	my $loncaparev = &Apache::lonnet::get_server_loncaparev($cdom);
	my $keynum = $ltitools->{'cipher'};
	my ($poss_key,$poss_secret) =
	&LONCAPA::Lond::get_lti_credentials($cdom,$cnum,$crsdef,'tools',$ltinum,$keynum,$loncaparev);
	if ($poss_key eq $key) {
	$consumer_secret = $poss_secret;
$nonce_lifetime = $ltitools->{'lifetime'};	$nonce_lifetime = $ltitools->{'lifetime'};
} else {	} else {
$errors->{11} = 1;	$errors->{11} = 1;
Line 239 sub get_tool_secret {	Line 264 sub get_tool_secret {
# secret for the specific LTI Provider.	# secret for the specific LTI Provider.
#	#

	# FIXME Move to Lond.pm and perform on course's homeserver

sub verify_request {	sub verify_request {
my ($params,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$errors) = @_;	my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
return unless (ref($errors) eq 'HASH');	$authheaders,$errors) = @_;
my $request = Net::OAuth->request('request token')->from_hash($params,	unless (ref($errors) eq 'HASH') {
request_url => $protocol.'://'.$hostname.$requri,	$errors->{15} = 1;
request_method => $reqmethod,	return;
consumer_secret => $consumer_secret,);	}
	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()) {	unless ($request->verify()) {
$errors->{15} = 1;	$errors->{15} = 1;
return;	return;
Line 270 sub verify_request {	Line 311 sub verify_request {

sub verify_lis_item {	sub verify_lis_item {
my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;	my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;
return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&	return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&
(ref($errors) eq 'HASH'));	(ref($errors) eq 'HASH'));
my ($has_action, $valid_for);	my ($has_action, $valid_for);
if ($context eq 'grade') {	if ($context eq 'grade') {
$has_action = $ltitools->{'passback'};	$has_action = $ltitools->{'passback'};
$valid_for = $ltitools->{'passbackvalid'}	$valid_for = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
} elsif ($context eq 'roster') {	} elsif ($context eq 'roster') {
$has_action = $ltitools->{'roster'};	$has_action = $ltitools->{'roster'};
$valid_for = $ltitools->{'rostervalid'};	$valid_for = $ltitools->{'rostervalid'};
Line 291 sub verify_lis_item {	Line 332 sub verify_lis_item {
my $expected_sig;	my $expected_sig;
if ($context eq 'grade') {	if ($context eq 'grade') {
my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;	my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;
$expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0];	$expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0];
if ($expected_sig eq $sigrec) {	if ($expected_sig eq $sigrec) {
return 1;	return 1;
} else {	} else {
$errors->{17} = 1;	$errors->{18} = 1;
}	}
} elsif ($context eq 'roster') {	} elsif ($context eq 'roster') {
my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;	my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;
$expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0];	$expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0];
if ($expected_sig eq $sigrec) {	if ($expected_sig eq $sigrec) {
return 1;	return 1;
} else {	} else {
$errors->{18} = 1;	$errors->{19} = 1;
}	}
}	}
} else {	} else {
$errors->{19} = 1;	$errors->{20} = 1;
}	}
} else {	} else {
$errors->{20} = 1;	$errors->{21} = 1;
}	}
return;	return;
}	}
Line 324 sub verify_lis_item {	Line 365 sub verify_lis_item {
#	#

sub sign_params {	sub sign_params {
my ($url,$key,$secret,$sigmethod,$paramsref) = @_;	my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_;
return unless (ref($paramsref) eq 'HASH');	return unless (ref($paramsref) eq 'HASH');
if ($sigmethod eq '') {	if ($sigmethod eq '') {
$sigmethod = 'HMAC-SHA1';	$sigmethod = 'HMAC-SHA1';
}	}
	if ($type eq '') {
	$type = 'request token';
	}
	if ($callback eq '') {
	$callback = 'about:blank',
	}
srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.	srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));	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_key => $key,
consumer_secret => $secret,	consumer_secret => $secret,
request_url => $url,	request_url => $url,
Line 339 sub sign_params {	Line 386 sub sign_params {
signature_method => $sigmethod,	signature_method => $sigmethod,
timestamp => time,	timestamp => time,
nonce => $nonce,	nonce => $nonce,
callback => 'about:blank',	callback => $callback,
extra_params => $paramsref,	extra_params => $paramsref,
version => '1.0',	version => '1.0',
);	);
$request->sign;	$request->sign();
return $request->to_hash();	if ($post) {
	return $request->to_post_body();
	} else {
	return $request->to_hash();
	}
}	}

#	#
Line 368 sub get_service_id {	Line 419 sub get_service_id {
# grade store). An existing secret past its expiration date	# grade store). An existing secret past its expiration date
# will be stored as old<service name>secret, and a new secret	# will be stored as old<service name>secret, and a new secret
# <service name>secret will be stored.	# <service name>secret will be stored.
#	#
# Secrets are specific to service name and to the tool instance	# Secrets are specific to service name and to the tool instance
# (and are stored in the exttool_$marker db file).	# (and are stored in the exttool_$marker db file).
# The time period a secret remains valid is determined by the	# The time period a secret remains valid is determined by the
# domain configuration for the specific tool and the service.	# domain configuration for the specific tool and the service.
#	#

sub set_service_secret {	sub set_service_secret {
my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_;	my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_;
Line 381 sub set_service_secret {	Line 432 sub set_service_secret {
my $warning;	my $warning;
my ($needsnew,$oldsecret,$lifetime);	my ($needsnew,$oldsecret,$lifetime);
if ($name eq 'grade') {	if ($name eq 'grade') {
$lifetime = $ltitools->{'passbackvalid'}	$lifetime = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
} elsif ($name eq 'roster') {	} elsif ($name eq 'roster') {
$lifetime = $ltitools->{'rostervalid'};	$lifetime = $ltitools->{'rostervalid'};
}	}
if ($toolsettings->{$name} eq '') {	if ($toolsettings->{$name.'secret'} eq '') {
$needsnew = 1;	$needsnew = 1;
} elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) {	} elsif (($toolsettings->{$name.'secretdate'} + $lifetime) < $now) {
$oldsecret = $toolsettings->{$name.'secret'};	$oldsecret = $toolsettings->{$name.'secret'};
$needsnew = 1;	$needsnew = 1;
}	}
Line 423 sub set_service_secret {	Line 474 sub set_service_secret {
#	#
# LON-CAPA as LTI Consumer	# LON-CAPA as LTI Consumer
#	#
# Add a lock key to exttools.db for the instance of an external tool	# Add a lock key to exttools.db for the instance of an external tool
# when generating and storing a service secret.	# when generating and storing a service secret.
#	#

Line 465 sub release_tool_lock {	Line 516 sub release_tool_lock {
}	}

#	#
	# LON-CAPA as LTI Consumer
	#
	# Parse XML containing grade data sent by an LTI Provider
	#

	sub parse_grade_xml {
	my ($xml) = @_;
	my %data = ();
	my $count = 0;
	my @state = ();
	my $p = HTML::Parser->new(
	xml_mode => 1,
	start_h =>
	[sub {
	my ($tagname, $attr) = @_;
	push(@state,$tagname);
	if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord") {
	$count ++;
	}
	}, "tagname, attr"],
	text_h =>
	[sub {
	my ($text) = @_;
	if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord sourcedGUID sourcedId") {
	$data{$count}{sourcedid} = $text;
	} elsif ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord result resultScore textString") {
	$data{$count}{score} = $text;
	}
	}, "dtext"],
	end_h =>
	[sub {
	my ($tagname) = @_;
	pop @state;
	}, "tagname"],
	);
	$p->parse($xml);
	$p->eof;
	return %data;
	}

	#
# LON-CAPA as LTI Provider	# LON-CAPA as LTI Provider
#	#
# Use the part of the launch URL after /adm/lti to determine	# Use the part of the launch URL after /adm/lti to determine
Line 487 sub lti_provider_scope {	Line 579 sub lti_provider_scope {
$scope = 'map';	$scope = 'map';
$realuri = $tail;	$realuri = $tail;
} else {	} else {
my ($map,$resid,$url) = &Apache::lonnet::decode_symb($tail);	my $symb = $tail;
	$symb =~ s{^/}{};
	my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
$realuri = &Apache::lonnet::clutter($url);	$realuri = &Apache::lonnet::clutter($url);
if ($url =~ /\.sequence$/) {	if ($url =~ /\.sequence$/) {
$scope = 'map';	$scope = 'map';
} else {	} else {
$scope = 'resource';	$scope = 'resource';
$realuri .= '?symb='.$tail;	$realuri .= '?symb='.$symb;
$passkey = $tail;	$passkey = $symb;
if ($getunenc) {	if ($getunenc) {
$unencsymb = $tail;	$unencsymb = $symb;
}	}
}	}
}	}
Line 506 sub lti_provider_scope {	Line 600 sub lti_provider_scope {
$scope = 'map';	$scope = 'map';
$realuri = $tail;	$realuri = $tail;
} else {	} else {
my ($map,$resid,$url) = &Apache::lonnet::decode_symb($tail);	my $symb = $tail;
	$symb =~ s{^/?res/}{};
	my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
$realuri = &Apache::lonnet::clutter($url);	$realuri = &Apache::lonnet::clutter($url);
if ($url =~ /\.sequence$/) {	if ($url =~ /\.sequence$/) {
$scope = 'map';	$scope = 'map';
} else {	} else {
$scope = 'resource';	$scope = 'resource';
$realuri .= '?symb='.$tail;	$realuri .= '?symb='.$symb;
$passkey = $tail;	$passkey = $symb;
if ($getunenc) {	if ($getunenc) {
$unencsymb = $tail;	$unencsymb = $symb;
}	}
}	}
}	}
Line 561 sub lti_provider_scope {	Line 657 sub lti_provider_scope {
} elsif (($tail =~ m{^/$cdom/$cnum$}) \|\| ($tail eq '')) {	} elsif (($tail =~ m{^/$cdom/$cnum$}) \|\| ($tail eq '')) {
$scope = 'course';	$scope = 'course';
$realuri = '/adm/navmaps';	$realuri = '/adm/navmaps';
$passkey = $tail;	$passkey = '';
}	}
if ($scope eq 'map') {	if ($scope eq 'map') {
$passkey = $realuri;	$passkey = $realuri;
Line 573 sub lti_provider_scope {	Line 669 sub lti_provider_scope {
}	}
}	}

	#
	# LON-CAPA as LTI Provider
	#
	# Obtain a list of course personnel and students from
	# the LTI Consumer which launched this instance.
	#

sub get_roster {	sub get_roster {
my ($id,$url,$ckey,$secret) = @_;	my ($cdom,$cnum,$ltinum,$keynum,$id,$url) = @_;
my %ltiparams = (	my %ltiparams = (
lti_version => 'LTI-1p0',	lti_version => 'LTI-1p0',
lti_message_type => 'basic-lis-readmembershipsforcontext',	lti_message_type => 'basic-lis-readmembershipsforcontext',
ext_ims_lis_memberships_id => $id,	ext_ims_lis_memberships_id => $id,
);	);
my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams);	my %info = ();
if (ref($hashref) eq 'HASH') {	my ($status,$hashref) =
	&Apache::lonnet::sign_lti($cdom,$cnum,'','lti','roster',$url,$ltinum,$keynum,\%ltiparams,\%info);
	if (($status eq 'ok') && (ref($hashref) eq 'HASH')) {
my $request=new HTTP::Request('POST',$url);	my $request=new HTTP::Request('POST',$url);
$request->content(join('&',map {	$request->content(join('&',map {
my $name = escape($_);	my $name = escape($_);
Line 589 sub get_roster {	Line 694 sub get_roster {
? join("&$name=", map {escape($_) } @{$hashref->{$_}})	? join("&$name=", map {escape($_) } @{$hashref->{$_}})
: &escape($hashref->{$_}) );	: &escape($hashref->{$_}) );
} keys(%{$hashref})));	} keys(%{$hashref})));
my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);	my $ua=new LWP::UserAgent;
	$ua->timeout(10);
	my $response=$ua->request($request);
my $message=$response->status_line;	my $message=$response->status_line;
if (($response->is_success) && ($response->content ne '')) {	if (($response->is_success) && ($response->content ne '')) {
my %data = ();	my %data = ();
Line 631 sub get_roster {	Line 738 sub get_roster {
return;	return;
}	}

	#
	# LON-CAPA as LTI Provider
	#
	# Passback a grade for a user to the LTI Consumer which originally
	# provided the lis_result_sourcedid
	#

sub send_grade {	sub send_grade {
my ($id,$url,$ckey,$secret,$scoretype,$total,$possible) = @_;	my ($cdom,$cnum,$crsdef,$type,$ltinum,$keynum,$id,$url,$scoretype,$sigmethod,$msgformat,$total,$possible) = @_;
my $score;	my $score;
if ($possible > 0) {	if ($possible > 0) {
if ($scoretype eq 'ratio') {	if ($scoretype eq 'ratio') {
Line 642 sub send_grade {	Line 756 sub send_grade {
$score = Math::Round::round($score);	$score = Math::Round::round($score);
} else {	} else {
$score = $total/$possible;	$score = $total/$possible;
$score = sprintf("%.2f",$score);	$score = sprintf("%.4f",$score);
}	}
}	}
my $date = &Apache::loncommon::utc_string(time);	if ($sigmethod eq '') {
my %ltiparams = (	$sigmethod = 'HMAC-SHA1';
lti_version => 'LTI-1p0',	}
lti_message_type => 'basic-lis-updateresult',	my ($request,$sendit,$respcode,$result);
sourcedid => $id,	if ($msgformat eq '1.0') {
result_resultscore_textstring => $score,	my $date = &Apache::loncommon::utc_string(time);
result_resultscore_language => 'en-US',	my %ltiparams = (
result_resultvaluesourcedid => $scoretype,	lti_version => 'LTI-1p0',
result_statusofresult => 'final',	lti_message_type => 'basic-lis-updateresult',
result_date => $date,	sourcedid => $id,
);	result_resultscore_textstring => $score,
my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams);	result_resultscore_language => 'en-US',
if (ref($hashref) eq 'HASH') {	result_resultvaluesourcedid => $scoretype,
my $request=new HTTP::Request('POST',$url);	result_statusofresult => 'final',
$request->content(join('&',map {	result_date => $date,
my $name = escape($_);	);
"$name=" . ( ref($hashref->{$_}) eq 'ARRAY'	my %info = (
? join("&$name=", map {escape($_) } @{$hashref->{$_}})	method => $sigmethod,
: &escape($hashref->{$_}) );	);
} keys(%{$hashref})));	my ($status,$hashref) =
my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);	&Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,
	\%ltiparams,\%info);
	if (($status eq 'ok') && (ref($hashref) eq 'HASH')) {
	$request=new HTTP::Request('POST',$url);
	$request->content(join('&',map {
	my $name = escape($_);
	"$name=" . ( ref($hashref->{$_}) eq 'ARRAY'
	? join("&$name=", map {escape($_) } @{$hashref->{$_}})
	: &escape($hashref->{$_}) );
	} keys(%{$hashref})));
	$sendit = 1;
	}
	} else {
	srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
	my $uniqmsgid = int(rand(2**32));
	my $gradexml = <<END;
	<?xml version = "1.0" encoding = "UTF-8"?>
	<imsx_POXEnvelopeRequest xmlns = "http://www.imsglobal.org/services/ltiv1p1/xsd/imsoms_v1p0">
	<imsx_POXHeader>
	<imsx_POXRequestHeaderInfo>
	<imsx_version>V1.0</imsx_version>
	<imsx_messageIdentifier>$uniqmsgid</imsx_messageIdentifier>
	</imsx_POXRequestHeaderInfo>
	</imsx_POXHeader>
	<imsx_POXBody>
	<replaceResultRequest>
	<resultRecord>
	<sourcedGUID>
	<sourcedId>$id</sourcedId>
	</sourcedGUID>
	<result>
	<resultScore>
	<language>en</language>
	<textString>$score</textString>
	</resultScore>
	</result>
	</resultRecord>
	</replaceResultRequest>
	</imsx_POXBody>
	</imsx_POXEnvelopeRequest>
	END
	chomp($gradexml);
	my $bodyhash = Digest::SHA::sha1_base64($gradexml);
	while (length($bodyhash) % 4) {
	$bodyhash .= '=';
	}
	my $reqmethod = 'POST';
	my %info = (
	body_hash => $bodyhash,
	method => $sigmethod,
	reqtype => 'consumer',
	reqmethod => $reqmethod,
	respfmt => 'to_authorization_header',
	);
	my %params;
	my ($status,$authheader) =
	&Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,\%params,\%info);
	if (($status eq 'ok') && ($authheader ne '')) {
	$request = HTTP::Request->new(
	$reqmethod,
	$url,
	[
	'Authorization' => $authheader,
	'Content-Type' => 'application/xml',
	],
	$gradexml,
	);
	$sendit = 1;
	}
	}
	if ($sendit) {
	my $ua=new LWP::UserAgent;
	$ua->timeout(10);
	my $response=$ua->request($request);
my $message=$response->status_line;	my $message=$response->status_line;
#FIXME Handle case where pass back of score to LTI Consumer failed.	$respcode = $response->code;
	$result = HTTP::Status::status_message($respcode);
	}
	return ($sendit,$score,$respcode,$result);
	}

	sub setup_logout_callback {
	my ($cdom,$cnum,$crstool,$idx,$keynum,$uname,$udom,$server,$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 %info = (
	respfmt => 'to_post_body',
	);
	my ($status,$post) =
	&Apache::lonnet::sign_lti($cdom,$cnum,$crstool,'lti','logout',$service_url,$idx,
	$keynum,\%ltiparams,\%info);
	if (($status eq 'ok') && ($post ne '')) {
	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 {	sub create_user {
my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results,	my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results,
$curr_rules,$got_rules) = @_;	$curr_rules,$got_rules) = @_;
Line 768 sub create_user {	Line 997 sub create_user {
return $result;	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 {	sub create_passwd {
my $passwd = '';	my $passwd = '';
	srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
my @letts = ("a".."z");	my @letts = ("a".."z");
for (my $i=0; $i<8; $i++) {	for (my $i=0; $i<8; $i++) {
my $lettnum = int(rand(2));	my $lettnum = int(rand(2));
Line 788 sub create_passwd {	Line 1026 sub create_passwd {
return ($passwd);	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 {	sub enrolluser {
my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end) = @_;	my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end,$selfenroll) = @_;
my $enrollresult;	my $enrollresult;
my $area = "/$cdom/$cnum";	my $area = "/$cdom/$cnum";
if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) {	if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) {
Line 801 sub enrolluser {	Line 1051 sub enrolluser {
$enrollresult =	$enrollresult =
&Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,	&Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,
undef,undef,$sec,$end,$start,	undef,undef,$sec,$end,$start,
'ltienroll',undef,$cdom.'_'.$cnum,undef,	'ltienroll',undef,$cdom.'_'.$cnum,
'ltienroll','',$instcid);	$selfenroll,'ltienroll','',$instcid);
} elsif ($role =~ /^(cc\|in\|ta\|ep)$/) {	} elsif ($role =~ /^(cc\|in\|ta\|ep)$/) {
$enrollresult =	$enrollresult =
&Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start,	&Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start,
undef,undef,'ltienroll');	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;	return $enrollresult;
}	}

	#
	# LON-CAPA as LTI Provider
	#
	# Batch addition of users following LTI launch by a user
	# with LTI Instructor status.
	#
	# A list of users is obtained by a call to get_roster()
	# if the calling Consumer support the LTI extension:
	# Context Memberships Service.
	#
	# If a user included in the retrieved list does not currently
	# have a user account in LON-CAPA, an account will be created.
	#
	# If a user already has an account, and the same role and
	# section assigned (currently active), then no change will
	# be made for that user.
	#
	# Information available for new users (besides username and)
	# role) may include: first name, last name, full name (from
	# which middle name will be extracted), permanent e-mail address,
	# and lis_result_sourcedid (for passback of grades).
	#
	# If grades are to be passed back, the passback url will be
	# the same as for the current user's session.
	#
	# The roles which may be assigned will be determined from the
	# LTI roles included in the retrieved roster, and the mapping
	# of LTI roles to LON-CAPA roles configured for this LTI Consumer
	# in the domain configuration.
	#
	# Course Coordinator roles will only be assigned if the current
	# user is also the course owner.
	#
	# The domain configuration for the corresponding Consumer can include
	# a section to assign to LTI users. If the roster includes students
	# any existing student roles with a different section will be expired,
	# and a role in the LTI section will be assigned.
	#
	# For non-student rules (excluding Course Coordinator) a role will be
	# assigned with the LTI section )or no section, if one is not rquired.
	#

sub batchaddroster {	sub batchaddroster {
my ($item) = @_;	my ($item) = @_;
return unless(ref($item) eq 'HASH');	return unless((ref($item) eq 'HASH') &&
return unless (ref($item->{'ltiref'}) eq 'HASH');	(ref($item->{'ltiref'}) eq 'HASH'));
my ($cdom,$cnum) = split(/_/,$item->{'cid'});	my ($cdom,$cnum) = split(/_/,$item->{'cid'});
	return if (($cdom eq '') \|\| ($cnum eq ''));
my $udom = $cdom;	my $udom = $cdom;
my $id = $item->{'id'};	my $id = $item->{'id'};
my $url = $item->{'url'};	my $url = $item->{'url'};
	my $ltinum = $item->{'lti'};
	my $keynum = $item->{'ltiref'}->{'cipher'};
my @intdoms;	my @intdoms;
my $intdomsref = $item->{'intdoms'};	my $intdomsref = $item->{'intdoms'};
if (ref($intdomsref) eq 'ARRAY') {	if (ref($intdomsref) eq 'ARRAY') {
@intdoms = @{$intdomsref};	@intdoms = @{$intdomsref};
}	}
my $uriscope = $item->{'uriscope'};	my $uriscope = $item->{'uriscope'};
my $ckey = $item->{'ltiref'}->{'key'};
my $secret = $item->{'ltiref'}->{'secret'};
my $section = $item->{'ltiref'}->{'section'};	my $section = $item->{'ltiref'}->{'section'};
$section =~ s/\W//g;	$section =~ s/\W//g;
if ($section eq 'none') {	if ($section eq 'none') {
Line 845 sub batchaddroster {	Line 1148 sub batchaddroster {
if (ref($item->{'possroles'}) eq 'ARRAY') {	if (ref($item->{'possroles'}) eq 'ARRAY') {
@possroles = @{$item->{'possroles'}};	@possroles = @{$item->{'possroles'}};
}	}
if (($ckey ne '') && ($secret ne '') && ($id ne '') && ($url ne '')) {	if (($id ne '') && ($url ne '')) {
my %data = &get_roster($id,$url,$ckey,$secret);	my %data = &get_roster($cdom,$cnum,$ltinum,$keynum,$id,$url);
if (keys(%data) > 0) {	if (keys(%data) > 0) {
my (%rulematch,%inst_results,%curr_rules,%got_rules,%alerts,%info);	my (%rulematch,%inst_results,%curr_rules,%got_rules,%alerts,%info);
my %coursehash = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);	my %coursehash = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);
Line 1015 sub batchaddroster {	Line 1318 sub batchaddroster {
return;	return;
}	}

	#
	# 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 {	sub get_lc_roles {
my ($rolestr,$allowedroles,$maproles) = @_;	my ($rolestr,$allowedroles,$maproles) = @_;
my (@ltiroles,@lcroles);	my (@ltiroles,@lcroles);
Line 1055 sub get_lc_roles {	Line 1379 sub get_lc_roles {
return (\@lcroles,\@ltiroles);	return (\@lcroles,\@ltiroles);
}	}

	#
	# LON-CAPA as LTI Provider
	#
	# Compares current start and dates for a user's role
	# with dates to apply for the same user/role to
	# determine if there is a change between the current
	# ones and the updated ones.
	#

sub datechange_check {	sub datechange_check {
my ($oldstart,$oldend,$startdate,$enddate) = @_;	my ($oldstart,$oldend,$startdate,$enddate) = @_;
my $datechange = 0;	my $datechange = 0;
Line 1073 sub datechange_check {	Line 1406 sub datechange_check {
return $datechange;	return $datechange;
}	}

	#
	# LON-CAPA as LTI Provider
	#
	# Store the URL used by a specific LTI Consumer to process grades passed back
	# by an LTI Provider.
	#

sub store_passbackurl {	sub store_passbackurl {
my ($ltinum,$pburl,$cdom,$cnum) = @_;	my ($ltinum,$pburl,$cdom,$cnum) = @_;
my %history = &Apache::lonnet::restore($ltinum,'passbackurl',$cdom,$cnum);	my %history = &Apache::lonnet::restore($ltinum,'passbackurl',$cdom,$cnum);

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.11
changed lines
	Added in v.1.17.2.6