sdk/R/R/autoGenAPI.R

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