[873] | 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 | |
---|
| 27 | void 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 | |
---|
| 36 | void 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 | */ |
---|
| 84 | int 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 *mps=zStrdup(mp->value); |
---|
| 113 | int i,len=strlen(mps); |
---|
| 114 | int j=0; |
---|
| 115 | for(i=0;i<len;i++){ |
---|
| 116 | if(mps[i]=='/'){ |
---|
| 117 | mps[i]='.'; |
---|
| 118 | } |
---|
| 119 | } |
---|
| 120 | char *mn=(char*)malloc((strlen(mps)+strlen(tmp->value)+2)*sizeof(char)); |
---|
| 121 | sprintf(mn,"%s.%s",mps,tmp->value); |
---|
| 122 | pName = mkString(mn); |
---|
| 123 | free(mn); |
---|
| 124 | free(mps); |
---|
| 125 | } |
---|
| 126 | else{ |
---|
| 127 | dumpMap(tmp); |
---|
| 128 | char *tmpStr=(char*)malloc((strlen(r_path)+strlen(tmp->value)+2)*sizeof(char)); |
---|
| 129 | sprintf(tmpStr,"%s/%s",r_path,tmp->value); |
---|
| 130 | pName = mkString(tmpStr); |
---|
| 131 | free(tmpStr); |
---|
| 132 | } |
---|
| 133 | } |
---|
| 134 | else{ |
---|
| 135 | errorException (m, "Unable to parse serviceProvider please check your zcfg file.", "NoApplicableCode", NULL); |
---|
| 136 | return -1; |
---|
| 137 | } |
---|
| 138 | SEXP e; |
---|
| 139 | int errorOccurred; |
---|
| 140 | PROTECT(e = lang2(install("source"), pName)); |
---|
| 141 | R_tryEval(e, R_GlobalEnv, &errorOccurred); |
---|
| 142 | UNPROTECT(1); |
---|
| 143 | if (errorOccurred){ |
---|
| 144 | setMapInMaps(*main_conf,"lenv","message",_("Unable to load your R file")); |
---|
| 145 | return SERVICE_FAILED; |
---|
| 146 | }else{ |
---|
| 147 | result=SERVICE_FAILED; |
---|
| 148 | { |
---|
| 149 | SEXP pValue; |
---|
| 150 | SEXP arg1=RList_FromMaps(m); |
---|
| 151 | SEXP arg2=RList_FromMaps(*real_inputs); |
---|
| 152 | SEXP arg3=RList_FromMaps(*real_outputs); |
---|
| 153 | SEXP r_call; |
---|
| 154 | init_zoo(arg1,arg3); |
---|
| 155 | PROTECT(r_call = lang4(install(s->name), arg1,arg2,arg3)); |
---|
| 156 | int errorOccurred; |
---|
| 157 | |
---|
| 158 | SEXP ret = R_tryEval(r_call, R_GlobalEnv, &errorOccurred); |
---|
| 159 | if (!errorOccurred) { |
---|
| 160 | int *val = INTEGER(ret); |
---|
| 161 | for (int i = 0; i < LENGTH(ret); i++) |
---|
| 162 | if(i==0){ |
---|
| 163 | result=val[i]; |
---|
| 164 | SEXP zooEnv = findVar(install("zoo"), R_GlobalEnv); |
---|
| 165 | if(zooEnv!=NULL){ |
---|
| 166 | SEXP names = Rf_getAttrib(zooEnv, R_NamesSymbol); |
---|
| 167 | int nbKeys=nrows(names); |
---|
| 168 | int i; |
---|
| 169 | for(i=0;i<nbKeys;i++){ |
---|
| 170 | if(i==2){ |
---|
| 171 | freeMaps(main_conf); |
---|
| 172 | free(*main_conf); |
---|
| 173 | SEXP confList=VECTOR_ELT(zooEnv,i); |
---|
| 174 | *main_conf=mapsFromRList(confList); |
---|
| 175 | } |
---|
| 176 | if(i==3){ |
---|
| 177 | freeMaps(real_outputs); |
---|
| 178 | free(*real_outputs); |
---|
| 179 | SEXP outList=VECTOR_ELT(zooEnv,i); |
---|
| 180 | *real_outputs=mapsFromRList(outList); |
---|
| 181 | } |
---|
| 182 | } |
---|
| 183 | } |
---|
| 184 | return result; |
---|
| 185 | } |
---|
| 186 | }else{ |
---|
| 187 | const char* tmpStr=R_curErrorBuf(); |
---|
| 188 | setMapInMaps(*main_conf,"lenv","message",tmpStr); |
---|
| 189 | char* finalStr=(char*)malloc((strlen(tmpStr)+strlen(_("Unable to run your R service: "))+2)*sizeof(char)); |
---|
| 190 | sprintf(finalStr,"%s %s",_("Unable to run your R service: "),tmpStr); |
---|
| 191 | fprintf(stderr,"%s %d %s \n",__FILE__,__LINE__,tmpStr); |
---|
| 192 | fflush(stderr); |
---|
| 193 | errorException(*main_conf,finalStr,"NoApplicableCode",NULL); |
---|
| 194 | free(finalStr); |
---|
| 195 | result=-1; |
---|
| 196 | } |
---|
| 197 | } |
---|
| 198 | } |
---|
| 199 | Rf_endEmbeddedR(0); |
---|
| 200 | return result; |
---|
| 201 | } |
---|
| 202 | |
---|
| 203 | char** listMapsKeys(maps* m){ |
---|
| 204 | char** res=NULL; |
---|
| 205 | maps* tmp=m; |
---|
| 206 | int i=0; |
---|
| 207 | while(tmp!=NULL){ |
---|
| 208 | if(i==0) |
---|
| 209 | res=(char**)malloc(2*sizeof(char*)); |
---|
| 210 | else |
---|
| 211 | res=(char**)realloc(res,(i+2)*sizeof(char*)); |
---|
| 212 | res[i]=zStrdup(tmp->name); |
---|
| 213 | res[i+1]=""; |
---|
| 214 | i++; |
---|
| 215 | tmp=tmp->next; |
---|
| 216 | } |
---|
| 217 | return res; |
---|
| 218 | } |
---|
| 219 | |
---|
| 220 | char** listMapKeys(map* m){ |
---|
| 221 | char** res=NULL; |
---|
| 222 | map* tmp=m; |
---|
| 223 | int i=0; |
---|
| 224 | while(tmp!=NULL){ |
---|
| 225 | if(i==0) |
---|
| 226 | res=(char**)malloc(2*sizeof(char*)); |
---|
| 227 | else |
---|
| 228 | res=(char**)realloc(res,(i+2)*sizeof(char*)); |
---|
| 229 | res[i]=zStrdup(tmp->name); |
---|
| 230 | res[i+1]=""; |
---|
| 231 | i++; |
---|
| 232 | tmp=tmp->next; |
---|
| 233 | } |
---|
| 234 | return res; |
---|
| 235 | } |
---|
| 236 | |
---|
| 237 | /** |
---|
| 238 | * Convert a maps to a R List |
---|
| 239 | * |
---|
| 240 | * @param t the maps to convert |
---|
| 241 | * @return a new SEXP containing the converted maps |
---|
| 242 | * @see RList_FromMap |
---|
| 243 | * @warning make sure to free resources returned by this function |
---|
| 244 | */ |
---|
| 245 | SEXP RList_FromMaps(maps* t){ |
---|
| 246 | maps* tmp=t; |
---|
| 247 | char** keys=listMapsKeys(t); |
---|
| 248 | SEXP res = PROTECT(mkNamed(VECSXP,(const char**) keys)); |
---|
| 249 | free(keys); |
---|
| 250 | int cnt=0; |
---|
| 251 | while(tmp!=NULL){ |
---|
| 252 | SEXP input = RList_FromMap(tmp->content); |
---|
| 253 | SET_VECTOR_ELT(res,cnt,input); |
---|
| 254 | cnt++; |
---|
| 255 | tmp=tmp->next; |
---|
| 256 | } |
---|
| 257 | UNPROTECT(1); |
---|
| 258 | return res; |
---|
| 259 | } |
---|
| 260 | |
---|
| 261 | /** |
---|
| 262 | * Convert a map to a R List |
---|
| 263 | * |
---|
| 264 | * @param t the map to convert |
---|
| 265 | * @return a new SEXP containing the converted maps |
---|
| 266 | * @warning make sure to free resources returned by this function |
---|
| 267 | */ |
---|
| 268 | SEXP RList_FromMap(map* t){ |
---|
| 269 | map* tmp=t; |
---|
| 270 | int hasSize=0; |
---|
| 271 | char** keys=listMapKeys(t); |
---|
| 272 | SEXP res = PROTECT(mkNamed(VECSXP, (const char**)keys)); |
---|
| 273 | free(keys); |
---|
| 274 | int cnt=0; |
---|
| 275 | while(tmp!=NULL){ |
---|
| 276 | SEXP value=mkString(tmp->value); |
---|
| 277 | SET_VECTOR_ELT(res,cnt,value); |
---|
| 278 | cnt++; |
---|
| 279 | tmp=tmp->next; |
---|
| 280 | } |
---|
| 281 | UNPROTECT(1); |
---|
| 282 | return res; |
---|
| 283 | } |
---|
| 284 | |
---|
| 285 | /** |
---|
| 286 | * Convert a R List to a maps |
---|
| 287 | * |
---|
| 288 | * @param t the PyDictObject to convert |
---|
| 289 | * @return a new maps containing the converted PyDictObject |
---|
| 290 | * @warning make sure to free resources returned by this function |
---|
| 291 | */ |
---|
| 292 | maps* mapsFromRList(SEXP t){ |
---|
| 293 | maps* res=NULL; |
---|
| 294 | maps* cursor=NULL; |
---|
| 295 | SEXP names = Rf_getAttrib(t, R_NamesSymbol); |
---|
| 296 | int nbKeys=nrows(names); |
---|
| 297 | int i; |
---|
| 298 | for(i=0;i<nbKeys;i++){ |
---|
| 299 | SEXP key=STRING_ELT(names,i); |
---|
| 300 | SEXP value=VECTOR_ELT(t,i); |
---|
| 301 | cursor=createMaps(R_CHAR(key)); |
---|
| 302 | cursor->content=mapFromRList(value); |
---|
| 303 | cursor->next=NULL; |
---|
| 304 | if(res==NULL) |
---|
| 305 | res=dupMaps(&cursor); |
---|
| 306 | else |
---|
| 307 | addMapsToMaps(&res,cursor); |
---|
| 308 | freeMap(&cursor->content); |
---|
| 309 | free(cursor->content); |
---|
| 310 | free(cursor); |
---|
| 311 | } |
---|
| 312 | return res; |
---|
| 313 | } |
---|
| 314 | |
---|
| 315 | /** |
---|
| 316 | * Convert a R List to a map |
---|
| 317 | * |
---|
| 318 | * @param t the PyDictObject to convert |
---|
| 319 | * @return a new map containing the converted PyDictObject |
---|
| 320 | * @warning make sure to free resources returned by this function |
---|
| 321 | */ |
---|
| 322 | map* mapFromRList(SEXP t){ |
---|
| 323 | map* res=NULL; |
---|
| 324 | SEXP names = Rf_getAttrib(t, R_NamesSymbol); |
---|
| 325 | int nbKeys=nrows(names); |
---|
| 326 | int i; |
---|
| 327 | for(i=0;i<nbKeys;i++){ |
---|
| 328 | SEXP key=STRING_ELT(names,i); |
---|
| 329 | SEXP value=VECTOR_ELT(t,i); |
---|
| 330 | if(strncmp(R_CHAR(key),"child",5)!=0){ |
---|
| 331 | { |
---|
| 332 | const char* lkey=R_CHAR(key); |
---|
| 333 | const char* lvalue=CHAR(STRING_ELT(value,0)); |
---|
| 334 | if(res!=NULL){ |
---|
| 335 | addToMap(res,lkey,lvalue); |
---|
| 336 | } |
---|
| 337 | else{ |
---|
| 338 | res=createMap(lkey,lvalue); |
---|
| 339 | } |
---|
| 340 | } |
---|
| 341 | } |
---|
| 342 | } |
---|
| 343 | return res; |
---|
| 344 | } |
---|
| 345 | |
---|
| 346 | /** |
---|
| 347 | * Use the ZOO-Services messages translation function from the R |
---|
| 348 | * environment |
---|
| 349 | * |
---|
| 350 | * @param str the R string passed from the R environment |
---|
| 351 | * @return a new R string containing the translated value |
---|
| 352 | * @see _ss |
---|
| 353 | */ |
---|
| 354 | SEXP |
---|
| 355 | RTranslate(SEXP str) |
---|
| 356 | { |
---|
| 357 | if (!isString(str) || !TYPEOF(STRING_ELT( str, 0 )) == CHARSXP){ |
---|
| 358 | #ifdef DEBUG |
---|
| 359 | fprintf(stderr,"Incorrect arguments to update status function"); |
---|
| 360 | #endif |
---|
| 361 | return R_NilValue; |
---|
| 362 | } |
---|
| 363 | const char* tmpStr=CHAR(STRING_ELT(str,0)); |
---|
| 364 | return mkString(_ss(tmpStr)); |
---|
| 365 | } |
---|
| 366 | |
---|
| 367 | /** |
---|
| 368 | * Update the ongoing status of a running service from the R environment |
---|
| 369 | * |
---|
| 370 | * @param confdict the R arguments passed from the R environment |
---|
| 371 | * @param status the R arguments passed from the R environment |
---|
| 372 | * @return Nil to the Python environment |
---|
| 373 | * @see _updateStatus |
---|
| 374 | */ |
---|
| 375 | SEXP |
---|
| 376 | RUpdateStatus(SEXP confdict,SEXP status) |
---|
| 377 | { |
---|
| 378 | maps* conf; |
---|
| 379 | int istatus; |
---|
| 380 | char* cstatus=NULL; |
---|
[877] | 381 | if (!isInteger(status) && !isReal(status)){ |
---|
[873] | 382 | #ifdef DEBUG |
---|
| 383 | fprintf(stderr,"Incorrect arguments to update status function"); |
---|
| 384 | #endif |
---|
| 385 | return R_NilValue; |
---|
| 386 | } |
---|
[877] | 387 | if(isInteger(status)) |
---|
| 388 | istatus=asInteger(status); |
---|
| 389 | else |
---|
| 390 | istatus=asReal(status); |
---|
[873] | 391 | if (istatus < 0 || istatus > 100){ |
---|
| 392 | return R_NilValue; |
---|
| 393 | } |
---|
| 394 | // create a local copy and update the lenv map |
---|
| 395 | conf = mapsFromRList(confdict); |
---|
| 396 | if(status!=NULL){ |
---|
| 397 | maps* tmpMaps=getMaps(conf,"lenv"); |
---|
| 398 | addIntToMap(tmpMaps->content,"status",istatus); |
---|
| 399 | } |
---|
| 400 | else |
---|
| 401 | setMapInMaps(conf,"lenv","status","15"); |
---|
| 402 | _updateStatus(conf); |
---|
| 403 | freeMaps(&conf); |
---|
| 404 | free(conf); |
---|
| 405 | return R_NilValue; |
---|
| 406 | } |
---|