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