--- loncom/lti/ltiutils.pm 2017/12/30 14:04:00 1.3 +++ loncom/lti/ltiutils.pm 2023/07/05 21:25:10 1.17.2.4 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Utility functions for managing LON-CAPA LTI interactions # -# $Id: ltiutils.pm,v 1.3 2017/12/30 14:04:00 raeburn Exp $ +# $Id: ltiutils.pm,v 1.17.2.4 2023/07/05 21:25:10 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,9 +31,19 @@ package LONCAPA::ltiutils; use strict; use Net::OAuth; use Digest::SHA; +use Digest::MD5 qw(md5_hex); +use Encode; use UUID::Tiny ':std'; +use LWP::UserAgent(); use Apache::lonnet; use Apache::loncommon; +use Apache::loncoursedata; +use Apache::lonuserutils; +use Apache::lonenc(); +use Apache::longroup(); +use Apache::lonlocal; +use Math::Round(); +use LONCAPA::Lond; use LONCAPA qw(:DEFAULT :match); # @@ -51,7 +61,7 @@ use LONCAPA qw(:DEFAULT :match); # # When LON-CAPA is operating as a Provider, nonce checking # occurs when a user in course context in another LMS (the -# Consumer launches an external tool to access a LON-CAPA URL: +# Consumer) launches an external tool to access a LON-CAPA URL: # /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended. # @@ -89,8 +99,8 @@ 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 +# 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. # @@ -135,8 +145,8 @@ sub get_loncapa_course { # # 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 +# 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 @@ -148,7 +158,7 @@ sub get_tool_instance { my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_; return unless (ref($errors) eq 'HASH'); my ($marker,$symb,$uname,$udom); - my @keys = ($digsymb); + my @keys = ($digsymb); if ($diguser) { push(@keys,$diguser); } @@ -179,15 +189,15 @@ sub get_tool_instance { # 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 +# 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 +# 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 +# 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). @@ -202,11 +212,30 @@ sub get_tool_secret { %{$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'}; + my ($crsdef,$ltinum); + if ($idx =~ /^c(\d+)$/) { + $ltinum = $1; + $crsdef = 1; + 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'}; } else { $errors->{11} = 1; @@ -234,13 +263,29 @@ sub get_tool_secret { # secret for the specific LTI Provider. # +# FIXME Move to Lond.pm and perform on course's homeserver + 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,); + my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params, + $authheaders,$errors) = @_; + unless (ref($errors) eq 'HASH') { + $errors->{15} = 1; + return; + } + my $request; + if ($oauthtype eq 'consumer') { + my $oauthreq = Net::OAuth->request('consumer'); + $oauthreq->add_required_message_params('body_hash'); + $request = $oauthreq->from_authorization_header($authheaders, + request_url => $protocol.'://'.$hostname.$requri, + request_method => $reqmethod, + consumer_secret => $consumer_secret,); + } else { + $request = Net::OAuth->request('request token')->from_hash($params, + request_url => $protocol.'://'.$hostname.$requri, + request_method => $reqmethod, + consumer_secret => $consumer_secret,); + } unless ($request->verify()) { $errors->{15} = 1; return; @@ -265,12 +310,12 @@ sub verify_request { sub verify_lis_item { 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')); my ($has_action, $valid_for); if ($context eq 'grade') { $has_action = $ltitools->{'passback'}; - $valid_for = $ltitools->{'passbackvalid'} + $valid_for = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds } elsif ($context eq 'roster') { $has_action = $ltitools->{'roster'}; $valid_for = $ltitools->{'rostervalid'}; @@ -286,26 +331,26 @@ sub verify_lis_item { my $expected_sig; if ($context eq 'grade') { my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum; - $expected_sig = &get_service_id($secret,$uniqid); + $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; if ($expected_sig eq $sigrec) { return 1; } else { - $errors->{17} = 1; + $errors->{18} = 1; } } elsif ($context eq 'roster') { my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum; - $expected_sig = &get_service_id($secret,$uniqid); + $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; if ($expected_sig eq $sigrec) { return 1; } else { - $errors->{18} = 1; + $errors->{19} = 1; } } } else { - $errors->{19} = 1; + $errors->{20} = 1; } } else { - $errors->{20} = 1; + $errors->{21} = 1; } return; } @@ -314,18 +359,25 @@ sub verify_lis_item { # LON-CAPA as LTI Consumer # # Sign a request used to launch an instance of an external -# too in a LON-CAPA course, using the key and secret supplied +# tool in a LON-CAPA course, using the key and secret supplied # by the Tool Provider. # 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, @@ -333,12 +385,16 @@ 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(); + $request->sign(); + if ($post) { + return $request->to_post_body(); + } else { + return $request->to_hash(); + } } # @@ -362,12 +418,12 @@ sub get_service_id { # 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 +# +# 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 +# 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) = @_; @@ -375,13 +431,13 @@ sub set_service_secret { my $warning; my ($needsnew,$oldsecret,$lifetime); if ($name eq 'grade') { - $lifetime = $ltitools->{'passbackvalid'} + $lifetime = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds } elsif ($name eq 'roster') { $lifetime = $ltitools->{'rostervalid'}; } - if ($toolsettings->{$name} eq '') { + if ($toolsettings->{$name.'secret'} eq '') { $needsnew = 1; - } elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) { + } elsif (($toolsettings->{$name.'secretdate'} + $lifetime) < $now) { $oldsecret = $toolsettings->{$name.'secret'}; $needsnew = 1; } @@ -417,7 +473,7 @@ sub set_service_secret { # # 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. # @@ -458,4 +514,941 @@ 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 ($cdom,$cnum,$ltinum,$keynum,$id,$url) = @_; + my %ltiparams = ( + lti_version => 'LTI-1p0', + lti_message_type => 'basic-lis-readmembershipsforcontext', + ext_ims_lis_memberships_id => $id, + ); + my %info = (); + 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); + $request->content(join('&',map { + my $name = escape($_); + "$name=" . ( ref($hashref->{$_}) eq 'ARRAY' + ? join("&$name=", map {escape($_) } @{$hashref->{$_}}) + : &escape($hashref->{$_}) ); + } keys(%{$hashref}))); + my $ua=new LWP::UserAgent; + $ua->timeout(10); + my $response=$ua->request($request); + 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 ($cdom,$cnum,$crsdef,$type,$ltinum,$keynum,$id,$url,$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 %info = ( + method => $sigmethod, + ); + 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->content(join('&',map { + my $name = escape($_); + "$name=" . ( ref($hashref->{$_}) eq 'ARRAY' + ? join("&$name=", map {escape($_) } @{$hashref->{$_}}) + : &escape($hashref->{$_}) ); + } keys(%{$hashref}))); +#FIXME Need to handle case where passback failed. + } + } else { + srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand. + my $uniqmsgid = int(rand(2**32)); + my $gradexml = < + + + + V1.0 + $uniqmsgid + + + + + + + $id + + + + en + $score + + + + + + +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, + ); + 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. + } + } +} + +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 { + 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') && + (ref($item->{'ltiref'}) eq 'HASH')); + my ($cdom,$cnum) = split(/_/,$item->{'cid'}); + return if (($cdom eq '') || ($cnum eq '')); + my $udom = $cdom; + my $id = $item->{'id'}; + my $url = $item->{'url'}; + my $ltinum = $item->{'lti'}; + my $keynum = $item->{'ltiref'}->{'cipher'}; + my @intdoms; + my $intdomsref = $item->{'intdoms'}; + if (ref($intdomsref) eq 'ARRAY') { + @intdoms = @{$intdomsref}; + } + my $uriscope = $item->{'uriscope'}; + 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 (($id ne '') && ($url ne '')) { + my %data = &get_roster($cdom,$cnum,$ltinum,$keynum,$id,$url); + 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;