source: trunk/zoo-project/zoo-kernel/service_internal_r.c

Last change on this file was 917, checked in by djay, 2 years ago

Merge prototype-v0 branch in trunk

  • 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