sdk/R/R/autoGenAPI.R

   1 getAPIDocument <- function(){
   2     url <- "https://4xphq.arvadosapi.com/discovery/v1/apis/arvados/v1/rest"
   3     serverResponse <- httr::RETRY("GET", url = url)
   4
   5     httr::content(serverResponse, as = "parsed", type = "application/json")
   6 }
   7
   8 #' @export
   9 generateAPI <- function()
  10 {
  11     #TODO: Consider passing discovery document URL as parameter.
  12     #TODO: Consider passing location where to create new files.
  13     JSONDocument <- getAPIDocument()
  14
  15     generateArvadosClasses(JSONDocument)
  16     generateArvadosAPIClass(JSONDocument)
  17 }
  18
  19 #NOTE: Arvados class generation:
  20
  21 generateArvadosAPIClass <- function(discoveryDocument)
  22 {
  23     classMetaData   <- discoveryDocument$schemas
  24     methodResources <- discoveryDocument$resources
  25     resourceNames   <- names(methodResources)
  26
  27     doc <- generateMethodsDocumentation(methodResources, resourceNames)
  28     arvadosAPIHeader <- generateAPIClassHeader()
  29     arvadosClassMethods <- generateClassContent(methodResources,
  30                                                 resourceNames, classMetaData)
  31     arvadosAPIFooter <- generateAPIClassFooter()
  32
  33     arvadosClass <- c(doc,
  34                       arvadosAPIHeader,
  35                       arvadosClassMethods,
  36                       arvadosAPIFooter)
  37
  38     #TODO: Save to a file or load in memory?
  39     fileConn <- file("./R/Arvados.R", "w")
  40     writeLines(unlist(arvadosClass), fileConn)
  41     close(fileConn)
  42     NULL
  43 }
  44
  45 generateAPIClassHeader <- function()
  46 {
  47     c("#' @export",
  48       "Arvados <- R6::R6Class(",
  49       "",
  50       "\t\"Arvados\",",
  51       "",
  52       "\tpublic = list(",
  53       "",
  54       "\t\tinitialize = function(authToken = NULL, hostName = NULL, numRetries = 0)",
  55       "\t\t{",
  56       "\t\t\tif(!is.null(hostName))",
  57       "\t\t\t\tSys.setenv(ARVADOS_API_HOST = hostName)",
  58       "",
  59       "\t\t\tif(!is.null(authToken))",
  60       "\t\t\t\tSys.setenv(ARVADOS_API_TOKEN = authToken)",
  61       "",
  62       "\t\t\thostName <- Sys.getenv(\"ARVADOS_API_HOST\")",
  63       "\t\t\ttoken    <- Sys.getenv(\"ARVADOS_API_TOKEN\")",
  64       "",
  65       "\t\t\tif(hostName == \"\" | token == \"\")",
  66       "\t\t\t\tstop(paste(\"Please provide host name and authentification token\",",
  67       "\t\t\t\t\t\t   \"or set ARVADOS_API_HOST and ARVADOS_API_TOKEN\",",
  68       "\t\t\t\t\t\t   \"environment variables.\"))",
  69       "",
  70       "\t\t\tprivate$token <- token",
  71       "\t\t\tprivate$host  <- paste0(\"https://\", hostName, \"/arvados/v1/\")",
  72       "\t\t\tprivate$numRetries <- numRetries",
  73       "\t\t\tprivate$REST <- RESTService$new(token, hostName,",
  74       "\t\t\t                                HttpRequest$new(), HttpParser$new(),",
  75       "\t\t\t                                numRetries)",
  76       "",
  77       "\t\t},\n")
  78 }
  79
  80 generateClassContent <- function(methodResources, resourceNames, classMetaData)
  81 {
  82     arvadosMethods <- Map(function(resource, resourceName)
  83     {
  84         methodNames <- names(resource$methods)
  85
  86         functions <- Map(function(methodMetaData, methodName)
  87         {
  88             methodName <- paste0(resourceName, ".", methodName)
  89             createMethod(methodName, methodMetaData, classMetaData)
  90
  91         }, resource$methods, methodNames)
  92
  93         unlist(unname(functions))
  94
  95     }, methodResources, resourceNames)
  96
  97     arvadosMethods
  98 }
  99
 100 generateAPIClassFooter <- function()
 101 {
 102     c("\t\tgetHostName = function() private$host,",
 103       "\t\tgetToken = function() private$token,",
 104       "\t\tsetRESTService = function(newREST) private$REST <- newREST",
 105       "\t),",
 106       "",
 107       "\tprivate = list(",
 108       "",
 109       "\t\ttoken = NULL,",
 110       "\t\thost = NULL,",
 111       "\t\tREST = NULL,",
 112       "\t\tnumRetries = NULL",
 113       "\t),",
 114       "",
 115       "\tcloneable = FALSE",
 116       ")")
 117 }
 118
 119 createMethod <- function(name, methodMetaData, classMetaData)
 120 {
 121     args      <- getMethodArguments(methodMetaData)
 122     signature <- getMethodSignature(name, args)
 123     body      <- getMethodBody(methodMetaData, classMetaData)
 124
 125     c(signature,
 126       "\t\t{",
 127           body,
 128       "\t\t},\n")
 129 }
 130
 131 #TODO: Make sure that arguments that are required always go first.
 132 #      This is not the case if request$required is false.
 133 getMethodArguments <- function(methodMetaData)
 134 {
 135     request <- methodMetaData$request
 136     requestArgs <- NULL
 137
 138     if(!is.null(request))
 139     {
 140         if(request$required)
 141             requestArgs <- names(request$properties)
 142         else
 143             requestArgs <- paste(names(request$properties), "=", "NULL")
 144     }
 145
 146     argNames <- names(methodMetaData$parameters)
 147
 148     args <- sapply(argNames, function(argName)
 149     {
 150         arg <- methodMetaData$parameters[[argName]]
 151
 152         if(!arg$required)
 153         {
 154             if(!is.null(arg$default))
 155                 return(paste0(argName, " = ", "\"", arg$default, "\""))
 156             else
 157                 return(paste(argName, "=", "NULL"))
 158         }
 159
 160         argName
 161     })
 162
 163     c(requestArgs, args)
 164 }
 165
 166 getMethodSignature <- function(methodName, args)
 167 {
 168     collapsedArgs <- paste0(args, collapse = ", ")
 169     lineLengthLimit <- 40
 170
 171     if(nchar(collapsedArgs) > lineLengthLimit)
 172     {
 173         return(paste0("\t\t",
 174                       formatArgs(paste(methodName, "= function("),
 175                                  "\t", args, ")", lineLengthLimit)))
 176     }
 177     else
 178     {
 179         return(paste0("\t\t", methodName, " = function(", collapsedArgs, ")"))
 180     }
 181 }
 182
 183 getMethodBody <- function(methodMetaData, classMetaData)
 184 {
 185     url              <- getRequestURL(methodMetaData)
 186     headers          <- getRequestHeaders()
 187     requestQueryList <- getRequestQueryList(methodMetaData)
 188     requestBody      <- getRequestBody(methodMetaData)
 189     request          <- getRequest(methodMetaData)
 190     response         <- getResponse(methodMetaData)
 191     errorCheck       <- getErrorCheckingCode()
 192     returnObject     <- getReturnObject(methodMetaData, classMetaData)
 193     returnStatement  <- getReturnObjectValidationCode()
 194
 195     body <- c(url,
 196               headers,
 197               requestQueryList,
 198               requestBody, "",
 199               request, response, "",
 200               errorCheck, "",
 201               returnObject, "",
 202               returnStatement)
 203
 204     paste0("\t\t\t", body)
 205 }
 206
 207 getRequestURL <- function(methodMetaData)
 208 {
 209     endPoint <- methodMetaData$path
 210     endPoint <- stringr::str_replace_all(endPoint, "\\{", "${")
 211     url <- c(paste0("endPoint <- stringr::str_interp(\"", endPoint, "\")"),
 212              paste0("url <- paste0(private$host, endPoint)"))
 213     url
 214 }
 215
 216 getRequestHeaders <- function()
 217 {
 218     c("headers <- list(Authorization = paste(\"OAuth2\", private$token), ",
 219       "                \"Content-Type\" = \"application/json\")")
 220 }
 221
 222 getRequestQueryList <- function(methodMetaData)
 223 {
 224     args <- names(methodMetaData$parameters)
 225
 226     if(length(args) == 0)
 227         return("queryArgs <- NULL")
 228
 229     args <- sapply(args, function(arg) paste0(arg, " = ", arg))
 230     collapsedArgs <- paste0(args, collapse = ", ")
 231
 232     if(nchar(collapsedArgs) > 40)
 233         return(formatArgs("queryArgs <- list(", "\t", args, ")", 40))
 234     else
 235         return(paste0("queryArgs <- list(", collapsedArgs, ")"))
 236 }
 237
 238 getRequestBody <- function(methodMetaData)
 239 {
 240     request <- methodMetaData$request
 241
 242     if(is.null(request) || !request$required)
 243         return("body <- NULL")
 244
 245     requestParameterName <- names(request$properties)[1]
 246     paste0("body <- ", requestParameterName, "$toJSON()")
 247 }
 248
 249 getRequest <- function(methodMetaData)
 250 {
 251     method <- methodMetaData$httpMethod
 252     c(paste0("response <- private$REST$http$exec(\"", method, "\", url, headers, body,"),
 253       "                                   queryArgs, private$numRetries)")
 254 }
 255
 256 getResponse <- function(methodMetaData)
 257 {
 258     "resource <- private$REST$httpParser$parseJSONResponse(response)"
 259 }
 260
 261 getErrorCheckingCode <- function()
 262 {
 263     c("if(!is.null(resource$errors))",
 264       "\tstop(resource$errors)")
 265 }
 266
 267 getReturnObject <- function(methodMetaData, classMetaData)
 268 {
 269     returnClass <- methodMetaData$response[["$ref"]]
 270     classArguments <- getReturnClassArguments(returnClass, classMetaData)
 271
 272     if(returnClass == "Collection")
 273         return(c(formatArgs("result <- Collection$new(", "\t",
 274                             classArguments, ")", 40),
 275                  "",
 276                  "result$setRESTService(private$REST)"))
 277
 278     formatArgs(paste0("result <- ", returnClass, "$new("),
 279                "\t", classArguments, ")", 40)
 280 }
 281
 282 getReturnObjectValidationCode <- function()
 283 {
 284     c("if(result$isEmpty())",
 285       "\tresource",
 286       "else",
 287       "\tresult")
 288 }
 289
 290 getReturnClassArguments <- function(className, classMetaData)
 291 {
 292     classArguments <- unique(names(classMetaData[[className]]$properties))
 293
 294     arguments <- sapply(classArguments, function(arg)
 295     {
 296         paste0(arg, " = resource$", arg)
 297     })
 298
 299     arguments
 300 }
 301
 302
 303 #NOTE: Arvados class documentation:
 304
 305 generateMethodsDocumentation <- function(methodResources, resourceNames)
 306 {
 307     methodsDoc <- unlist(unname(Map(function(resource, resourceName)
 308     {
 309         methodNames <- names(resource$methods)
 310
 311         methodDoc <- Map(function(methodMetaData, methodName)
 312         {
 313             methodName <- paste0(resourceName, ".", methodName)
 314             getMethodDocumentation(methodName, methodMetaData)
 315
 316         }, resource$methods, methodNames)
 317
 318         unlist(unname(methodDoc))
 319
 320     }, methodResources, resourceNames)))
 321
 322     methodsDoc
 323 }
 324
 325 getMethodDocumentation <- function(methodName, methodMetaData)
 326 {
 327     name        <- paste("#' @name", methodName)
 328     usage       <- getMethodUsage(methodName, methodMetaData)
 329     description <- paste("#'", methodName, "is a method defined in Arvados class.")
 330     params      <- getMethodDescription(methodMetaData)
 331     returnValue <- paste("#' @return", methodMetaData$response[["$ref"]], "object.")
 332
 333     c(description,
 334       "#' ",
 335       usage,
 336       params,
 337       returnValue,
 338       name,
 339       "NULL",
 340       "")
 341 }
 342
 343 getMethodUsage <- function(methodName, methodMetaData)
 344 {
 345     lineLengthLimit <- 40
 346     args <- getMethodArguments(methodMetaData)
 347     c(formatArgs(paste0("#' @usage arv$", methodName,
 348                         "("), "#' \t", args, ")", lineLengthLimit))
 349 }
 350
 351 getMethodDescription <- function(methodMetaData)
 352 {
 353     request <- methodMetaData$request
 354     requestDoc <- NULL
 355
 356     if(!is.null(request))
 357     {
 358         requestDoc <- unname(unlist(sapply(request$properties, function(prop)
 359                              {
 360                                  className <- sapply(prop, function(ref) ref)
 361                                  objectName <- paste0(tolower(substr(className, 1, 1)),
 362                                                       substr(className, 2, nchar(className)))
 363                                  paste("#' @param", objectName, className, "object.")
 364                              })))
 365     }
 366
 367     argNames <- names(methodMetaData$parameters)
 368
 369     argsDoc <- unname(unlist(sapply(argNames, function(argName)
 370     {
 371         arg <- methodMetaData$parameters[[argName]]
 372         argDescription <- arg$description
 373         paste("#' @param", argName, argDescription)
 374     })))
 375
 376     c(requestDoc, argsDoc)
 377 }
 378
 379 #NOTE: API Classes generation:
 380
 381 generateArvadosClasses <- function(resources)
 382 {
 383     classes <- sapply(resources$schemas, function(classSchema)
 384     {
 385         #NOTE: Collection is implemented manually.
 386         if(classSchema$id != "Collection")
 387             getArvadosClass(classSchema)
 388
 389     }, USE.NAMES = TRUE)
 390
 391     fileConn <- file("./R/ArvadosClasses.R", "w")
 392     writeLines(unlist(classes), fileConn)
 393     close(fileConn)
 394     NULL
 395 }
 396
 397 getArvadosClass <- function(classSchema)
 398 {
 399     name            <- classSchema$id
 400     fields          <- unique(names(classSchema$properties))
 401     constructorArgs <- paste(fields, "= NULL")
 402     documentation   <- getClassDocumentation(classSchema, constructorArgs)
 403
 404     classString <- c(documentation,
 405               paste0(name, " <- R6::R6Class("),
 406                      "",
 407               paste0("\t\"", name, "\","),
 408                      "",
 409                      "\tpublic = list(",
 410               paste0("\t\t", fields, " = NULL,"),
 411                      "",
 412               paste0("\t\t", formatArgs("initialize = function(", "\t\t",
 413                                         constructorArgs, ")", 40)),
 414                      "\t\t{",
 415               paste0("\t\t\tself$", fields, " <- ", fields),
 416                      "\t\t\t",
 417               paste0("\t\t\t", formatArgs("private$classFields <- c(", "\t",
 418                                          paste0("\"", fields, "\""), ")", 40)),
 419                      "\t\t},",
 420                      "",
 421                      "\t\ttoJSON = function() {",
 422                      "\t\t\tfields <- sapply(private$classFields, function(field)",
 423                      "\t\t\t{",
 424                      "\t\t\t\tself[[field]]",
 425                      "\t\t\t}, USE.NAMES = TRUE)",
 426                      "\t\t\t",
 427               paste0("\t\t\tjsonlite::toJSON(list(\"", tolower(name), "\" =
 428                      Filter(Negate(is.null), fields)), auto_unbox = TRUE)"),
 429                      "\t\t},",
 430                      "",
 431                      "\t\tisEmpty = function() {",
 432                      "\t\t\tfields <- sapply(private$classFields,",
 433                      "\t\t\t                 function(field) self[[field]])",
 434                      "",
 435               paste0("\t\t\tif(any(sapply(fields, function(field) !is.null(field)",
 436                      " && field != \"\")))"),
 437                      "\t\t\t\tFALSE",
 438                      "\t\t\telse",
 439                      "\t\t\t\tTRUE",
 440                      "\t\t}",
 441                      "\t),",
 442                      "",
 443                      "\tprivate = list(",
 444                      "\t\tclassFields = NULL",
 445                      "\t),",
 446                      "",
 447                      "\tcloneable = FALSE",
 448                      ")",
 449                      "")
 450 }
 451
 452 #NOTE: API Classes documentation:
 453
 454 getClassDocumentation <- function(classSchema, constructorArgs)
 455 {
 456     name                     <- classSchema$id
 457     description              <- classSchema$description
 458     nameLowercaseFirstLetter <- paste0(tolower(substr(name, 1, 1)),
 459                                        substr(name, 2, nchar(name)))
 460     c(paste0("#' ", name),
 461              "#' ",
 462       paste0("#' ", description),
 463              "#' ",
 464              "#' @section Usage:",
 465              formatArgs(paste0("#' \\preformatted{",
 466                                nameLowercaseFirstLetter, " -> ", name, "$new("),
 467                         "#' \t", constructorArgs, ")", 50),
 468              "#' }",
 469              "#' ",
 470       paste0("#' @section Arguments:"),
 471              "#'   \\describe{",
 472       paste0("#'     ", getClassArgumentDescription(classSchema)),
 473              "#'   }",
 474              "#' ",
 475       paste0("#' @name ", name),
 476              "NULL",
 477              "",
 478              "#' @export")
 479 }
 480
 481 getClassArgumentDescription <- function(classSchema)
 482 {
 483     argDoc <- sapply(classSchema$properties, function(arg)
 484     {
 485         paste0("{", arg$description, "}")
 486     }, USE.NAMES = TRUE)
 487
 488     paste0("\\item{", names(classSchema$properties), "}", argDoc)
 489 }
 490
 491 #NOTE: Utility functions:
 492
 493 formatArgs <- function(prependAtStart, prependToEachSplit,
 494                        args, appendAtEnd, lineLength)
 495 {
 496     if(length(args) > 1)
 497     {
 498         args[1:(length(args) - 1)] <- paste0(args[1:(length(args) - 1)], ",")
 499     }
 500
 501     args[1] <- paste0(prependAtStart, args[1])
 502     args[length(args)] <- paste0(args[length(args)], appendAtEnd)
 503
 504     argsLength <- length(args)
 505     argLines <- list()
 506     index <- 1
 507
 508     while(index <= argsLength)
 509     {
 510         line <- args[index]
 511         index <- index + 1
 512
 513         while(nchar(line) < lineLength && index <= argsLength)
 514         {
 515             line <- paste(line, args[index])
 516             index <- index + 1
 517         }
 518
 519         argLines <- c(argLines, line)
 520     }
 521
 522     argLines <- unlist(argLines)
 523     argLinesLen <- length(argLines)
 524
 525     if(argLinesLen > 1)
 526         argLines[2:argLinesLen] <- paste0(prependToEachSplit, argLines[2:argLinesLen])
 527
 528     argLines
 529 }