[BACK]Return to ltiutils.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lti

Diff for /loncom/lti/ltiutils.pm between versions 1.1 and 1.14

version 1.1, 2017/12/07 15:36:25 version 1.14, 2018/08/14 17:24:21
Line 34  use Digest::SHA; Line 34  use Digest::SHA;
 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 51  use LONCAPA qw(:DEFAULT :match); Line 57  use LONCAPA qw(:DEFAULT :match);
 #  #
 # When LON-CAPA is operating as a Provider, nonce checking   # When LON-CAPA is operating as a Provider, nonce checking 
 # occurs when a user in course context in another LMS (the   # 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.  # /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.
 #  #
   
Line 270  sub verify_lis_item { Line 276  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 286  sub verify_lis_item { Line 292  sub verify_lis_item {
             my $expected_sig;              my $expected_sig;
             if ($context eq 'grade') {              if ($context eq 'grade') {
                 my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;                  my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;
                 $expected_sig = &get_service_id($secret,$uniqid);                  $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
                 if ($expected_sig eq $sigrec) {                  if ($expected_sig eq $sigrec) {
                     return 1;                      return 1;
                 } else {                  } else {
                     $errors->{16} = 1;                      $errors->{17} = 1;
                 }                  }
             } elsif ($context eq 'roster') {              } elsif ($context eq 'roster') {
                 my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;                  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) {                  if ($expected_sig eq $sigrec) {
                     return 1;                      return 1;
                 } else {                  } else {
                     $errors->{17} = 1;                      $errors->{18} = 1;
                 }                  }
             }              }
         } else {          } else {
             $errors->{18} = 1;              $errors->{19} = 1;
         }          }
     } else {      } else {
         $errors->{19} = 1;          $errors->{20} = 1;
     }      }
     return;      return;
 }  }
Line 314  sub verify_lis_item { Line 320  sub verify_lis_item {
 # LON-CAPA as LTI Consumer  # LON-CAPA as LTI Consumer
 #  #
 # Sign a request used to launch an instance of an external  # 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.  # by the Tool Provider.
 #   # 
   
 sub sign_params {  sub sign_params {
     my ($url,$key,$secret,$paramsref) = @_;      my ($url,$key,$secret,$sigmethod,$paramsref) = @_;
     return unless (ref($paramsref) eq 'HASH');      return unless (ref($paramsref) eq 'HASH');
       if ($sigmethod eq '') {
           $sigmethod = 'HMAC-SHA1';
       }
       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("request token")->new(
             consumer_key => $key,              consumer_key => $key,
             consumer_secret => $secret,              consumer_secret => $secret,
             request_url => $url,              request_url => $url,
             request_method => 'POST',              request_method => 'POST',
             signature_method => 'HMAC-SHA1',              signature_method => $sigmethod,
             timestamp => time,              timestamp => time,
             nonce => $nonce,              nonce => $nonce,
             callback => 'about:blank',              callback => 'about:blank',
Line 372  sub set_service_secret { Line 382  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 444  sub get_tool_lock { Line 454  sub get_tool_lock {
 #  #
   
 sub release_tool_lock {  sub release_tool_lock {
     my ($cdom,$cnum,$marker) = @_;      my ($cdom,$cnum,$marker,$name) = @_;
     #  remove lock      #  remove lock
     my @del_lock = ($name."\0".$marker."\0".'lock');      my @del_lock = ($name."\0".$marker."\0".'lock');
     my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);      my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);
Line 455  sub release_tool_lock { Line 465  sub release_tool_lock {
     }      }
 }  }
   
   #
   # 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,$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);
           }
       }
       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.
       }
   }
   
   #
   # 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;
Removed from v.1.1  
changed lines
  Added in v.1.14

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