source: branches/prototype-v0/zoo-project/zoo-kernel/service_internal_r.c @ 880

Last change on this file since 880 was 880, checked in by djay, 3 years ago

Modify memory configuration option gesture. Now, in case you don't have setup memory option in the main section your main.cfg file then, the ZOO-Kernel will load everything in memory and will also store the file containing the input. In case you want the old mode, you have to set memory option to 'load' in your main.cfg file. Fix issue with loading R ZOO-Service located in a subdirectory. Support for XML Execute request containing TEXT_NODE when CDATA_NODE should be used.

  • Property svn:keywords set to Id
File size: 10.4 KB
Line 
1/*
2 * Author : Gérald FENOY
3 *
4 * Copyright (c) 2018 GeoLabs SARL
5 *
6 * Permission is hereby granted, free of charge, to any person obtaining a copy
7 * of this software and associated documentation files (the "Software"), to deal
8 * in the Software without restriction, including without limitation the rights
9 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10 * copies of the Software, and to permit persons to whom the Software is
11 * furnished to do so, subject to the following conditions:
12 *
13 * The above copyright notice and this permission notice shall be included in
14 * all copies or substantial portions of the Software.
15 *
16 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22 * THE SOFTWARE.
23 */
24
25#include "service_internal_r.h"
26
27void jump_to_toplevel(void){
28  fprintf(stderr,"Error occured\n");
29  fprintf(stderr,"%s %d \n",__FILE__,__LINE__);
30  fflush(stderr);
31  //resetStack(1);
32  fprintf(stderr,"%s %d \n",__FILE__,__LINE__);
33  fflush(stderr);
34}
35
36void init_zoo(SEXP conf,SEXP outputs){
37  const char* names[]={
38    "SERVICE_SUCCEEDEED",
39    "SERVICE_FAILED",
40    "conf",
41    "outputs",
42    ""
43  };
44  SEXP res = PROTECT(mkNamed(VECSXP, names));
45  SET_VECTOR_ELT(res, 0, Rf_ScalarInteger(3));
46  SET_VECTOR_ELT(res, 1, Rf_ScalarInteger(4));
47  SET_VECTOR_ELT(res, 2, conf);
48  SET_VECTOR_ELT(res, 3, outputs);
49  defineVar(install("zoo"),res, R_GlobalEnv);
50
51  static const R_CallMethodDef callMethods[]  = {
52    {"ZOOTranslate", (DL_FUNC) &RTranslate, 1},
53    {"ZOOUpdateStatus", (DL_FUNC) &RUpdateStatus, 2},
54    {NULL, NULL, 0}
55  };
56 
57  static R_NativePrimitiveArgType RTranslate_t[] = {
58    STRSXP
59  };
60  static R_NativePrimitiveArgType RUpdateStatus_t[] = {
61    VECSXP,STRSXP
62  };
63 
64  static const R_CMethodDef cMethods[] = {
65   {"ZOOTranslate", (DL_FUNC) &RTranslate, 1, RTranslate_t},
66   {"ZOOUpdateStatus", (DL_FUNC) &RUpdateStatus, 2, RUpdateStatus_t},
67   {NULL, NULL, 0, NULL}
68  };
69 
70  DllInfo *info = R_getEmbeddingDllInfo();
71  R_registerRoutines(info, cMethods, callMethods, NULL, NULL);
72}
73
74/**
75 * Load a R script then run the function corresponding to the service
76 * by passing the conf, inputs and outputs parameters by reference.
77 *
78 * @param main_conf the conf maps containing the main.cfg settings
79 * @param request the map containing the HTTP request
80 * @param s the service structure
81 * @param real_inputs the maps containing the inputs
82 * @param real_outputs the maps containing the outputs
83 */
84int zoo_r_support(maps** main_conf,map* request,service* s,maps **real_inputs,maps **real_outputs){
85  SEXP pName;
86  int result=0;
87  maps* m=*main_conf;
88  maps* inputs=*real_inputs;
89  maps* outputs=*real_outputs;
90  map* tmp0=getMapFromMaps(*main_conf,"lenv","cwd");
91  char *ntmp=tmp0->value;
92  map* tmp=NULL;
93  int hasToClean=0;
94  char *r_path, *rpath;
95  map* cwdMap=getMapFromMaps(*main_conf,"main","servicePath");
96  int r_argc = 3;
97  char *r_argv[] = { "R", "--no-save", "--silent" };
98  Rf_initEmbeddedR(r_argc, r_argv);
99  if(cwdMap!=NULL)
100    r_path=cwdMap->value;
101  else{
102    if(tmp0!=NULL)
103      r_path=tmp0->value;
104    else
105      r_path=(char*)".";
106  }
107
108  tmp=getMap(s->content,"serviceProvider");
109  map* mp=getMap(request,"metapath");
110  if(tmp!=NULL){
111    if(mp!=NULL && strlen(mp->value)>0){
112      char *mn=(char*)malloc((strlen(mp->value)+strlen(tmp->value)+2)*sizeof(char));
113      sprintf(mn,"%s/%s",mp->value,tmp->value);
114      pName = mkString(mn);
115      free(mn);
116    }
117    else{
118      char *tmpStr=(char*)malloc((strlen(r_path)+strlen(tmp->value)+2)*sizeof(char));
119      sprintf(tmpStr,"%s/%s",r_path,tmp->value);
120      pName = mkString(tmpStr);
121      free(tmpStr);
122    }
123  }
124  else{
125    errorException (m, "Unable to parse serviceProvider please check your zcfg file.", "NoApplicableCode", NULL);
126    return -1;
127  }
128  SEXP e;
129  int errorOccurred;
130  PROTECT(e = lang2(install("source"), pName));
131  R_tryEval(e, R_GlobalEnv, &errorOccurred);
132  UNPROTECT(1);
133  if (errorOccurred){
134    setMapInMaps(*main_conf,"lenv","message",_("Unable to load your R file"));
135    return SERVICE_FAILED;
136  }else{
137    result=SERVICE_FAILED;
138    {
139      SEXP pValue;
140      SEXP  arg1=RList_FromMaps(m);
141      SEXP  arg2=RList_FromMaps(*real_inputs);
142      SEXP  arg3=RList_FromMaps(*real_outputs);
143      SEXP r_call;
144      init_zoo(arg1,arg3);
145      PROTECT(r_call = lang4(install(s->name), arg1,arg2,arg3));
146      int errorOccurred;
147     
148      SEXP ret = R_tryEval(r_call, R_GlobalEnv, &errorOccurred);
149      if (!errorOccurred) {
150        int *val = INTEGER(ret);
151        for (int i = 0; i < LENGTH(ret); i++)
152          if(i==0){
153              result=val[i];
154              SEXP zooEnv = findVar(install("zoo"), R_GlobalEnv);
155              if(zooEnv!=NULL){
156                SEXP names = Rf_getAttrib(zooEnv, R_NamesSymbol);
157                int nbKeys=nrows(names);
158                int i;
159                for(i=0;i<nbKeys;i++){
160                  if(i==2){
161                    freeMaps(main_conf);
162                    free(*main_conf);
163                    SEXP confList=VECTOR_ELT(zooEnv,i);
164                    *main_conf=mapsFromRList(confList);
165                  }
166                  if(i==3){
167                    freeMaps(real_outputs);
168                    free(*real_outputs);
169                    SEXP outList=VECTOR_ELT(zooEnv,i);
170                    *real_outputs=mapsFromRList(outList);
171                  }
172                }
173              }
174              return result;
175            }
176      }else{
177        const char* tmpStr=R_curErrorBuf();
178        setMapInMaps(*main_conf,"lenv","message",tmpStr);
179        char* finalStr=(char*)malloc((strlen(tmpStr)+strlen(_("Unable to run your R service: "))+2)*sizeof(char));
180        sprintf(finalStr,"%s %s",_("Unable to run your R service: "),tmpStr);
181        errorException(*main_conf,finalStr,"NoApplicableCode",NULL);
182        free(finalStr);
183        result=-1;
184      }
185    }
186  }
187  Rf_endEmbeddedR(0);
188  return result;
189}
190
191char** listMapsKeys(maps* m){
192  char** res=NULL;
193  maps* tmp=m;
194  int i=0;
195  while(tmp!=NULL){
196    if(i==0)
197      res=(char**)malloc(2*sizeof(char*));
198    else
199      res=(char**)realloc(res,(i+2)*sizeof(char*));
200    res[i]=zStrdup(tmp->name);
201    res[i+1]="";
202    i++;
203    tmp=tmp->next;
204  }
205  return res;
206}
207
208char** listMapKeys(map* m){
209  char** res=NULL;
210  map* tmp=m;
211  int i=0;
212  while(tmp!=NULL){
213    if(i==0)
214      res=(char**)malloc(2*sizeof(char*));
215    else
216      res=(char**)realloc(res,(i+2)*sizeof(char*));
217    res[i]=zStrdup(tmp->name);
218    res[i+1]="";
219    i++;
220    tmp=tmp->next;
221  }
222  return res;
223}
224
225/**
226 * Convert a maps to a R List
227 *
228 * @param t the maps to convert
229 * @return a new SEXP containing the converted maps
230 * @see RList_FromMap
231 * @warning make sure to free resources returned by this function
232 */
233SEXP RList_FromMaps(maps* t){
234  maps* tmp=t;
235  char** keys=listMapsKeys(t);
236  SEXP res = PROTECT(mkNamed(VECSXP,(const char**) keys));
237  free(keys);
238  int cnt=0;
239  while(tmp!=NULL){
240    SEXP input = RList_FromMap(tmp->content);
241    SET_VECTOR_ELT(res,cnt,input);
242    cnt++;
243    tmp=tmp->next;
244  } 
245  UNPROTECT(1);
246  return res;
247}
248
249/**
250 * Convert a map to a R List
251 *
252 * @param t the map to convert
253 * @return a new SEXP containing the converted maps
254 * @warning make sure to free resources returned by this function
255 */
256SEXP RList_FromMap(map* t){
257  map* tmp=t;
258  int hasSize=0;
259  char** keys=listMapKeys(t);
260  SEXP res = PROTECT(mkNamed(VECSXP, (const char**)keys));
261  free(keys);
262  int cnt=0;
263  while(tmp!=NULL){
264    SEXP value=mkString(tmp->value);
265    SET_VECTOR_ELT(res,cnt,value);
266    cnt++;
267    tmp=tmp->next;
268  }
269  UNPROTECT(1);
270  return res;
271}
272
273/**
274 * Convert a R List to a maps
275 *
276 * @param t the PyDictObject to convert
277 * @return a new maps containing the converted PyDictObject
278 * @warning make sure to free resources returned by this function
279 */
280maps* mapsFromRList(SEXP t){
281  maps* res=NULL;
282  maps* cursor=NULL;
283  SEXP names = Rf_getAttrib(t, R_NamesSymbol);
284  int nbKeys=nrows(names);
285  int i;
286  for(i=0;i<nbKeys;i++){
287    SEXP key=STRING_ELT(names,i);
288    SEXP value=VECTOR_ELT(t,i);
289    cursor=createMaps(R_CHAR(key));
290    cursor->content=mapFromRList(value);
291    cursor->next=NULL;
292    if(res==NULL)
293      res=dupMaps(&cursor);
294    else
295      addMapsToMaps(&res,cursor);
296    freeMap(&cursor->content);
297    free(cursor->content);
298    free(cursor);
299  }
300  return res;
301}
302
303/**
304 * Convert a R List to a map
305 *
306 * @param t the PyDictObject to convert
307 * @return a new map containing the converted PyDictObject
308 * @warning make sure to free resources returned by this function
309 */
310map* mapFromRList(SEXP t){
311  map* res=NULL;
312  SEXP names = Rf_getAttrib(t, R_NamesSymbol);
313  int nbKeys=nrows(names);
314  int i;
315  for(i=0;i<nbKeys;i++){
316    SEXP key=STRING_ELT(names,i);
317    SEXP value=VECTOR_ELT(t,i);
318    if(strncmp(R_CHAR(key),"child",5)!=0){
319      {
320        const char* lkey=R_CHAR(key);
321        const char* lvalue=CHAR(STRING_ELT(value,0));
322        if(res!=NULL){
323          addToMap(res,lkey,lvalue);
324        }
325        else{
326          res=createMap(lkey,lvalue);
327        }
328      }
329    }
330  }
331  return res;
332}
333
334/**
335 * Use the ZOO-Services messages translation function from the R
336 * environment
337 *
338 * @param str the R string passed from the R environment
339 * @return a new R string containing the translated value
340 * @see _ss
341 */
342SEXP
343RTranslate(SEXP str)
344{
345  if (!isString(str) || !TYPEOF(STRING_ELT( str, 0 )) == CHARSXP){
346#ifdef DEBUG
347    fprintf(stderr,"Incorrect arguments to update status function");
348#endif
349    return R_NilValue;
350  }
351  const char* tmpStr=CHAR(STRING_ELT(str,0));
352  return mkString(_ss(tmpStr));
353}
354
355/**
356 * Update the ongoing status of a running service from the R environment
357 *
358 * @param confdict the R arguments passed from the R environment
359 * @param status the R arguments passed from the R environment
360 * @return Nil to the Python environment
361 * @see _updateStatus
362 */
363SEXP
364RUpdateStatus(SEXP confdict,SEXP status)
365{
366  maps* conf;
367  int istatus;
368  char* cstatus=NULL;
369  if (!isInteger(status) && !isReal(status)){
370#ifdef DEBUG
371    fprintf(stderr,"Incorrect arguments to update status function");
372#endif
373    return R_NilValue;
374  }
375  if(isInteger(status))
376    istatus=asInteger(status);
377  else
378    istatus=asReal(status);
379  if (istatus < 0 || istatus > 100){
380    return R_NilValue;
381  }
382  // create a local copy and update the lenv map
383  conf = mapsFromRList(confdict);
384  if(status!=NULL){
385    maps* tmpMaps=getMaps(conf,"lenv");
386    addIntToMap(tmpMaps->content,"status",istatus);
387  }
388  else
389    setMapInMaps(conf,"lenv","status","15");
390  _updateStatus(conf);
391  freeMaps(&conf);
392  free(conf);
393  return R_NilValue;
394}
Note: See TracBrowser for help on using the repository browser.

Search

Context Navigation

ZOO Sponsors

http://www.zoo-project.org/trac/chrome/site/img/geolabs-logo.pnghttp://www.zoo-project.org/trac/chrome/site/img/neogeo-logo.png http://www.zoo-project.org/trac/chrome/site/img/apptech-logo.png http://www.zoo-project.org/trac/chrome/site/img/3liz-logo.png http://www.zoo-project.org/trac/chrome/site/img/gateway-logo.png

Become a sponsor !

Knowledge partners

http://www.zoo-project.org/trac/chrome/site/img/ocu-logo.png http://www.zoo-project.org/trac/chrome/site/img/gucas-logo.png http://www.zoo-project.org/trac/chrome/site/img/polimi-logo.png http://www.zoo-project.org/trac/chrome/site/img/fem-logo.png http://www.zoo-project.org/trac/chrome/site/img/supsi-logo.png http://www.zoo-project.org/trac/chrome/site/img/cumtb-logo.png

Become a knowledge partner

Related links

http://zoo-project.org/img/ogclogo.png http://zoo-project.org/img/osgeologo.png