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