|
version 1.5, 2018/01/04 12:19:25
|
version 1.17, 2019/07/18 18:28:46
|
|
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 UUID::Tiny ':std'; |
use UUID::Tiny ':std'; |
| use Apache::lonnet; |
use Apache::lonnet; |
| use Apache::loncommon; |
use Apache::loncommon; |
| |
use Apache::loncoursedata; |
| |
use Apache::lonuserutils; |
| |
use Apache::lonenc(); |
| |
use Apache::longroup(); |
| |
use Apache::lonlocal; |
| |
use Math::Round(); |
| use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
| |
|
| # |
# |
|
Line 235 sub get_tool_secret {
|
Line 242 sub get_tool_secret {
|
| # |
# |
| |
|
| 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_lis_item {
|
Line 291 sub verify_lis_item {
|
| 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 290 sub verify_lis_item {
|
Line 311 sub verify_lis_item {
|
| 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; |
|
Line 298 sub verify_lis_item {
|
Line 319 sub verify_lis_item {
|
| 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 319 sub verify_lis_item {
|
Line 340 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. |
| 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 333 sub sign_params {
|
Line 361 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 375 sub set_service_secret {
|
Line 407 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 458 sub release_tool_lock {
|
Line 490 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 |
| |
# |
| |
# 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; |
| |
} |
| |
} |
| |
|
| |
# |
| |
# LON-CAPA as LTI Provider |
| |
# |
| |
# Obtain a list of course personnel and students from |
| |
# the LTI Consumer which launched this instance. |
| |
# |
| |
|
| |
sub get_roster { |
| |
my ($id,$url,$ckey,$secret) = @_; |
| |
my %ltiparams = ( |
| |
lti_version => 'LTI-1p0', |
| |
lti_message_type => 'basic-lis-readmembershipsforcontext', |
| |
ext_ims_lis_memberships_id => $id, |
| |
); |
| |
my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams); |
| |
if (ref($hashref) eq 'HASH') { |
| |
my $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}))); |
| |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10); |
| |
my $message=$response->status_line; |
| |
if (($response->is_success) && ($response->content ne '')) { |
| |
my %data = (); |
| |
my $count = 0; |
| |
my @state = (); |
| |
my @items = ('user_id','roles','person_sourcedid','person_name_given','person_name_family', |
| |
'person_contact_email_primary','person_name_full','lis_result_sourcedid'); |
| |
my $p = HTML::Parser->new |
| |
( |
| |
xml_mode => 1, |
| |
start_h => |
| |
[sub { |
| |
my ($tagname, $attr) = @_; |
| |
push(@state,$tagname); |
| |
if ("@state" eq "message_response memberships member") { |
| |
$count ++; |
| |
} |
| |
}, "tagname, attr"], |
| |
text_h => |
| |
[sub { |
| |
my ($text) = @_; |
| |
foreach my $item (@items) { |
| |
if ("@state" eq "message_response memberships member $item") { |
| |
$data{$count}{$item} = $text; |
| |
} |
| |
} |
| |
}, "dtext"], |
| |
end_h => |
| |
[sub { |
| |
my ($tagname) = @_; |
| |
pop @state; |
| |
}, "tagname"], |
| |
); |
| |
$p->parse($response->content); |
| |
$p->eof; |
| |
return %data; |
| |
} |
| |
} |
| |
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 { |
| |
my ($id,$url,$ckey,$secret,$scoretype,$sigmethod,$msgformat,$total,$possible) = @_; |
| |
my $score; |
| |
if ($possible > 0) { |
| |
if ($scoretype eq 'ratio') { |
| |
$score = Math::Round::round($total).'/'.Math::Round::round($possible); |
| |
} elsif ($scoretype eq 'percentage') { |
| |
$score = (100.0*$total)/$possible; |
| |
$score = Math::Round::round($score); |
| |
} else { |
| |
$score = $total/$possible; |
| |
$score = sprintf("%.2f",$score); |
| |
} |
| |
} |
| |
if ($sigmethod eq '') { |
| |
$sigmethod = 'HMAC-SHA1'; |
| |
} |
| |
my $request; |
| |
if ($msgformat eq '1.0') { |
| |
my $date = &Apache::loncommon::utc_string(time); |
| |
my %ltiparams = ( |
| |
lti_version => 'LTI-1p0', |
| |
lti_message_type => 'basic-lis-updateresult', |
| |
sourcedid => $id, |
| |
result_resultscore_textstring => $score, |
| |
result_resultscore_language => 'en-US', |
| |
result_resultvaluesourcedid => $scoretype, |
| |
result_statusofresult => 'final', |
| |
result_date => $date, |
| |
); |
| |
my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams,$sigmethod); |
| |
if (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}))); |
| |
} |
| |
} else { |
| |
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 $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 $gradereq = Net::OAuth->request('consumer')->new( |
| |
consumer_key => $ckey, |
| |
consumer_secret => $secret, |
| |
request_url => $url, |
| |
request_method => 'POST', |
| |
signature_method => $sigmethod, |
| |
timestamp => time(), |
| |
nonce => $nonce, |
| |
body_hash => $bodyhash, |
| |
); |
| |
$gradereq->add_required_message_params('body_hash'); |
| |
$gradereq->sign(); |
| |
$request = HTTP::Request->new( |
| |
$gradereq->request_method, |
| |
$gradereq->request_url, |
| |
[ |
| |
'Authorization' => $gradereq->to_authorization_header, |
| |
'Content-Type' => 'application/xml', |
| |
], |
| |
$gradexml, |
| |
); |
| |
} |
| |
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 { |
| |
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 |
| |
# |
| |
# 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 { |
| |
my ($item) = @_; |
| |
return unless(ref($item) eq 'HASH'); |
| |
return unless (ref($item->{'ltiref'}) eq 'HASH'); |
| |
my ($cdom,$cnum) = split(/_/,$item->{'cid'}); |
| |
my $udom = $cdom; |
| |
my $id = $item->{'id'}; |
| |
my $url = $item->{'url'}; |
| |
my @intdoms; |
| |
my $intdomsref = $item->{'intdoms'}; |
| |
if (ref($intdomsref) eq 'ARRAY') { |
| |
@intdoms = @{$intdomsref}; |
| |
} |
| |
my $uriscope = $item->{'uriscope'}; |
| |
my $ckey = $item->{'ltiref'}->{'key'}; |
| |
my $secret = $item->{'ltiref'}->{'secret'}; |
| |
my $section = $item->{'ltiref'}->{'section'}; |
| |
$section =~ s/\W//g; |
| |
if ($section eq 'none') { |
| |
undef($section); |
| |
} elsif ($section ne '') { |
| |
my %curr_groups = |
| |
&Apache::longroup::coursegroups($cdom,$cnum); |
| |
if (exists($curr_groups{$section})) { |
| |
undef($section); |
| |
} |
| |
} |
| |
my (%maproles,@possroles); |
| |
if (ref($item->{'ltiref'}->{'maproles'}) eq 'HASH') { |
| |
%maproles = %{$item->{'ltiref'}->{'maproles'}}; |
| |
} |
| |
if (ref($item->{'possroles'}) eq 'ARRAY') { |
| |
@possroles = @{$item->{'possroles'}}; |
| |
} |
| |
if (($ckey ne '') && ($secret ne '') && ($id ne '') && ($url ne '')) { |
| |
my %data = &get_roster($id,$url,$ckey,$secret); |
| |
if (keys(%data) > 0) { |
| |
my (%rulematch,%inst_results,%curr_rules,%got_rules,%alerts,%info); |
| |
my %coursehash = &Apache::lonnet::coursedescription($cdom.'_'.$cnum); |
| |
my $start = $coursehash{'default_enrollment_start_date'}; |
| |
my $end = $coursehash{'default_enrollment_end_date'}; |
| |
my $domdesc = &Apache::lonnet::domain($udom,'description'); |
| |
my $roster = &Apache::loncoursedata::get_classlist($cdom,$cnum); |
| |
my $status = &Apache::loncoursedata::CL_STATUS; |
| |
my $cend = &Apache::loncoursedata::CL_END; |
| |
my $cstart = &Apache::loncoursedata::CL_START; |
| |
my $lockedtype=&Apache::loncoursedata::CL_LOCKEDTYPE; |
| |
my $sec=&Apache::loncoursedata::CL_SECTION; |
| |
my (@activestudents,@futurestudents,@excludedstudents,@localstudents,%currlist,%advroles); |
| |
if (grep(/^st$/,@possroles)) { |
| |
foreach my $user (keys(%{$roster})) { |
| |
if ($user =~ m/^(.+):$cdom$/) { |
| |
my $stuname = $1; |
| |
if ($roster->{$user}[$status] eq "Active") { |
| |
push(@activestudents,$stuname); |
| |
@{$currlist{$stuname}} = @{$roster->{$user}}; |
| |
push(@localstudents,$stuname); |
| |
} elsif (($roster->{$user}[$cstart] > time) && ($roster->{$user}[$cend] > time || |
| |
$roster->{$user}[$cend] == 0 || $roster->{$user}[$cend] eq '')) { |
| |
push(@futurestudents,$stuname); |
| |
@{$currlist{$stuname}} = @{$roster->{$user}}; |
| |
push(@localstudents,$stuname); |
| |
} elsif ($roster->{$user}[$lockedtype] == 1) { |
| |
push(@excludedstudents,$stuname); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ((@possroles > 1) || ((@possroles == 1) && (!grep(/^st$/,@possroles)))) { |
| |
my %personnel = &Apache::lonnet::get_course_adv_roles($item->{'cid'},1); |
| |
foreach my $item (keys(%personnel)) { |
| |
my ($role,$currsec) = split(/:/,$item); |
| |
if ($currsec eq '') { |
| |
$currsec = 'none'; |
| |
} |
| |
foreach my $user (split(/,/,$personnel{$item})) { |
| |
push(@{$advroles{$user}{$role}},$currsec); |
| |
} |
| |
} |
| |
} |
| |
if (($end == 0) || ($end > time) || (@localstudents > 0)) { |
| |
my (%passback,$pbnum,$numadv); |
| |
$numadv = 0; |
| |
foreach my $i (sort { $a <=> $b } keys(%data)) { |
| |
if (ref($data{$i}) eq 'HASH') { |
| |
my $entry = $data{$i}; |
| |
my $user = $entry->{'person_sourcedid'}; |
| |
my $uname; |
| |
if ($user =~ /^($match_username):($match_domain)$/) { |
| |
$uname = $1; |
| |
my $possudom = $2; |
| |
if ($possudom ne $udom) { |
| |
my $uintdom = &Apache::lonnet::domain($possudom,'primary'); |
| |
if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) { |
| |
$udom = $possudom; |
| |
} |
| |
} |
| |
} elsif ($uname =~ /^match_username$/) { |
| |
$uname = $user; |
| |
} else { |
| |
next; |
| |
} |
| |
my $uhome = &Apache::lonnet::homeserver($uname,$udom); |
| |
if ($uhome eq 'no_host') { |
| |
my %data; |
| |
$data{'permanentemail'} = $entry->{'person_contact_email_primary'}; |
| |
$data{'lastname'} = $entry->{'person_name_family'}; |
| |
$data{'firstname'} = $entry->{'person_name_given'}; |
| |
$data{'fullname'} = $entry->{'person_name_full'}; |
| |
my $addresult = |
| |
&create_user($item->{'ltiref'},$uname,$udom, |
| |
$domdesc,\%data,\%alerts,\%rulematch, |
| |
\%inst_results,\%curr_rules,\%got_rules); |
| |
next unless ($addresult eq 'ok'); |
| |
} |
| |
if ($env{'request.lti.passbackurl'}) { |
| |
if ($entry->{'lis_result_sourcedid'} ne '') { |
| |
unless ($pbnum) { |
| |
($pbnum,my $error) = &store_passbackurl($env{'request.lti.login'}, |
| |
$env{'request.lti.passbackurl'}, |
| |
$cdom,$cnum); |
| |
if ($pbnum eq '') { |
| |
$pbnum = $env{'request.lti.passbackurl'}; |
| |
} |
| |
} |
| |
$passback{$uname."\0".$uriscope."\0".$env{'request.lti.sourcecrs'}."\0".$env{'request.lti.login'}} = |
| |
$pbnum."\0".$entry->{'lis_result_sourcedid'}; |
| |
} |
| |
} |
| |
my $rolestr = $entry->{'roles'}; |
| |
my ($lcrolesref) = &get_lc_roles($rolestr,\@possroles,\%maproles); |
| |
my @lcroles = @{$lcrolesref}; |
| |
if (@lcroles) { |
| |
if (grep(/^st$/,@lcroles)) { |
| |
my $addstu; |
| |
if (!grep(/^\Q$uname\E$/,@excludedstudents)) { |
| |
if (grep(/^\Q$uname\E$/,@localstudents)) { |
| |
# Check for section changes |
| |
if ($currlist{$uname}[$sec] ne $section) { |
| |
$addstu = 1; |
| |
&Apache::lonuserutils::modifystudent($udom,$uname,$cdom.'_'.$cnum, |
| |
undef,undef,'course'); |
| |
} elsif (grep(/^\Q$uname\E$/,@futurestudents)) { |
| |
# Check for access date changes for students with access starting in the future. |
| |
my $datechange = &datechange_check($currlist{$uname}[$cstart], |
| |
$currlist{$uname}[$cend], |
| |
$start,$end); |
| |
if ($datechange) { |
| |
$addstu = 1; |
| |
} |
| |
} |
| |
} else { |
| |
$addstu = 1; |
| |
} |
| |
} |
| |
unless ($addstu) { |
| |
pop(@lcroles); |
| |
} |
| |
} |
| |
my @okroles; |
| |
if (@lcroles) { |
| |
foreach my $role (@lcroles) { |
| |
unless (($role eq 'st') || (keys(%advroles) == 0)) { |
| |
if (exists($advroles{$uname.':'.$udom})) { |
| |
if ((ref($advroles{$uname.':'.$udom}) eq 'HASH') && |
| |
(ref($advroles{$uname.':'.$udom}{$role}) eq 'ARRAY')) { |
| |
if (($section eq '') || ($role eq 'cc') || ($role eq 'co')) { |
| |
next if (grep(/^none$/,@{$advroles{$uname.':'.$udom}{$role}})); |
| |
} else { |
| |
next if (grep(/^\Q$sec\E$/,@{$advroles{$uname.':'.$udom}{$role}})); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
push(@okroles,$role); |
| |
} |
| |
} |
| |
if (@okroles) { |
| |
my $permanentemail = $entry->{'person_contact_email_primary'}; |
| |
my $lastname = $entry->{'person_name_family'}; |
| |
my $firstname = $entry->{'person_name_given'}; |
| |
foreach my $role (@okroles) { |
| |
my $enrollresult = &enrolluser($udom,$uname,$role,$cdom,$cnum, |
| |
$section,$start,$end); |
| |
if (($enrollresult eq 'ok') && ($role ne 'st')) { |
| |
$numadv ++; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (keys(%passback)) { |
| |
&Apache::lonnet::put('nohist_lti_passback',\%passback,$cdom,$cnum); |
| |
} |
| |
if ($numadv) { |
| |
&Apache::lonnet::flushcourselogs(); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
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 { |
| |
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); |
| |
} |
| |
|
| |
# |
| |
# 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 { |
| |
my ($oldstart,$oldend,$startdate,$enddate) = @_; |
| |
my $datechange = 0; |
| |
unless ($oldstart eq $startdate) { |
| |
$datechange = 1; |
| |
} |
| |
if (!$datechange) { |
| |
if (!$oldend) { |
| |
if ($enddate) { |
| |
$datechange = 1; |
| |
} |
| |
} elsif ($oldend ne $enddate) { |
| |
$datechange = 1; |
| |
} |
| |
} |
| |
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 { |
| |
my ($ltinum,$pburl,$cdom,$cnum) = @_; |
| |
my %history = &Apache::lonnet::restore($ltinum,'passbackurl',$cdom,$cnum); |
| |
my ($pbnum,$version,$error); |
| |
if ($history{'version'}) { |
| |
$version = $history{'version'}; |
| |
for (my $i=1; $i<=$version; $i++) { |
| |
if ($history{$i.':pburl'} eq $pburl) { |
| |
$pbnum = $i; |
| |
last; |
| |
} |
| |
} |
| |
} else { |
| |
$version = 0; |
| |
} |
| |
if ($pbnum eq '') { |
| |
# get lock on passbackurl db |
| |
my $now = time; |
| |
my $lockhash = { |
| |
'lock'."\0".$ltinum."\0".$now => $env{'user.name'}.':'.$env{'user.domain'}, |
| |
}; |
| |
my $tries = 0; |
| |
my $gotlock = &Apache::lonnet::newput('passbackurl',$lockhash,$cdom,$cnum); |
| |
while (($gotlock ne 'ok') && ($tries<3)) { |
| |
$tries ++; |
| |
sleep 1; |
| |
$gotlock = &Apache::lonnet::newput('passbackurl',$lockhash,$cdom.$cnum); |
| |
} |
| |
if ($gotlock eq 'ok') { |
| |
if (&Apache::lonnet::store_userdata({pburl => $pburl}, |
| |
$ltinum,'passbackurl',$cdom,$cnum) eq 'ok') { |
| |
$pbnum = 1+$version; |
| |
} |
| |
my $dellock = &Apache::lonnet::del('passbackurl',['lock'."\0".$ltinum."\0".$now],$cdom,$cnum); |
| |
unless ($dellock eq 'ok') { |
| |
$error = &mt('error: could not release lockfile'); |
| |
} |
| |
} else { |
| |
$error = &mt('error: could not obtain lockfile'); |
| |
} |
| |
} |
| |
return ($pbnum,$error); |
| |
} |
| |
|
| 1; |
1; |
![[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