Annotation of loncom/lti/ltipassback.pm, revision 1.6
1.1 raeburn 1: # The LearningOnline Network with CAPA
2: # LTI Consumer Module to receive grades passed back by Provider
3: #
1.6 ! raeburn 4: # $Id: ltipassback.pm,v 1.5 2017/12/15 17:07:09 raeburn Exp $
1.1 raeburn 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
28:
29: package Apache::ltipassback;
30:
31: use strict;
1.6 ! raeburn 32: use URI::Escape;
1.1 raeburn 33: use Apache::Constants qw(:common :http);
34: use Apache::lonnet;
35: use Apache::loncommon;
36: use Apache::lonacc;
37: use LONCAPA::ltiutils;
38:
39: sub handler {
40: my $r = shift;
41: my %errors;
1.6 ! raeburn 42: my $params = {};
! 43: my ($oauthtype,$authheader,$xmlbody);
! 44: #
! 45: # Retrieve content type from headers
! 46: #
! 47: my $content_type = $r->headers_in->get('Content-Type');
! 48: if ($content_type eq 'application/xml') {
! 49: $oauthtype = 'consumer';
! 50: #
! 51: # Retrieve OAuth data from Authorization header sent by LTI Provider
! 52: #
! 53: $authheader = $r->headers_in->get('Authorization');
! 54: my ($authtype,$valuestr) = ($authheader =~ /^(OAuth)\s+(.+)$/i);
! 55: if (lc($authtype) eq 'oauth') {
! 56: foreach my $pair (split(/\s*,\s*/,$valuestr)) {
! 57: my ($key,$value) = split(/=/,$pair);
! 58: $value =~ s /(^"|"$)//g;
! 59: $params->{$key} = URI::Escape::uri_unescape($value);
! 60: }
! 61: }
! 62: #
! 63: # Retrieve message body
! 64: #
! 65: my $length = $r->headers_in->get('Content-length');
! 66: if ($length) {
! 67: $r->read($xmlbody,$length,0);
! 68: if ($xmlbody ne '') {
! 69: my %grades = &LONCAPA::ltiutils::parse_grade_xml($xmlbody);
! 70: foreach my $num (sort { $a <=> $b } (keys(%grades))) {
! 71: if (ref($grades{$num}) eq 'HASH') {
! 72: if (($grades{$num}{'sourcedid'} ne '') && ($grades{$num}{'score'} ne '')) {
! 73: $params->{'sourcedid'} = $grades{$num}{'sourcedid'};
! 74: $params->{'result_resultscore_textstring'} = $grades{$num}{'score'};
! 75: $params->{'result_resultscore_language'} = $grades{$num}{'language'};
! 76: $params->{'result_resultvaluesourcedid'} = 'decimal';
! 77: }
! 78: }
! 79: }
! 80: }
! 81: }
! 82: } else {
! 83: $oauthtype = 'request token';
1.1 raeburn 84: #
85: # Retrieve data POSTed by LTI Provider
86: #
1.6 ! raeburn 87: &Apache::lonacc::get_posted_cgi($r);
! 88: foreach my $key (sort(keys(%env))) {
! 89: if ($key =~ /^form\.(.+)$/) {
! 90: $params->{$1} = $env{$key};
! 91: }
1.1 raeburn 92: }
93: }
94:
95: unless (keys(%{$params})) {
96: $errors{1} = 1;
97: &invalid_request($r,$params,\%errors);
98: return OK;
99: }
100:
101: unless ($params->{'oauth_consumer_key'} &&
102: $params->{'oauth_nonce'} &&
103: $params->{'oauth_timestamp'} &&
104: $params->{'oauth_version'} &&
105: $params->{'oauth_signature'} &&
106: $params->{'oauth_signature_method'}) {
107: $errors{2} = 1;
108: &invalid_request($r,$params,\%errors);
109: return OK;
110: }
111:
112: #
113: # Retrieve the signature, digested symb, digested user, and LON-CAPA
114: # courseID from the sourcedid in the POSTed data
115: #
116: unless ($params->{'sourcedid'}) {
117: $errors{3} = 1;
118: &invalid_request($r,$params,\%errors);
119: return OK;
120: }
121:
122: my ($resultsig,$digsymb,$diguser,$cid) = split(/\Q:::\E/,$params->{'sourcedid'});
123: unless ($resultsig && $digsymb && $diguser && $cid) {
124: $errors{4} = 1;
125: &invalid_request($r,$params,\%errors);
126: return OK;
127: }
128:
129: my ($cdom,$cnum,$marker,$symb,$uname,$udom);
130:
131: #
132: # Determine the domain and the courseID of the LON-CAPA course to which the
133: # launch of LON-CAPA should provide access.
134: #
135: ($cdom,$cnum) = &LONCAPA::ltiutils::get_loncapa_course($r->dir_config('lonHostID'),
136: $cid,\%errors);
137: unless ($cdom && $cnum) {
138: &invalid_request($r,$params,\%errors);
139: return OK;
140: }
141:
142: #
143: # Use the digested symb to lookup the real symb in exttools.db
144: #
145:
146: ($marker,$symb,$uname,$udom) =
147: &LONCAPA::ltiutils::get_tool_instance($cdom,$cnum,$digsymb,$diguser,\%errors);
148:
149: unless ($marker) {
150: &invalid_request($r,$params,\%errors);
151: return OK;
152: }
153:
154: #
155: # Retrieve the Consumer key and Consumer secret from the domain configuration
156: # for the Tool Provider ID stored in the exttool_$marker.db
157: #
158:
159: my (%toolsettings,%ltitools);
160: my ($consumer_secret,$nonce_lifetime) =
161: &LONCAPA::ltiutils::get_tool_secret($params->{'oauth_consumer_key'},
162: $marker,$symb,$cdom,$cnum,
163: \%toolsettings,\%ltitools,\%errors);
164:
1.6 ! raeburn 165: if (keys(%errors) > 0) {
! 166: &invalid_request($r,$params,\%errors);
! 167: return OK;
! 168: }
! 169:
1.1 raeburn 170: #
171: # Verify the signed request using the consumer_key and
172: # secret for the specific LTI Provider.
173: #
174:
175: my $protocol = 'http';
176: if ($ENV{'SERVER_PORT'} == 443) {
177: $protocol = 'https';
178: }
1.6 ! raeburn 179:
! 180: unless (LONCAPA::ltiutils::verify_request($oauthtype,$protocol,$r->hostname,$r->uri,
! 181: $r->method,$consumer_secret,$params,
! 182: $authheader,\%errors)) {
! 183: &invalid_request($r,$params,\%errors);
! 184: return OK;
! 185: }
! 186:
! 187: #
! 188: # Verify XML in request body has not been tampered with
! 189: #
! 190:
! 191: my $bodyhash = Digest::SHA::sha1_base64($xmlbody);
! 192: while (length($bodyhash) % 4) {
! 193: $bodyhash .= '=';
! 194: }
! 195: unless ($bodyhash eq $params->{oauth_body_hash}) {
! 196: $errors{16} = 1;
1.1 raeburn 197: &invalid_request($r,$params,\%errors);
198: return OK;
199: }
200:
201: #
202: # Determine if nonce in POSTed data has expired.
203: # If unexpired, confirm it has not already been used.
1.6 ! raeburn 204: #
1.1 raeburn 205:
206: unless (&LONCAPA::ltiutils::check_nonce($params->{'oauth_nonce'},$params->{'oauth_timestamp'},
207: $ltitools{'lifetime'},$cdom,$r->dir_config('lonLTIDir'))) {
1.6 ! raeburn 208: $errors{17} = 1;
1.1 raeburn 209: &invalid_request($r,$params,\%errors);
210: return OK;
211: }
212:
213: #
214: # Verify that the sourcedid has not been tampered with,
215: # and the gradesecret used to create it is still valid.
216: #
217:
218: unless (&LONCAPA::ltiutils::verify_lis_item($resultsig,'grade',$digsymb,$diguser,$cdom,
219: $cnum,\%toolsettings,\%ltitools,\%errors)) {
220: &invalid_request($r,$params,\%errors);
221: return OK;
222: }
223:
224: #
225: # Does the user have an active role in the course which maps to one of
226: # the supported LTI roles
227: #
228:
229: if (($uname ne '') && ($udom ne '')) {
230: my %maproles;
231: if (ref($ltitools{'roles'}) eq 'HASH') {
232: %maproles = %{$ltitools{'roles'}};
233: }
234: unless (keys(%maproles)) {
1.6 ! raeburn 235: $errors{22} = 1;
1.1 raeburn 236: &invalid_request($r,$params,\%errors);
237: return OK;
238: }
239: my ($crstype,$hasrole);
240: my @allroles = &Apache::lonuserutils::roles_by_context('course',0,$crstype);
241: my (%availableroles,$coursepersonnel,$includestudents,%users);
242: foreach my $role (@allroles) {
243: if (exists($maproles{$role})) {
244: $availableroles{$role} = 1;
245: if ($role eq 'st') {
246: $includestudents = 1;
247: } else {
248: $coursepersonnel = 1;
249: }
250: }
251: }
252: if (keys(%availableroles)) {
253: my $courseurl = "/$cdom/$cnum";
254: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname,$courseurl);
255: if (keys(%roleshash)) {
256: my $now = time;
257: foreach my $key (keys(%roleshash)) {
258: if ($key =~ m{^\Q$courseurl\E(|/\w+)_(\w+)$}) {
259: my ($secgroup,$rolecode) = ($1,$2);
260: next if ($rolecode eq 'gr');
261: next unless ($availableroles{$rolecode});
262: my ($dummy,$end,$start)=split(/\_/,$roleshash{$key});
263: next if (defined($end) && $end && ($now > $end));
264: next if (defined($start) && $start && ($now < $start));
265: $hasrole = 1;
266: last;
267: }
268: }
269: }
270: }
271: unless ($hasrole) {
1.6 ! raeburn 272: $errors{23} = 1;
1.1 raeburn 273: &invalid_request($r,$params,\%errors);
274: return OK;
275: }
276: } else {
1.6 ! raeburn 277: $errors{24} = 1;
1.1 raeburn 278: &invalid_request($r,$params,\%errors);
279: return OK;
280: }
281:
282: #
283: # Store result if one was sent in a valid format.
284: #
285:
286: my ($result,$resulttype,$lang,$pcf);
287: if (exists($params->{'result_resultvaluesourcedid'})) {
288: $resulttype = $params->{'result_resultvaluesourcedid'};
289: $resulttype =~ s/(^\s+|\s+)$//g;
1.2 raeburn 290: } else {
291: $resulttype = 'decimal';
1.5 raeburn 292: }
1.1 raeburn 293: $result = $params->{'result_resultscore_textstring'};
294: $result =~ s/(^\s+|\s+)$//g;
295: my $posslang = $params->{'result_resultscore_language'};
296: $posslang =~ s/(^\s+|\s+)$//g;
297: if ($posslang =~ /^\w+(|\-\w+(|\-w+))$/) {
298: $lang = $posslang;
299: }
300: if (($resulttype eq 'ratio') || ($resulttype eq 'decimal') || ($resulttype eq 'percentage')) {
301: if ($resulttype eq 'ratio') {
302: my ($numerator,$denominator) = split(/\s*\/\s*/,$result,2);
303: $numerator =~ s/(^\s+|\s+)$//g;
304: $denominator =~ s/(^\s+|\s+)$//g;
305: if (($numerator =~ /^\d+$/) && ($denominator =~ /^\d+$/) && ($denominator !=0)) {
306: eval {
307: $pcf = $numerator/$denominator;
308: };
309: }
310: if ($@) {
1.3 raeburn 311: $errors{24} = 1;
1.1 raeburn 312: &invalid_request($r,$params,\%errors);
313: return OK;
314: }
315: } elsif ($resulttype eq 'decimal') {
316: if (($result ne '') && ($result =~ /^\d*\.?\d*$/)) {
317: if ($result eq '.') {
318: $result = 0;
319: }
320: if (($result >= 0) && ($result <= 1)) {
321: $pcf = $result;
322: }
323: }
324: } elsif ($resulttype eq 'percentage') {
325: if ($result =~ /^(\d+)\s*\%?$/) {
326: my $percent = $1;
327: if (($percent >= 0) && ($percent <= 100)) {
328: $pcf = $percent/100.0;
329: }
330: }
331: }
332: if ($pcf ne '') {
333: my %newrecord=();
334: my $reckey = 'resource.0.solved';
335: my %record = &Apache::lonnet::restore($symb,$cdom.'_'.$cnum,$udom,$uname);
1.5 raeburn 336: my $tries = 0;
337: if ($record{'resource.0.tries'} =~ /^\d$/) {
338: $tries = $record{'resource.0.tries'};
339: }
1.1 raeburn 340: if ($record{'resource.0.awarded'} ne $pcf) {
341: $newrecord{'resource.0.awarded'} = $pcf;
342: }
343: if ($pcf == 0) {
1.5 raeburn 344: if ($record{$reckey} ne 'incorrect_by_passback') {
345: $newrecord{$reckey} = 'incorrect_by_passback';
1.1 raeburn 346: }
347: } else {
1.5 raeburn 348: if ($record{$reckey} ne 'correct_by_passback') {
349: $newrecord{$reckey} = 'correct_by_passback';
1.1 raeburn 350: }
351: }
352: if (%newrecord) {
1.5 raeburn 353: $newrecord{'resource.0.tries'} = 1 + $tries;
1.4 raeburn 354: $env{'request.course.id'} = $cdom.'_'.$cnum;
1.1 raeburn 355: my $result = &Apache::lonnet::cstore(\%newrecord,$symb,$cdom.'_'.$cnum,
356: $udom,$uname);
1.4 raeburn 357: delete($env{'request.course.id'});
1.1 raeburn 358: if (($result eq 'ok') || ($result eq 'con_delayed')) {
359: &success($r,$params->{'sourcedid'},$resulttype,$result,$lang);
360: } else {
1.3 raeburn 361: $errors{25} = 1;
1.1 raeburn 362: &invalid_request($r,$params,\%errors);
363: }
1.5 raeburn 364: } else {
365: &success($r,$params->{'sourcedid'},$resulttype,$result,$lang);
1.1 raeburn 366: }
367: } else {
1.3 raeburn 368: $errors{26} = 1;
1.1 raeburn 369: &invalid_request($r,$params,\%errors);
370: }
371: } else {
1.3 raeburn 372: $errors{27} = 1;
1.1 raeburn 373: &invalid_request($r,$params,\%errors);
374: }
375: return OK;
376: }
377:
378: sub success {
379: my ($r,$sourcedid,$scoretype,$score,$lang) = @_;
380: my $date = &Apache::loncommon::utc_string(time);
381: &Apache::loncommon::content_type($r,'text/xml');
382: $r->send_http_header;
383: if ($r->header_only) {
384: return;
385: }
386: $r->print(<<"END");
387: <?xml version="1.0" encoding="UTF-8" ?>
388: <message_response>
389: <lti_message_type>basic-lis-updateresult</lti_message_type>
390: <statusinfo>
391: <codemajor>Success</codemajor>
392: <severity>Status</severity>
393: <codeminor>fullsuccess</codeminor>
394: <description>Grade updated</description>
395: </statusinfo>
396: <result>
397: <sourcedid>$sourcedid</sourcedid>
398: <date>$date</date>
399: <resultscore>
400: <resultvaluesourcedid>$scoretype</resultvaluesourcedid>
401: <textstring>$score</textstring>
402: <language>$lang</language>
403: </resultscore>
404: </result>
405: </message_response>
406: END
407: return;
408: }
409:
410: sub invalid_request {
411: my ($r,$params,$errors) = @_;
412: my $date = &Apache::loncommon::utc_string(time);
413: my ($scoretype,$score,$lang);
414: if (ref($params) eq 'HASH') {
415: if ($params->{'result_resultvaluesourcedid'} =~ /^\s*(decimal|percentage|ratio)\s*$/) {
416: $scoretype = $1;
417: }
418: if ($scoretype eq 'decimal') {
419: if ($params->{'result_resultscore_textstring'} =~ /^\s*(\d*\.?\d*)\s*$/) {
420: $score = $1;
421: }
422: } elsif ($scoretype eq 'ratio') {
423: if ($params->{'result_resultscore_textstring'} =~ m{^\s*(\d+)\s*/\s*(\d+)\s*$}) {
424: $score = $1.'/'.$2;
425: }
426: } elsif ($scoretype eq 'percentage') {
427: if ($params->{'result_resultscore_textstring'} =~ /^\s*(\d+)\s*(\%?)\s*$/) {
428: $score = $1.$2;
429: }
430: }
431: my $posslang = $params->{'result_resultscore_language'};
432: $posslang =~ s/(^\s+|\s+)$//g;
433: if ($posslang =~ /^\w+(|\-\w+(|\-w+))$/) {
434: $lang = $posslang;
435: }
436: }
437: my $errormsg;
438: if (ref($errors) eq 'HASH') {
439: $errormsg = join(',',keys(%{$errors}));
440: }
441: &Apache::loncommon::content_type($r,'text/xml');
442: $r->send_http_header;
443: if ($r->header_only) {
444: return;
445: }
446: $r->print(<<"END");
447: <message_response>
448: <lti_message_type>basic-lis-updateresult</lti_message_type>
449: <statusinfo>
450: <codemajor>Failure</codemajor>
451: <severity>Error</severity>
452: <codeminor>$errormsg</codeminor>
453: </statusinfo>
454: <result>
455: <sourcedid>$params->{'sourcedid'}</sourcedid>
456: <statusofresult>interim</statusofresult>
457: <date>$date</date>
458: <resultscore>
459: <resultvaluesourcedid>$scoretype</resultvaluesourcedid>
460: <textstring>$score</textstring>
461: <language>$lang</language>
462: </resultscore>
463: </result>
464: </message_response>
465: END
466: return;
467: }
468:
469: 1;
470:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to ltipassback.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lti