Return to lonr.pm CVS log

Up to [LON-CAPA] / loncom / homework

Needed for R to work

    1: # The LearningOnline Network with CAPA
    2: # Interface routines to R CAS
    3: #
    4: # $Id: lonr.pm,v 1.10 2009/09/02 14:13:16 www Exp $
    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::lonr;
   30:  
   31: use strict;
   32: use IO::Socket;
   33: use Apache::lonnet;
   34: use Apache::response();
   35: use LONCAPA;
   36: use Tie::IxHash::Easy; # autoties all subhashes to keep index order
   37: use Data::Dumper;  # used to output hash contents
   38: 
   39: my $errormsg='';
   40: 
   41: #
   42: # Rcroak: for use with R-error messages
   43: #
   44: sub Rcroak {
   45:    $errormsg=$_[0];
   46: }
   47: 
   48: #
   49: #
   50: # Rpeel takes a string containing serialized values from R, 
   51: # peels off the first syntactically complete unit (number, string or array),
   52: # and returns a list (first unit, remainder).
   53: #
   54: sub Rpeel {
   55:         my $x = $_[0];  # the string containing the serialized R object(s)
   56:         if ($x =~ /^((?:i|d):(.+?);)(.*)$/) {
   57:                 return ($1, $+);  # x starts with a number
   58:         } elsif ($x =~ /^s:(\d+):/) {
   59:                 my $n = $1;  # x starts with a string of length n
   60:                 if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) {
   61:                         return ($1, $+);  # x starts with a valid string
   62:                 } else {
   63:                         &Rcroak('invalid string detected');
   64:                 }
   65:         } elsif ($x =~ /^a:/) {
   66:                 # x starts with an array -- need to find the closing brace
   67:                 my $i = index $x, '{', 0;  # position of first opening brace
   68:                 if ($i < 0) {
   69:                         &Rcroak('array with no opening brace');
   70:                 }
   71:                 my $open = 1;  # counts open braces
   72:                 my $j = index $x, '}', $i; # position of first closing brace
   73:                 $i = index $x, '{', $i + 1; # position of next opening brace (if any)
   74:                 my $pos = -1;  # position of final closing brace
   75:                 do {
   76:                         if (($i < $j) && ($i > 0)) {
   77:                                 # encounter another opening brace before next closing brace
   78:                                 $open++;
   79:                                 $i = index $x, '{', $i + 1;  # find the next opening brace
   80:                         } elsif ($j > 0) {
   81:                                 # next brace encountered is a closing brace
   82:                                 $open--;
   83:                                 $pos = $j;
   84:                                 $j = index $x, '}', $j + 1;
   85:                         } else {
   86:                                 &Rcroak('unmatched left brace');
   87:                         }
   88:                 } until ($open eq 0);
   89:                 # array runs from start to $pos
   90:                 my $a = substr $x, 0, $pos + 1;  # array
   91:                 my $b = substr $x, $pos + 1;     # remainder
   92:                 return ($a, $b);
   93:         } else {
   94:                 &Rcroak('unrecognized R value');
   95:         }
   96: }
   97: # --- end Rpeel ---
   98: 
   99: #
  100: # Rreturn accepts a string containing a serialized R object
  101: # and returns either the object's value (if it is scalar) or a reference
  102: # to a hash containing the contents of the object.  Any null keys in the hash
  103: # are replaced by 'resultNNN' where NNN is the index of the entry in the original
  104: # R array.
  105: #
  106: sub Rreturn {
  107:     my $x = $_[0];  # the string containing the serialized R object(s)
  108:     $x=~s/^\"//;
  109:     $x=~s/\"$//;
  110:     $x=~s/\\\"/\"/g;
  111:     $errormsg='';
  112:     if ($x =~ /^(?:i|d):(.+?);$/) {
  113:         return $1;  # return the value of the number
  114:     } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {
  115:         # string -- verify the length
  116:         if (length($2) eq $1) {
  117:            return $2;  # return the string
  118:         } else {
  119:            return 'mismatch in string length';
  120:         }
  121:     } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {
  122:         # array
  123:         my $dim = $1;  # array size
  124:         $x = $2;  # array contents
  125:         tie(my %h,'Tie::IxHash::Easy'); # start a hash
  126:         keys(%h) = $dim; # allocate space for the hash
  127:         my $key;
  128:         my $y;
  129:         for (my $i = 0; $i < $dim; $i++) {
  130:            ($y, $x) = &Rpeel($x);  # strip off the entry for the key
  131:            if ($y eq '') {
  132:               &Rcroak('ran out of keys');
  133:            }
  134:            $key = &Rreturn($y);
  135:            if ($key eq '') {
  136:               $key = "result$i";  # correct null key
  137:            }
  138:            ($y, $x) = &Rpeel($x);  # strip off the value
  139:            if ($y eq '') {
  140:                &Rcroak('ran out of values');
  141:            }
  142:            if ($y =~ /^a:/) {
  143:                $h{$key} = \&Rreturn($y);  # array value: store as reference
  144:            } else {
  145:                $h{$key} = &Rreturn($y);  # scalar value: store the entry in the hash
  146:            }
  147:         }
  148:         if ($errormsg) { return $errormsg; }
  149:         return \%h;  # return a reference to the hash
  150:     } else {
  151:         return 'Unrecognized output';
  152:     }
  153: }
  154: # --- end Rreturn ---
  155: 
  156: sub Rentry {
  157:     my $hash = shift;  # pointer to tied hash
  158:     my $i;
  159:     if (ref($hash) ne 'HASH') {
  160:        return 'Argument to cas_hashref_entry is not a hash!';
  161:     }
  162:     while ($i = shift) {
  163:        if (exists($hash->{$i})) {
  164:           $hash = $hash->{$i};
  165:        } else {
  166:           return undef;
  167:        }
  168:        if (ref($hash) eq 'REF') {
  169:           $hash = $$hash;  # dereference one layer
  170:        } elsif (ref($hash) ne 'HASH') {
  171:           return $hash;  # drilled down to a scalar
  172:        }
  173:     }
  174: }
  175: 
  176: sub Rarray {
  177:     my $hash = shift;  # pointer to tied hash
  178:     my $i;
  179:     if (ref($hash) ne 'HASH') {
  180:        return 'Argument to cas_hashref_array is not a hash!';
  181:     }
  182:     while ($i = shift) {
  183:        if (exists($hash->{$i})) {
  184:           $hash = $hash->{$i};
  185:        } else {
  186:           return undef;
  187:        }
  188:        if (ref($hash) eq 'REF') {
  189:           $hash = $$hash;  # dereference one layer
  190:        }
  191:     }
  192:     my @returnarray=();
  193:     foreach my $key (keys(%{$hash})) {
  194:         $returnarray[$key-1]=$$hash{$key};
  195:     }
  196:     return @returnarray;
  197: }
  198: 
  199: sub connect {
  200:    return IO::Socket::UNIX->new(Peer    => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
  201: 				Type    => SOCK_STREAM,
  202: 				Timeout => 10);
  203: }
  204: 
  205: sub disconnect {
  206:     my ($socket)=@_;
  207:     if ($socket) { close($socket); }
  208: }
  209: 
  210: sub rreply {
  211:     my ($socket,$cmd)=@_;
  212:     if ($socket) {
  213: 	print $socket &escape($cmd)."\n";
  214:         my $reply=<$socket>;
  215:         chomp($reply);
  216:         if ($reply=~/^Incorrect/) { $reply='Error: '.$reply; }
  217:         return &unescape($reply);
  218:     } else {
  219:         return 'Error: no connection.';
  220:     }
  221: }
  222: 
  223: sub blacklisted {
  224:     my ($cmd)=@_;
  225:     foreach my $forbidden (
  226:         'read','write','scan','save','socket','connections',
  227:         'open','close',
  228:         'plot','X11','windows','quartz',
  229:         'postscript','pdf','png','jpeg',
  230:         'dev\.list','dev\.next','dev\.prev','dev\.set',
  231:         'dev\.off','dev\.copy','dev\.print','graphics',
  232:         'library','package','source','sink','objects',
  233:         'Sys\.','unlink','file\.','on\.exit','error',
  234:         'q\(\)'
  235:      ) {
  236: 	if ($cmd=~/$forbidden/s) { return 1; }
  237:     } 
  238:     return 0;
  239: }
  240: 
  241: sub r_allowed_libraries {
  242:    return ('alr3','boot','car','class','cluster','datasets','Hmisc','KernSmooth','leaps','lmtest',
  243:            'MASS','methods','mgcv','nlme','nnet','qAnalyst','quadprog','rpart','SuppDists','spatial',
  244:            'splines','stats','stats4','survival','tseries','zoo');
  245: }
  246: 
  247: sub r_is_allowed_library {
  248:     my ($library)=@_;
  249:     foreach my $allowed_library (&r_allowed_libraries()) {
  250:        if ($library eq $allowed_library) { return 1; }
  251:     }
  252:     return 0;
  253: }
  254: 
  255: sub runscript {
  256:     my ($socket,$fullscript,$libraries)=@_;
  257:     if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
  258:     my $reply='';
  259:     $fullscript=~s/[\n\r\l]//gs;
  260:     if ($libraries) {
  261:        foreach my $library (split(/\s*\,\s*/,$libraries)) {
  262:           unless ($library=~/\w/) { next; }
  263:           if (&r_is_allowed_library($library)) {
  264:               $reply=&rreply($socket,'library('.$library.');');
  265:               if ($reply=~/^Error\:/) { return $reply; }
  266:           } else { 
  267:              return 'Error: blacklisted'; 
  268:           }
  269:        }
  270:     }
  271:     $fullscript=~s/\;+\s*$//s;
  272:     if ($fullscript=~/\w/) { $reply=&rreply($socket,$fullscript.';'); }
  273:     if ($reply=~/^Error\:/) { return $reply; }
  274:     $reply=~s/^\s*//gs;
  275:     $reply=~s/\s*$//gs;
  276:     &Apache::lonxml::debug("r $fullscript \n reply $reply");
  277:     return $reply;
  278: }
  279: 
  280: sub runserializedscript {
  281:     my ($socket,$fullscript,$libraries)=@_;
  282:     if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
  283:     my $reply;
  284:     $fullscript=~s/[\n\r\l]//gs;
  285:     if ($libraries) {
  286:        foreach my $library (split(/\s*\,\s*/,$libraries)) {
  287:           unless ($library=~/\w/) { next; }
  288:           if (&r_is_allowed_library($library)) {
  289:               $reply=&rreply($socket,'library('.$library.');');
  290:               if ($reply=~/^Error\:/) { return($reply,$reply); }
  291:           } else {
  292:              return 'Error: blacklisted';
  293:           }
  294:        }
  295:     }
  296:     $fullscript=~s/\;+\s*$//s;
  297:     my $lastline='';
  298:     my $firstpart='';
  299:     if ($fullscript=~/\;/) {
  300:        ($firstpart,$lastline)=($fullscript=~/^(.*\;)([^\;]+)$/);
  301:     } else {
  302:        $lastline=$fullscript;
  303:     }
  304:     if ($firstpart) {
  305:         $firstpart=~s/\;+\s*$//s;
  306:         $reply=&rreply($socket,$firstpart.';');
  307:         if ($reply=~/^Error\:/) { return($reply,$reply); }
  308:     }
  309: # The last line needs to be serialized
  310:     $reply=&Rreturn(&rreply($socket,"phpSerialize($lastline);"));
  311:     return($reply,&Dumper($reply));
  312: }
  313: 
  314: sub r_cas_formula_fix {
  315:    my ($expression)=@_;
  316:    return &Apache::response::implicit_multiplication($expression);
  317: }
  318: 
  319: sub r_run {
  320:     my ($script,$submission,$argument,$libraries) = @_;
  321:     my $socket=&connect();
  322:     my @submissionarray=split(/\s*\,\s*/,$submission);
  323:     for (my $i=0;$i<=$#submissionarray;$i++) {
  324:         my $n=$i+1;
  325:         my $fixedsubmission=&r_cas_formula_fix($submissionarray[$i]);
  326:         $script=~s/RESPONSE\[$n\]/$fixedsubmission/gs;
  327:     }
  328:     my @argumentarray=@{$argument};
  329:     for (my $i=0;$i<=$#argumentarray;$i++) {
  330:         my $n=$i+1;
  331:         my $fixedargument=&r_cas_formula_fix($argumentarray[$i]);
  332:         $script=~s/LONCAPALIST\[$n\]/$fixedargument/gs;
  333:     }
  334:     my $reply=&runscript($socket,$script,$libraries);
  335:     &disconnect($socket);
  336:     if ($reply=~/^\s*true\s*$/i) { return 'EXACT_ANS'; }
  337:     if ($reply=~/^\s*false\s*$/i) { return 'INCORRECT'; } 
  338:     return 'BAD_FORMULA';
  339: }
  340: 
  341: sub r_eval {
  342:     my ($script,$libraries,$hashflag) = @_;
  343:     my $socket=&connect();
  344:     my $reply;
  345:     my $dump='';
  346:     if ($hashflag) {
  347:        ($reply,$dump)=&runserializedscript($socket,$script,$libraries);
  348:     } else {
  349:        $reply=&runscript($socket,$script,$libraries);
  350:     }
  351:     &disconnect($socket);
  352:     return ($reply,$dump);
  353: }
  354: 
  355: 
  356: sub compareterms {
  357:     my ($socket,$terma,$termb)=@_;
  358:     my $difference=$terma.'-('.$termb.')';
  359:     if (&blacklisted($difference)) { return 'Error: blacklisted'; }
  360:     my $reply=&rreply($socket,$difference.';');
  361:     if ($reply=~/^\s*0\s*$/) { return 'true'; }
  362:     if ($reply=~/^Error\:/) { return $reply; }
  363:     return 'false';
  364: }
  365: 
  366: sub r_check {
  367:     my ($response,$answer,$reterror) = @_;
  368:     my $socket=&connect();
  369:     my $reply=&compareterms($socket,$response,$answer);
  370:     &disconnect($socket);
  371:     # integer to string mappings come from capaParser.h
  372:     # 1 maps to 'EXACT_ANS'
  373:     if ($reply eq 'true') { return 1; }
  374:     # 11 maps to 'BAD_FORMULA'
  375:     if ($reply=~/^Error\:/) { return 11; }
  376:     # 7 maps to 'INCORRECT'
  377:     return 7;
  378: }
  379:  
  380: 1;
  381: __END__;