Return to ltipassback.pm CVS log

Up to [LON-CAPA] / loncom / lti

- Remove trailing white space.

# The LearningOnline Network with CAPA
# LTI Consumer Module to receive grades passed back by Provider 
#
# $Id: ltipassback.pm,v 1.8 2023/06/02 00:28:03 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#

package Apache::ltipassback;

use strict;
use URI::Escape;
use Apache::Constants qw(:common :http);
use Apache::lonnet;
use Apache::loncommon;
use Apache::lonacc;
use LONCAPA::ltiutils;

sub handler {
    my $r = shift;
    my %errors;
    my $params = {};
    my ($oauthtype,$authheader,$xmlbody);
#
# Retrieve content type from headers
#
    my $content_type = $r->headers_in->get('Content-Type');
    if ($content_type eq 'application/xml') {
        $oauthtype = 'consumer';
#
# Retrieve OAuth data from Authorization header sent by LTI Provider
#
        $authheader = $r->headers_in->get('Authorization');
        my ($authtype,$valuestr) = ($authheader =~ /^(OAuth)\s+(.+)$/i);
        if (lc($authtype) eq 'oauth') {
            foreach my $pair (split(/\s*,\s*/,$valuestr)) {
                my ($key,$value) = split(/=/,$pair);
                $value =~ s /(^"|"$)//g;
                $params->{$key} = URI::Escape::uri_unescape($value);
            }
        }
#
# Retrieve message body
#
        my $length = $r->headers_in->get('Content-length');
        if ($length) {
            $r->read($xmlbody,$length,0);
            if ($xmlbody ne '') {
                my %grades = &LONCAPA::ltiutils::parse_grade_xml($xmlbody);
                foreach my $num (sort { $a <=> $b } (keys(%grades))) {
                    if (ref($grades{$num}) eq 'HASH') {
                        if (($grades{$num}{'sourcedid'} ne '') && ($grades{$num}{'score'} ne '')) {
                            $params->{'sourcedid'} = $grades{$num}{'sourcedid'};
                            $params->{'result_resultscore_textstring'} = $grades{$num}{'score'};
                            $params->{'result_resultscore_language'} = $grades{$num}{'language'};
                            $params->{'result_resultvaluesourcedid'} = 'decimal'; 
                        }
                    } 
                }
            }
        }
    } else {
        $oauthtype = 'request token';
#
# Retrieve data POSTed by LTI Provider
#
        &Apache::lonacc::get_posted_cgi($r);
        foreach my $key (sort(keys(%env))) {
            if ($key =~ /^form\.(.+)$/) {
                $params->{$1} = $env{$key};
            }
        }
    }

    unless (keys(%{$params})) {
        $errors{1} = 1; 
        &invalid_request($r,$params,\%errors);
        return OK;
    }

    unless ($params->{'oauth_consumer_key'} &&
            $params->{'oauth_nonce'} &&
            $params->{'oauth_timestamp'} &&
            $params->{'oauth_version'} &&
            $params->{'oauth_signature'} &&
            $params->{'oauth_signature_method'}) {
        $errors{2} = 1; 
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Retrieve the signature, digested symb, digested user, and LON-CAPA 
# courseID from the sourcedid in the POSTed data
#
    unless ($params->{'sourcedid'}) {
        $errors{3} = 1; 
        &invalid_request($r,$params,\%errors);
        return OK;
    }

    my ($resultsig,$digsymb,$diguser,$cid) = split(/\Q:::\E/,$params->{'sourcedid'});
    unless ($resultsig && $digsymb && $diguser && $cid) {
        $errors{4} = 1; 
        &invalid_request($r,$params,\%errors);
        return OK;
    }

    my ($cdom,$cnum,$marker,$symb,$uname,$udom);

#
# Determine the domain and the courseID of the LON-CAPA course to which the
# launch of LON-CAPA should provide access.
#
    ($cdom,$cnum) = &LONCAPA::ltiutils::get_loncapa_course($r->dir_config('lonHostID'),
                                                           $cid,\%errors);  
    unless ($cdom && $cnum) {
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Use the digested symb to lookup the real symb in exttools.db
#

    ($marker,$symb,$uname,$udom) = 
        &LONCAPA::ltiutils::get_tool_instance($cdom,$cnum,$digsymb,$diguser,\%errors);

    unless ($marker) {
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Retrieve the Consumer key and Consumer secret from the domain configuration
# for the Tool Provider ID stored in the exttool_$marker.db
#

    my (%toolsettings,%ltitools);
    my ($consumer_secret,$nonce_lifetime) =
        &LONCAPA::ltiutils::get_tool_secret($params->{'oauth_consumer_key'},
                                            $marker,$symb,$cdom,$cnum,
                                            \%toolsettings,\%ltitools,\%errors);

    if (keys(%errors) > 0) {
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Verify the signed request using the consumer_key and 
# secret for the specific LTI Provider.
#

    my $protocol = 'http';
    if ($ENV{'SERVER_PORT'} == 443) {
        $protocol = 'https';
    }

    unless (LONCAPA::ltiutils::verify_request($oauthtype,$protocol,$r->hostname,$r->uri,
                                              $r->method,$consumer_secret,$params,
                                              $authheader,\%errors)) {
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Verify XML in request body has not been tampered with
#

    if ($content_type eq 'application/xml') {
        my $bodyhash = Digest::SHA::sha1_base64($xmlbody);
        while (length($bodyhash) % 4) {
            $bodyhash .= '=';
        }
        unless ($bodyhash eq $params->{oauth_body_hash}) {
            $errors{16} = 1;
            &invalid_request($r,$params,\%errors);
            return OK;
        }
    }

#
# Determine if nonce in POSTed data has expired.
# If unexpired, confirm it has not already been used.
#

    unless (&LONCAPA::ltiutils::check_nonce($params->{'oauth_nonce'},$params->{'oauth_timestamp'},
                                            $ltitools{'lifetime'},$cdom,$r->dir_config('lonLTIDir'))) {
        $errors{17} = 1;
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Verify that the sourcedid has not been tampered with,
# and the gradesecret used to create it is still valid. 
# 

    unless (&LONCAPA::ltiutils::verify_lis_item($resultsig,'grade',$digsymb,$diguser,$cdom,
                                                $cnum,\%toolsettings,\%ltitools,\%errors)) {
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Does the user have an active role in the course which maps to one of
# the supported LTI roles
#

    if (($uname ne '') && ($udom ne '')) {
        my %maproles;
        if (ref($ltitools{'roles'}) eq 'HASH') {
            %maproles = %{$ltitools{'roles'}};
        }
        unless (keys(%maproles)) {
            $errors{22} = 1;
            &invalid_request($r,$params,\%errors);
            return OK;
        }
        my ($crstype,$hasrole);
        my @allroles = &Apache::lonuserutils::roles_by_context('course',0,$crstype);
        my (%availableroles,$coursepersonnel,$includestudents,%users);
        foreach my $role (@allroles) {
            if (exists($maproles{$role})) {
                $availableroles{$role} = 1;
                if ($role eq 'st') {
                    $includestudents = 1;
                } else {
                    $coursepersonnel = 1;
                }
            }
        }
        if (keys(%availableroles)) {
            my $courseurl = "/$cdom/$cnum";
            my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname,$courseurl);
            if (keys(%roleshash)) {
                my $now = time;
                foreach my $key (keys(%roleshash)) {
                    if ($key =~ m{^\Q$courseurl\E(|/\w+)_(\w+)$}) {
                        my ($secgroup,$rolecode) = ($1,$2);
                        next if ($rolecode eq 'gr');
                        next unless ($availableroles{$rolecode});
                        my ($dummy,$end,$start)=split(/\_/,$roleshash{$key});
                        next if (defined($end) && $end && ($now > $end));
                        next if (defined($start) && $start && ($now < $start));
                        $hasrole = 1;
                        last;
                    }
                }
            }
        }
        unless ($hasrole) {
            $errors{23} = 1;
            &invalid_request($r,$params,\%errors);
            return OK;
        }
    } else {
        $errors{24} = 1;
        &invalid_request($r,$params,\%errors);
        return OK;
    }

#
# Store result if one was sent in a valid format. 
#

    my ($result,$resulttype,$lang,$pcf);
    if (exists($params->{'result_resultvaluesourcedid'})) {
        $resulttype = $params->{'result_resultvaluesourcedid'};
        $resulttype =~ s/(^\s+|\s+)$//g;
    } else {
        $resulttype = 'decimal';
    }
    $result = $params->{'result_resultscore_textstring'};
    $result =~ s/(^\s+|\s+)$//g;
    my $posslang = $params->{'result_resultscore_language'};
    $posslang =~ s/(^\s+|\s+)$//g;
    if ($posslang =~ /^\w+(|\-\w+(|\-w+))$/) {
        $lang = $posslang;
    }
    if (($resulttype eq 'ratio') || ($resulttype eq 'decimal') || ($resulttype eq 'percentage')) {
        if ($resulttype eq 'ratio') {
            my ($numerator,$denominator) = split(/\s*\/\s*/,$result,2);
            $numerator =~ s/(^\s+|\s+)$//g;
            $denominator =~ s/(^\s+|\s+)$//g;
            if (($numerator =~ /^\d+$/) && ($denominator =~ /^\d+$/) && ($denominator !=0)) {
                eval {
                         $pcf = $numerator/$denominator;
                     };
            }
            if ($@) {
                $errors{24} = 1;
                &invalid_request($r,$params,\%errors);
                return OK;
            }
        } elsif ($resulttype eq 'decimal') {
            if (($result ne '') && ($result =~ /^\d*\.?\d*$/)) {
                if ($result eq '.') {
                    $result = 0;
                }
                if (($result >= 0) && ($result <= 1)) {
                    $pcf = $result;
                }
            }
        } elsif ($resulttype eq 'percentage') {
            if ($result =~ /^(\d+)\s*\%?$/) {
                my $percent = $1;
                if (($percent >= 0) && ($percent <= 100)) {
                    $pcf = $percent/100.0;
                }
            }
        }
        if ($pcf ne '') {
            my %newrecord=();
            my $reckey = 'resource.0.solved'; 
            my %record = &Apache::lonnet::restore($symb,$cdom.'_'.$cnum,$udom,$uname);
            my $tries = 0;
            if ($record{'resource.0.tries'} =~ /^\d$/) {
                $tries = $record{'resource.0.tries'};
            }
            if ($record{'resource.0.awarded'} ne $pcf) {
                $newrecord{'resource.0.awarded'}  = $pcf;
            }
            if ($pcf == 0) {
                if ($record{$reckey} ne 'incorrect_by_passback') {
                    $newrecord{$reckey} = 'incorrect_by_passback';
                }
            } else {
                if ($record{$reckey} ne 'correct_by_passback') {
                    $newrecord{$reckey} = 'correct_by_passback';
                }
            }
            if (%newrecord) {
                $newrecord{'resource.0.tries'} = 1 + $tries;
                $env{'request.course.id'} = $cdom.'_'.$cnum;
                my $result = &Apache::lonnet::cstore(\%newrecord,$symb,$cdom.'_'.$cnum,
                                                     $udom,$uname);
                delete($env{'request.course.id'});
                if (($result eq 'ok') || ($result eq 'con_delayed')) {
                    &success($r,$params->{'sourcedid'},$resulttype,$result,$lang);
                } else {
                    $errors{25} = 1;
                    &invalid_request($r,$params,\%errors);
                }
            } else {
                &success($r,$params->{'sourcedid'},$resulttype,$result,$lang);
            }
        } else {
            $errors{26} = 1;
            &invalid_request($r,$params,\%errors);
        }
    } else {
        $errors{27} = 1;
        &invalid_request($r,$params,\%errors);
    }
    return OK;
}

sub success {
    my ($r,$sourcedid,$scoretype,$score,$lang) = @_;
    my $date = &Apache::loncommon::utc_string(time); 
    &Apache::loncommon::content_type($r,'text/xml');
    $r->send_http_header;
    if ($r->header_only) {
        return;
    }
    $r->print(<<"END");
<?xml version="1.0" encoding="UTF-8" ?>
<message_response>
  <lti_message_type>basic-lis-updateresult</lti_message_type>
  <statusinfo>
    <codemajor>Success</codemajor>
    <severity>Status</severity>
    <codeminor>fullsuccess</codeminor>
    <description>Grade updated</description>
  </statusinfo>
  <result>
    <sourcedid>$sourcedid</sourcedid>
    <date>$date</date>
    <resultscore>
      <resultvaluesourcedid>$scoretype</resultvaluesourcedid>
      <textstring>$score</textstring>
      <language>$lang</language>
    </resultscore>
  </result>
</message_response>
END
    return;
}

sub invalid_request {
    my ($r,$params,$errors) = @_;
    my $date = &Apache::loncommon::utc_string(time);
    my ($scoretype,$score,$lang);
    if (ref($params) eq 'HASH') {
        if ($params->{'result_resultvaluesourcedid'} =~ /^\s*(decimal|percentage|ratio)\s*$/) {
            $scoretype = $1;
        }
        if ($scoretype eq 'decimal') {
            if ($params->{'result_resultscore_textstring'} =~ /^\s*(\d*\.?\d*)\s*$/) {
                $score = $1;
            }
        } elsif ($scoretype eq 'ratio') {
            if ($params->{'result_resultscore_textstring'} =~ m{^\s*(\d+)\s*/\s*(\d+)\s*$}) {
                $score = $1.'/'.$2;
            }
        } elsif ($scoretype eq 'percentage') {
            if ($params->{'result_resultscore_textstring'} =~ /^\s*(\d+)\s*(\%?)\s*$/) {
                $score = $1.$2;
            }
        }
        my $posslang = $params->{'result_resultscore_language'};
        $posslang =~ s/(^\s+|\s+)$//g; 
        if ($posslang =~ /^\w+(|\-\w+(|\-w+))$/) {
            $lang = $posslang;
        }
    } 
    my $errormsg;
    if (ref($errors) eq 'HASH') {
        $errormsg = join(',',keys(%{$errors}));
    }
    &Apache::loncommon::content_type($r,'text/xml');
    $r->send_http_header;
    if ($r->header_only) {
        return;
    }
    $r->print(<<"END");
<message_response>
  <lti_message_type>basic-lis-updateresult</lti_message_type>
  <statusinfo>
     <codemajor>Failure</codemajor>
     <severity>Error</severity>
     <codeminor>$errormsg</codeminor>
  </statusinfo>
  <result>
    <sourcedid>$params->{'sourcedid'}</sourcedid>
    <statusofresult>interim</statusofresult>
    <date>$date</date>
    <resultscore>
      <resultvaluesourcedid>$scoretype</resultvaluesourcedid>
      <textstring>$score</textstring>
      <language>$lang</language>
    </resultscore>
  </result>
</message_response>
END
    return;
}

1;