Return to ltiutils.pm CVS log

Up to [LON-CAPA] / loncom / lti

Diff for /loncom/lti/ltiutils.pm between versions 1.17.2.5 and 1.18

version 1.17.2.5, 2024/02/27 04:13:34	version 1.18, 2022/03/29 20:12:46
Line 34 use Digest::SHA;	Line 34 use Digest::SHA;
use Digest::MD5 qw(md5_hex);	use Digest::MD5 qw(md5_hex);
use Encode;	use Encode;
use UUID::Tiny ':std';	use UUID::Tiny ':std';
use LWP::UserAgent();
use Apache::lonnet;	use Apache::lonnet;
use Apache::loncommon;	use Apache::loncommon;
use Apache::loncoursedata;	use Apache::loncoursedata;
Line 43 use Apache::lonenc();	Line 42 use Apache::lonenc();
use Apache::longroup();	use Apache::longroup();
use Apache::lonlocal;	use Apache::lonlocal;
use Math::Round();	use Math::Round();
use LONCAPA::Lond;
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);

#	#
Line 99 sub check_nonce {	Line 97 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 145 sub get_loncapa_course {	Line 143 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 158 sub get_tool_instance {	Line 156 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 189 sub get_tool_instance {	Line 187 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 212 sub get_tool_secret {	Line 210 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 ($crsdef,$ltinum);	my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');
if ($idx =~ /^c(\d+)$/) {	if (ref($lti{$idx}) eq 'HASH') {
$ltinum = $1;	%{$ltitools} = %{$lti{$idx}};
$crsdef = 1;	if ($ltitools->{'key'} eq $key) {
my %crslti = &Apache::lonnet::get_course_lti($cnum,$cdom,'consumer');	$consumer_secret = $ltitools->{'secret'};
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 263 sub get_tool_secret {	Line 242 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 ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,	my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
$authheaders,$errors) = @_;	$authheaders,$errors) = @_;
Line 310 sub verify_request {	Line 287 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') {
Line 331 sub verify_lis_item {	Line 308 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 {
Line 339 sub verify_lis_item {	Line 316 sub verify_lis_item {
}	}
} 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 {
Line 418 sub get_service_id {	Line 395 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 473 sub set_service_secret {	Line 450 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 540 sub parse_grade_xml {	Line 517 sub parse_grade_xml {
my ($text) = @_;	my ($text) = @_;
if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord sourcedGUID sourcedId") {	if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord sourcedGUID sourcedId") {
$data{$count}{sourcedid} = $text;	$data{$count}{sourcedid} = $text;
} elsif ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord result resultScore textString") {	} elsif ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord result resultScore textString") {
$data{$count}{score} = $text;	$data{$count}{score} = $text;
}	}
}, "dtext"],	}, "dtext"],
Line 676 sub lti_provider_scope {	Line 653 sub lti_provider_scope {
#	#

sub get_roster {	sub get_roster {
my ($cdom,$cnum,$ltinum,$keynum,$id,$url) = @_;	my ($id,$url,$ckey,$secret) = @_;
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 %info = ();	my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams);
my ($status,$hashref) =	if (ref($hashref) eq 'HASH') {
&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 693 sub get_roster {	Line 668 sub get_roster {
? join("&$name=", map {escape($_) } @{$hashref->{$_}})	? join("&$name=", map {escape($_) } @{$hashref->{$_}})
: &escape($hashref->{$_}) );	: &escape($hashref->{$_}) );
} keys(%{$hashref})));	} keys(%{$hashref})));
my $ua=new LWP::UserAgent;	my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
$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 745 sub get_roster {	Line 718 sub get_roster {
#	#

sub send_grade {	sub send_grade {
my ($cdom,$cnum,$crsdef,$type,$ltinum,$keynum,$id,$url,$scoretype,$sigmethod,$msgformat,$total,$possible) = @_;	my ($id,$url,$ckey,$secret,$scoretype,$sigmethod,$msgformat,$total,$possible) = @_;
my $score;	my $score;
if ($possible > 0) {	if ($possible > 0) {
if ($scoretype eq 'ratio') {	if ($scoretype eq 'ratio') {
Line 755 sub send_grade {	Line 728 sub send_grade {
$score = Math::Round::round($score);	$score = Math::Round::round($score);
} else {	} else {
$score = $total/$possible;	$score = $total/$possible;
$score = sprintf("%.4f",$score);	$score = sprintf("%.2f",$score);
}	}
}	}
if ($sigmethod eq '') {	if ($sigmethod eq '') {
Line 774 sub send_grade {	Line 747 sub send_grade {
result_statusofresult => 'final',	result_statusofresult => 'final',
result_date => $date,	result_date => $date,
);	);
my %info = (	my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams,$sigmethod);
method => $sigmethod,	if (ref($hashref) eq 'HASH') {
);
my ($status,$hashref) =
&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=new HTTP::Request('POST',$url);
$request->content(join('&',map {	$request->content(join('&',map {
my $name = escape($_);	my $name = escape($_);
Line 788 sub send_grade {	Line 756 sub send_grade {
? join("&$name=", map {escape($_) } @{$hashref->{$_}})	? join("&$name=", map {escape($_) } @{$hashref->{$_}})
: &escape($hashref->{$_}) );	: &escape($hashref->{$_}) );
} keys(%{$hashref})));	} keys(%{$hashref})));
#FIXME Need to handle case where passback failed.
}	}
} else {	} else {
srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.	srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
	my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
my $uniqmsgid = int(rand(2**32));	my $uniqmsgid = int(rand(2**32));
my $gradexml = <<END;	my $gradexml = <<END;
<?xml version = "1.0" encoding = "UTF-8"?>	<?xml version = "1.0" encoding = "UTF-8"?>
Line 805 sub send_grade {	Line 773 sub send_grade {
<imsx_POXBody>	<imsx_POXBody>
<replaceResultRequest>	<replaceResultRequest>
<resultRecord>	<resultRecord>
<sourcedGUID>	<sourcedGUID>
<sourcedId>$id</sourcedId>	<sourcedId>$id</sourcedId>
</sourcedGUID>	</sourcedGUID>
<result>	<result>
<resultScore>	<resultScore>
<language>en</language>	<language>en</language>
<textString>$score</textString>	<textString>$score</textString>
</resultScore>	</resultScore>
</result>	</result>
</resultRecord>	</resultRecord>
</replaceResultRequest>	</replaceResultRequest>
</imsx_POXBody>	</imsx_POXBody>
Line 824 END	Line 792 END
while (length($bodyhash) % 4) {	while (length($bodyhash) % 4) {
$bodyhash .= '=';	$bodyhash .= '=';
}	}
my $reqmethod = 'POST';	my $gradereq = Net::OAuth->request('consumer')->new(
my %info = (	consumer_key => $ckey,
body_hash => $bodyhash,	consumer_secret => $secret,
method => $sigmethod,	request_url => $url,
reqtype => 'consumer',	request_method => 'POST',
reqmethod => $reqmethod,	signature_method => $sigmethod,
respfmt => 'to_authorization_header',	timestamp => time(),
);	nonce => $nonce,
my %params;	body_hash => $bodyhash,
my ($status,$authheader) =	);
&Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,\%params,\%info);	$gradereq->add_required_message_params('body_hash');
if (($status eq 'ok') && ($authheader ne '')) {	$gradereq->sign();
$request = HTTP::Request->new(	$request = HTTP::Request->new(
$reqmethod,	$gradereq->request_method,
$url,	$gradereq->request_url,
[	[
'Authorization' => $authheader,	'Authorization' => $gradereq->to_authorization_header,
'Content-Type' => 'application/xml',	'Content-Type' => 'application/xml',
],	],
$gradexml,	$gradexml,
);	);
my $ua=new LWP::UserAgent;
$ua->timeout(10);
my $response=$ua->request($request);
my $message=$response->status_line;
#FIXME Handle case where pass back of score to LTI Consumer failed.
}
}	}
	my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
	my $message=$response->status_line;
	#FIXME Handle case where pass back of score to LTI Consumer failed.
}	}

sub setup_logout_callback {	sub setup_logout_callback {
my ($cdom,$cnum,$crstool,$idx,$keynum,$uname,$udom,$server,$service_url,$idsdir,$protocol,$hostname) = @_;	my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;
if ($service_url =~ m{^https?://[^/]+/}) {	if ($service_url =~ m{^https?://[^/]+/}) {
my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);	my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);
my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));	my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));
Line 866 sub setup_logout_callback {	Line 831 sub setup_logout_callback {
my %ltiparams = (	my %ltiparams = (
callback => $callback,	callback => $callback,
);	);
my %info = (	my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
respfmt => 'to_post_body',	'','','',1);
);	my $request=new HTTP::Request('POST',$service_url);
my ($status,$post) =	$request->content($post);
&Apache::lonnet::sign_lti($cdom,$cnum,$crstool,'lti','logout',$service_url,$idx,	my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
$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;	return;
Line 1072 sub enrolluser {	Line 1029 sub enrolluser {
# with LTI Instructor status.	# with LTI Instructor status.
#	#
# A list of users is obtained by a call to get_roster()	# A list of users is obtained by a call to get_roster()
# if the calling Consumer support the LTI extension:	# if the calling Consumer support the LTI extension:
# Context Memberships Service.	# Context Memberships Service.
#	#
# If a user included in the retrieved list does not currently	# If a user included in the retrieved list does not currently
# have a user account in LON-CAPA, an account will be created.	# have a user account in LON-CAPA, an account will be created.
Line 1109 sub enrolluser {	Line 1066 sub enrolluser {

sub batchaddroster {	sub batchaddroster {
my ($item) = @_;	my ($item) = @_;
return unless((ref($item) eq 'HASH') &&	return unless(ref($item) eq 'HASH');
(ref($item->{'ltiref'}) eq 'HASH'));	return unless (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 1142 sub batchaddroster {	Line 1098 sub batchaddroster {
if (ref($item->{'possroles'}) eq 'ARRAY') {	if (ref($item->{'possroles'}) eq 'ARRAY') {
@possroles = @{$item->{'possroles'}};	@possroles = @{$item->{'possroles'}};
}	}
if (($id ne '') && ($url ne '')) {	if (($ckey ne '') && ($secret ne '') && ($id ne '') && ($url ne '')) {
my %data = &get_roster($cdom,$cnum,$ltinum,$keynum,$id,$url);	my %data = &get_roster($id,$url,$ckey,$secret);
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 1377 sub get_lc_roles {	Line 1333 sub get_lc_roles {
# LON-CAPA as LTI Provider	# LON-CAPA as LTI Provider
#	#
# Compares current start and dates for a user's role	# Compares current start and dates for a user's role
# with dates to apply for the same user/role to	# with dates to apply for the same user/role to
# determine if there is a change between the current	# determine if there is a change between the current
# ones and the updated ones.	# ones and the updated ones.
#	#

sub datechange_check {	sub datechange_check {
my ($oldstart,$oldend,$startdate,$enddate) = @_;	my ($oldstart,$oldend,$startdate,$enddate) = @_;

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

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

Removed from v.1.17.2.5
changed lines
	Added in v.1.18