--- loncom/lti/ltiutils.pm 2018/05/15 04:59:22 1.10 +++ loncom/lti/ltiutils.pm 2022/01/20 00:35:00 1.17.2.2 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Utility functions for managing LON-CAPA LTI interactions # -# $Id: ltiutils.pm,v 1.10 2018/05/15 04:59:22 raeburn Exp $ +# $Id: ltiutils.pm,v 1.17.2.2 2022/01/20 00:35:00 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,10 +31,10 @@ package LONCAPA::ltiutils; use strict; use Net::OAuth; use Digest::SHA; -use UUID::Tiny ':std'; +use Digest::MD5 qw(md5_hex); +use LWP::UserAgent(); use Apache::lonnet; use Apache::loncommon; -use Math::Round(); use LONCAPA qw(:DEFAULT :match); # @@ -89,226 +89,35 @@ sub check_nonce { # # LON-CAPA as LTI Consumer # -# Determine the domain and the courseID of the LON-CAPA course -# for which access is needed by a Tool Provider -- either to -# retrieve a roster or store the grade for an instance of an -# external tool in the course. -# - -sub get_loncapa_course { - my ($lonhost,$cid,$errors) = @_; - return unless (ref($errors) eq 'HASH'); - my ($cdom,$cnum); - if ($cid =~ /^($match_domain)_($match_courseid)$/) { - my ($posscdom,$posscnum) = ($1,$2); - my $cprimary_id = &Apache::lonnet::domain($posscdom,'primary'); - if ($cprimary_id eq '') { - $errors->{5} = 1; - return; - } else { - my @intdoms; - my $internet_names = &Apache::lonnet::get_internet_names($lonhost); - if (ref($internet_names) eq 'ARRAY') { - @intdoms = @{$internet_names}; - } - my $cintdom = &Apache::lonnet::internet_dom($cprimary_id); - if (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) { - $cdom = $posscdom; - } else { - $errors->{6} = 1; - return; - } - } - my $chome = &Apache::lonnet::homeserver($posscnum,$posscdom); - if ($chome =~ /(con_lost|no_host|no_such_host)/) { - $errors->{7} = 1; - return; - } else { - $cnum = $posscnum; - } - } else { - $errors->{8} = 1; - return; - } - return ($cdom,$cnum); -} - -# -# LON-CAPA as LTI Consumer -# -# Determine the symb and (optionally) LON-CAPA user for an -# instance of an external tool in a course -- either to -# to retrieve a roster or store a grade. -# -# Use the digested symb to lookup the real symb in exttools.db -# and the digested userID to lookup the real userID (if needed). -# and extract the exttool instance and symb. -# - -sub get_tool_instance { - my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_; - return unless (ref($errors) eq 'HASH'); - my ($marker,$symb,$uname,$udom); - my @keys = ($digsymb); - if ($diguser) { - push(@keys,$diguser); - } - my %digesthash = &Apache::lonnet::get('exttools',\@keys,$cdom,$cnum); - if ($digsymb) { - $symb = $digesthash{$digsymb}; - if ($symb) { - my ($map,$id,$url) = split(/___/,$symb); - $marker = (split(m{/},$url))[3]; - $marker=~s/\D//g; - } else { - $errors->{9} = 1; - } - } - if ($diguser) { - if ($digesthash{$diguser} =~ /^($match_username):($match_domain)$/) { - ($uname,$udom) = ($1,$2); - } else { - $errors->{10} = 1; - } - return ($marker,$symb,$uname,$udom); - } else { - return ($marker,$symb); - } -} - -# -# LON-CAPA as LTI Consumer -# -# 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 -# tool in a LON-CAPA course. -# -# Retrieve the Consumer key and Consumer secret from the domain -# configuration or the Tool Provider ID stored in the -# exttool_$marker db file and compare the Consumer key with the -# one in the POSTed data. -# -# Side effect is to populate the $toolsettings hashref with the -# contents of the .db file (instance of tool in course) and the -# $ltitools hashref with the configuration for the tool (at -# domain level). -# - -sub get_tool_secret { - my ($key,$marker,$symb,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_; - return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') && - (ref($errors) eq 'HASH')); - my ($consumer_secret,$nonce_lifetime); - if ($marker) { - %{$toolsettings}=&Apache::lonnet::dump('exttool_'.$marker,$cdom,$cnum); - if ($toolsettings->{'id'}) { - my $idx = $toolsettings->{'id'}; - my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer'); - if (ref($lti{$idx}) eq 'HASH') { - %{$ltitools} = %{$lti{$idx}}; - if ($ltitools->{'key'} eq $key) { - $consumer_secret = $ltitools->{'secret'}; - $nonce_lifetime = $ltitools->{'lifetime'}; - } else { - $errors->{11} = 1; - return; - } - } else { - $errors->{12} = 1; - return; - } - } else { - $errors->{13} = 1; - return; - } - } else { - $errors->{14}; - return; - } - return ($consumer_secret,$nonce_lifetime); -} - -# -# LON-CAPA as LTI Consumer -# # Verify a signed request using the consumer_key and # secret for the specific LTI Provider. # sub verify_request { - my ($params,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$errors) = @_; - return unless (ref($errors) eq 'HASH'); - my $request = Net::OAuth->request('request token')->from_hash($params, - request_url => $protocol.'://'.$hostname.$requri, - request_method => $reqmethod, - consumer_secret => $consumer_secret,); - unless ($request->verify()) { + my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params, + $authheaders,$errors) = @_; + unless (ref($errors) eq 'HASH') { $errors->{15} = 1; return; } -} - -# -# LON-CAPA as LTI Consumer -# -# Verify that an item identifier (either roster request: -# ext_ims_lis_memberships_id, or grade store: -# lis_result_sourcedid) has not been tampered with, and -# the secret used to create the unique identifier has not -# expired. -# -# Prepending the current secret (if still valid), -# or the previous secret (if current one is no longer valid), -# to a string composed of the :::-separated components -# must generate the result signature in the lis item ID -# sent by the Tool Provider. -# - -sub verify_lis_item { - my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_; - return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') && - (ref($errors) eq 'HASH')); - my ($has_action, $valid_for); - if ($context eq 'grade') { - $has_action = $ltitools->{'passback'}; - $valid_for = $ltitools->{'passbackvalid'} - } elsif ($context eq 'roster') { - $has_action = $ltitools->{'roster'}; - $valid_for = $ltitools->{'rostervalid'}; - } - if ($has_action) { - my $secret; - if (($toolsettings->{$context.'secretdate'} + $valid_for) > time) { - $secret = $toolsettings->{$context.'secret'}; - } else { - $secret = $toolsettings->{'old'.$context.'secret'}; - } - if ($secret) { - my $expected_sig; - if ($context eq 'grade') { - my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum; - $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; - if ($expected_sig eq $sigrec) { - return 1; - } else { - $errors->{17} = 1; - } - } elsif ($context eq 'roster') { - my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum; - $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; - if ($expected_sig eq $sigrec) { - return 1; - } else { - $errors->{18} = 1; - } - } - } else { - $errors->{19} = 1; - } + 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 { - $errors->{20} = 1; + $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; } - return; } # @@ -320,14 +129,20 @@ sub verify_lis_item { # sub sign_params { - my ($url,$key,$secret,$sigmethod,$paramsref) = @_; + my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_; return unless (ref($paramsref) eq 'HASH'); if ($sigmethod eq '') { $sigmethod = 'HMAC-SHA1'; } + if ($type eq '') { + $type = 'request token'; + } + if ($callback eq '') { + $callback = 'about:blank', + } srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand. my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0))); - my $request = Net::OAuth->request("request token")->new( + my $request = Net::OAuth->request($type)->new( consumer_key => $key, consumer_secret => $secret, request_url => $url, @@ -335,128 +150,15 @@ sub sign_params { signature_method => $sigmethod, timestamp => time, nonce => $nonce, - callback => 'about:blank', + callback => $callback, extra_params => $paramsref, version => '1.0', ); - $request->sign; - return $request->to_hash(); -} - -# -# LON-CAPA as LTI Consumer -# -# Generate a signature for a unique identifier (roster request: -# ext_ims_lis_memberships_id, or grade store: lis_result_sourcedid) -# - -sub get_service_id { - my ($secret,$id) = @_; - my $sig = Digest::SHA::sha1_hex($secret.':::'.$id); - return $sig.':::'.$id; -} - -# -# LON-CAPA as LTI Consumer -# -# Generate and store the time-limited secret used to create the -# signature in a service request identifier (roster request or -# grade store). An existing secret past its expiration date -# will be stored as oldsecret, and a new secret -# secret will be stored. -# -# Secrets are specific to service name and to the tool instance -# (and are stored in the exttool_$marker db file). -# The time period a secret remains valid is determined by the -# domain configuration for the specific tool and the service. -# - -sub set_service_secret { - my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_; - return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH')); - my $warning; - my ($needsnew,$oldsecret,$lifetime); - if ($name eq 'grade') { - $lifetime = $ltitools->{'passbackvalid'} - } elsif ($name eq 'roster') { - $lifetime = $ltitools->{'rostervalid'}; - } - if ($toolsettings->{$name} eq '') { - $needsnew = 1; - } elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) { - $oldsecret = $toolsettings->{$name.'secret'}; - $needsnew = 1; - } - if ($needsnew) { - if (&get_tool_lock($cdom,$cnum,$marker,$name,$now) eq 'ok') { - my $secret = UUID::Tiny::create_uuid_as_string(UUID_V4); - $toolsettings->{$name.'secret'} = $secret; - my %secrethash = ( - $name.'secret' => $secret, - $name.'secretdate' => $now, - ); - if ($oldsecret ne '') { - $secrethash{'old'.$name.'secret'} = $oldsecret; - } - my $putres = &Apache::lonnet::put('exttool_'.$marker, - \%secrethash,$cdom,$cnum); - my $delresult = &release_tool_lock($cdom,$cnum,$marker,$name); - if ($delresult ne 'ok') { - $warning = $delresult ; - } - if ($putres eq 'ok') { - return 'ok'; - } - } else { - $warning = 'Could not obtain exclusive lock'; - } + $request->sign(); + if ($post) { + return $request->to_post_body(); } else { - return 'ok'; - } - return; -} - -# -# LON-CAPA as LTI Consumer -# -# Add a lock key to exttools.db for the instance of an external tool -# when generating and storing a service secret. -# - -sub get_tool_lock { - my ($cdom,$cnum,$marker,$name,$now) = @_; - # get lock for tool for which secret is being set - my $lockhash = { - $name."\0".$marker."\0".'lock' => $now.':'.$env{'user.name'}. - ':'.$env{'user.domain'}, - }; - my $tries = 0; - my $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum); - - while (($gotlock ne 'ok') && $tries <3) { - $tries ++; - sleep(1); - $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum); - } - return $gotlock; -} - -# -# LON-CAPA as LTI Consumer -# -# Remove a lock key from exttools.db for the instance of an external -# tool created when generating and storing a service secret. -# - -sub release_tool_lock { - my ($cdom,$cnum,$marker,$name) = @_; - # remove lock - my @del_lock = ($name."\0".$marker."\0".'lock'); - my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum); - if ($dellockoutcome ne 'ok') { - return 'Warning: failed to release lock for exttool'; - } else { - return 'ok'; + return $request->to_hash(); } } @@ -483,16 +185,18 @@ sub lti_provider_scope { $scope = 'map'; $realuri = $tail; } 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); if ($url =~ /\.sequence$/) { $scope = 'map'; } else { $scope = 'resource'; - $realuri .= '?symb='.$tail; - $passkey = $tail; + $realuri .= '?symb='.$symb; + $passkey = $symb; if ($getunenc) { - $unencsymb = $tail; + $unencsymb = $symb; } } } @@ -502,16 +206,18 @@ sub lti_provider_scope { $scope = 'map'; $realuri = $tail; } 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); if ($url =~ /\.sequence$/) { $scope = 'map'; } else { $scope = 'resource'; - $realuri .= '?symb='.$tail; - $passkey = $tail; + $realuri .= '?symb='.$symb; + $passkey = $symb; if ($getunenc) { - $unencsymb = $tail; + $unencsymb = $symb; } } } @@ -557,7 +263,7 @@ sub lti_provider_scope { } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) { $scope = 'course'; $realuri = '/adm/navmaps'; - $passkey = $tail; + $passkey = ''; } if ($scope eq 'map') { $passkey = $realuri; @@ -569,44 +275,271 @@ sub lti_provider_scope { } } -sub send_grade { - my ($id,$url,$ckey,$secret,$scoretype,$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); +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 $ua=new LWP::UserAgent; + $ua->timeout(10); + my $request=new HTTP::Request('POST',$service_url); + $request->content($post); + my $response=$ua->request($request); + } + } + return; +} + +# +# LON-CAPA as LTI Provider +# +# Create a new user in LON-CAPA. If the domain's configuration +# includes rules for format of "official" usernames, those rules +# will apply when determining if a user is to be created. In +# additional if institutional user information is available that +# will be used when creating a new user account. +# + +sub create_user { + my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results, + $curr_rules,$got_rules) = @_; + return unless (ref($ltiref) eq 'HASH'); + my $checkhash = { "$uname:$udom" => { 'newuser' => 1, }, }; + my $checks = { 'username' => 1, }; + my ($lcauth,$lcauthparm); + &Apache::loncommon::user_rule_check($checkhash,$checks,$alerts,$rulematch, + $inst_results,$curr_rules,$got_rules); + my ($userchkmsg,$lcauth,$lcauthparm); + my $allowed = 1; + if (ref($alerts->{'username'}) eq 'HASH') { + if (ref($alerts->{'username'}{$udom}) eq 'HASH') { + if ($alerts->{'username'}{$udom}{$uname}) { + if (ref($curr_rules->{$udom}) eq 'HASH') { + $userchkmsg = + &Apache::loncommon::instrule_disallow_msg('username',$domdesc,1). + &Apache::loncommon::user_rule_formats($udom,$domdesc, + $curr_rules->{$udom}{'username'}, + 'username'); + } + $allowed = 0; + } + } + } + if ($allowed) { + if (ref($rulematch->{$uname.':'.$udom}) eq 'HASH') { + my $matchedrule = $rulematch->{$uname.':'.$udom}{'username'}; + my ($rules,$ruleorder) = + &Apache::lonnet::inst_userrules($udom,'username'); + if (ref($rules) eq 'HASH') { + if (ref($rules->{$matchedrule}) eq 'HASH') { + $lcauth = $rules->{$matchedrule}{'authtype'}; + $lcauthparm = $rules->{$matchedrule}{'authparm'}; + } + } + } + if ($lcauth eq '') { + $lcauth = $ltiref->{'lcauth'}; + if ($lcauth eq 'internal') { + $lcauthparm = &create_passwd(); + } else { + $lcauthparm = $ltiref->{'lcauthparm'}; + } + } + } else { + return 'notallowed'; + } + my @userinfo = ('firstname','middlename','lastname','generation','permanentemail','id'); + my (%useinstdata,%info); + if (ref($ltiref->{'instdata'}) eq 'ARRAY') { + map { $useinstdata{$_} = 1; } @{$ltiref->{'instdata'}}; + } + foreach my $item (@userinfo) { + if (($useinstdata{$item}) && (ref($inst_results->{$uname.':'.$udom}) eq 'HASH') && + ($inst_results->{$uname.':'.$udom}{$item} ne '')) { + $info{$item} = $inst_results->{$uname.':'.$udom}{$item}; + } else { + if ($item eq 'permanentemail') { + if ($data->{'permanentemail'} =~/^[^\@]+\@[^@]+$/) { + $info{$item} = $data->{'permanentemail'}; + } + } elsif (($item eq 'firstname') || ($item eq 'lastname')) { + $info{$item} = $data->{$item}; + } + } + } + if (($info{'middlename'} eq '') && ($data->{'fullname'} ne '')) { + unless ($useinstdata{'middlename'}) { + my $fullname = $data->{'fullname'}; + if ($info{'firstname'}) { + $fullname =~ s/^\s*\Q$info{'firstname'}\E\s*//i; + } + if ($info{'lastname'}) { + $fullname =~ s/\s*\Q$info{'lastname'}\E\s*$//i; + } + if ($fullname ne '') { + $fullname =~ s/^\s+|\s+$//g; + if ($fullname ne '') { + $info{'middlename'} = $fullname; + } + } + } + } + if (ref($inst_results->{$uname.':'.$udom}{'inststatus'}) eq 'ARRAY') { + my @inststatuses = @{$inst_results->{$uname.':'.$udom}{'inststatus'}}; + $info{'inststatus'} = join(':',map { &escape($_); } @inststatuses); + } + my $result = + &Apache::lonnet::modifyuser($udom,$uname,$info{'id'}, + $lcauth,$lcauthparm,$info{'firstname'}, + $info{'middlename'},$info{'lastname'}, + $info{'generation'},undef,undef, + $info{'permanentemail'},$info{'inststatus'}); + return $result; +} + +# +# LON-CAPA as LTI Provider +# +# Create a password for a new user if the authentication +# type to assign to new users created following LTI launch is +# to be LON-CAPA "internal". +# + +sub create_passwd { + my $passwd = ''; + srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand. + my @letts = ("a".."z"); + for (my $i=0; $i<8; $i++) { + my $lettnum = int(rand(2)); + my $item = ''; + if ($lettnum) { + $item = $letts[int(rand(26))]; + my $uppercase = int(rand(2)); + if ($uppercase) { + $item =~ tr/a-z/A-Z/; + } } else { - $score = $total/$possible; - $score = sprintf("%.2f",$score); + $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); + } } } - 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); - 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; -#FIXME Handle case where pass back of score to LTI Consumer failed. + 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;