inst/examples/createFunctions.R

In johndharrison/seleniumPipes: R Client Implementing the W3C WebDriver Specification

# utility script to get the w3c specs to create the functions in
# seleniumPipes. Assummed ran from the project base
DOCUMENT <- FALSE
library(xml2)
library(httr)
library(rvest)
library(data.table)
library(rapportools)
library(whisker)
appURL <- "https://w3c.github.io/webdriver/webdriver-spec.html"
doc <- read_html(appURL)
tabXpath <- "//section[h3[text()='List of Endpoints']]//table"
methPaths <- html_table(xml_find_all(doc, tabXpath))[[1]]
setDT(methPaths)
setnames(methPaths, names(methPaths), tocamel(tolower(names(methPaths))))
methPaths[,command := tocamel(tolower(command))]

oldSelMethods <- list(
  data.frame(
    method = "GET",
    uriTemplate = "/session/{session id}/window_handle",
    command = "getWindowHandleOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "GET",
    uriTemplate = "/session/{session id}/window_handles",
    command = "getWindowHandlesOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "GET",
    uriTemplate = "/session/{sessionId}/window/{windowHandle}/size",
    command = "getWindowSizeOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "GET",
    uriTemplate = "/session/{sessionId}/window/{windowHandle}/position",
    command = "getWindowPositionOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{sessionId}/window/{windowHandle}/size",
    command = "setWindowSizeOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{sessionId}/window/{windowHandle}/position",
    command = "setWindowPositionOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{sessionId}/window/{windowHandle}/maximize",
    command = "maximizeWindowOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{session id}/execute",
    command = "executeScriptOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{session id}/execute_async",
    command = "executeAsyncScriptOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "GET",
    uriTemplate = "/session/{session id}/alert_text",
    command = "getAlertTextOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{session id}/alert_text",
    command = "sendAlertTextOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{session id}/alert_accept",
    command = "acceptAlertOld", stringsAsFactors = FALSE
  ),
  data.frame(
    method = "POST",
    uriTemplate = "/session/{session id}/alert_dismiss",
    command = "dismissAlertOld", stringsAsFactors = FALSE
  )
)
methPaths <- rbindlist(list(methPaths, rbindlist(oldSelMethods)))

methPaths[, uriTemplate := gsub("/session/\\{session id)/cookie",
                                "/session/\\{session id\\}/cookie",
                                uriTemplate)]
methPaths[, uriTemplate := gsub("session id", "sessionId", uriTemplate)]
methPaths[, uriTemplate := gsub("element id", "elementId", uriTemplate)]
methPaths[, uriTemplate := gsub("\\{property name\\}",
                                "\\{propertyName\\}",
                                uriTemplate)]
methPaths[, uriTemplate := gsub("\\{", "\\{\\{", uriTemplate)]
methPaths[, uriTemplate := gsub("\\}", "\\}\\}", uriTemplate)]
methPaths[, elemInd := grepl("\\{elementId\\}", uriTemplate)]
methPaths[, Arg := ifelse(elemInd, "webElem", "remDr")]

methGroups <- list(
  sessions = c("newSession", "deleteSession", "status", "setTimeouts",
               "getTimeouts"),
  navigation = c("go", "getCurrentUrl", "back", "forward", "refresh",
                 "getTitle"),
  commandContexts = c("getWindowHandle", "closeWindow", "switchToWindow",
                      "getWindowHandles" , "switchToFrame",
                      "switchToParentFrame", "getWindowSize",
                      "setWindowSize", "getWindowPosition",
                      "setWindowPosition", "maximizeWindow",
                      "fullscreenWindow"),
  elementRetrieval = c("getActiveElement", "findElement", "findElements",
                       "findElementFromElement",
                       "findElementsFromElement"),
  elementState = c("isElementSelected", "getElementAttribute",
                   "getElementProperty", "getElementCssValue",
                   "getElementText", "getElementTagName",
                   "getElementRect", "isElementEnabled"),
  elementInteraction = c("elementClick", "elementClear",
                         "elementSendKeys"),
  documentHandling = c("getPageSource", "executeScript",
                       "executeAsyncScript"),
  cookies = c("getAllCookies", "getNamedCookie", "addCookie",
              "deleteCookie", "deleteAllCookies"),
  interactions = c("performActions", "releasingActions"),
  userPrompts = c("dismissAlert", "acceptAlert", "getAlertText",
                  "sendAlertText"),
  screenCapture = c("takeScreenshot", "takeElementScreenshot"),
  oldMethods = c("getWindowHandleOld", "getWindowHandlesOld",
                 "getWindowPositionOld", "getWindowSizeOld",
                 "setWindowSizeOld", "setWindowPositionOld",
                 "maximizeWindowOld", "executeScriptOld",
                 "executeAsyncScriptOld", "getAlertTextOld",
                 "sendAlertTextOld", "acceptAlertOld", "dismissAlertOld")
)
methGroups <- lapply(names(methGroups), function(x){
  expand.grid(group = x, command = methGroups[[x]],
              stringsAsFactors = FALSE)
}
)
methGroups <- rbindlist(methGroups)
methPaths <- merge(methPaths, methGroups, by = "command")

funcTemp <- list(
remDr = list( roxy = "#' {{command}}
#'
#'{{codecommand}}
#'
#' @template remDr
{{roxyArgs}}
#' @family {{group}} functions
#' @template {{rettype}}
#' @export
#'
#' @example /inst/examples/docs/{{group}}.R
#' @name {{command}}
NULL

",

fbody = "
#' @rdname {{command}}
{{command}} <- function({{Arg}}, {{{addArgs}}}...){
  obj <- {{Arg}}
  obj$sessionId <- {{Arg}}$sessionId({{Arg}}$drvID)
  {{{JSON_command}}}
  pathTemplate <-
    whisker.render(\"{{uriTemplate}}\", data = obj)
  pathURL <- {{Arg}}[['remServAdd']]
  pathURL[['path']] <- paste0(pathURL[['path']], pathTemplate)
  res <- queryDriver(verb = {{method}}, url = build_url(pathURL),
            source = \"{{command}}\",
            drvID = {{Arg}}$drvID, json = {{JSON}},...)
  {{{return}}}
}
"
),

webElem = list(roxy = "#' {{command}}
#'
#'{{codecommand}}
#'
#' @template webElem
{{roxyArgs}}
#' @family {{group}} functions
#' @template {{rettype}}
#' @export
#'
#' @example /inst/examples/docs/{{group}}.R
#' @name {{command}}
NULL

",
fbody = "
#' @rdname {{command}}
{{command}} <- function({{Arg}}, {{{addArgs}}}...){
  obj <- {{Arg}}
  obj$sessionId <- {{Arg}}$sessionId({{Arg}}$remDr$drvID)
  obj$elementId <- {{Arg}}$elementId$ELEMENT
  {{{JSON_command}}}
  pathTemplate <-
    whisker.render(\"{{uriTemplate}}\", data = obj)
  pathURL <- {{Arg}}[['remDr']][['remServAdd']]
  pathURL[['path']] <- paste0(pathURL[['path']], pathTemplate)
  res <- queryDriver(verb = {{method}}, url = build_url(pathURL),
            source = \"{{command}}\", drvID = {{Arg}}$remDr$drvID,
            json = {{JSON}},...)
  {{{return}}}
}


"))

# configure returns
selReturn <- list(
  ret1 = "invisible(remDr)"
  , ret2 = "res$value"
  , ret3 = "read_html(res$value)"
  , ret4 = "invisible(wbElement(res$value, remDr))"
  , ret5 = "invisible(lapply(res$value, wbElement, remDr = remDr))"
  , ret6 = "if(replace){testWebElement(res$value, remDr)}else{res$value}"
  , ret7 = "invisible(webElem)"
  , ret8 = "remDr$sessionInfo <- res$value;invisible(remDr)"
  , ret9 = ".e$sessionId[[remDr$drvID]] <- NULL;invisible(remDr)"
  , ret10 = "invisible(wbElement(res$value, webElem$remDr))"
  , ret11 = "invisible(lapply(res$value, wbElement, remDr = webElem$remDr))"
  , ret12 =
"b64png <- base64_dec(res$value)
if(display){
  tmp <- file.path(tempdir(), 'tmpScreenShot.png')
  writeBin(b64png, tmp)
  viewer <- getOption(\"viewer\")
  if (useViewer){
    viewer(tmp)
  }else{
    utils::browseURL(tmp)
  }
}
if(!is.null(file)){
  writeBin(b64png, file)
}
if(returnPNG){
  b64png
}else{
  invisible(remDr)
}
", ret13 =
  "b64png <- base64_dec(res$value)
if(display){
  tmp <- file.path(tempdir(), 'tmpElementScreenShot.png')
  writeBin(b64png, tmp)
  viewer <- getOption(\"viewer\")
  if (useViewer){
    viewer(tmp)
  }else{
    utils::browseURL(tmp)
  }
}
if(!is.null(file)){
  writeBin(b64png, file)
}
if(returnPNG){
  b64png
}else{
  invisible(webElem)
}
"
)

# list of POST type JSON commands

JCommands <- list(
  newSession = list( com = "
# Add function specific JSON to post
  jsonBody <- toJSON(list(
    desiredCapabilities =c(remDr$desiredCapabilities,
                            remDr$extraCapabilities)
  ), auto_unbox = TRUE)
  ", type = "ret8"),

  deleteSession = list(type = "ret9"),

  go = list(com =  "
# Add function specific JSON to post
  jsonBody <- toJSON(list(
     url = url
  ), auto_unbox = TRUE)
  ", args = list(url = NA)
, type = "ret1"),

  getCurrentUrl = list(type = "ret2"),

  back = list(com =  "
# Add function specific JSON to post
  jsonBody <- NULL
  ", type = "ret1"),


  forward = list(com =  "
# Add function specific JSON to post
  jsonBody <- NULL
  ", type = "ret1"),


  refresh = list(com =  "
# Add function specific JSON to post
  jsonBody <- NULL
  ", type = "ret1"),

  default = list(com = "
# Add function specific JSON to post
  jsonBody <- toJSON(list(

  ), auto_unbox = TRUE)
  ", type = "ret1"),

  getPageSource = list(type = "ret3"),

  getTitle = list(type = "ret2"),

  getWindowHandle = list(type = "ret2"),

  getWindowHandleOld = list(type = "ret2"),

  closeWindow = list(type = "ret1"),

  switchToWindow = list(
    com = "
# Add function specific JSON to post
  jsonBody <- toJSON(list(
    name = name
  ), auto_unbox = TRUE)
    ",
    args = list(name = NA),
    type = "ret1"
  ),

  getWindowHandles = list(type = "ret2"),

  getWindowHandlesOld = list(type = "ret2"),

  getWindowPosition = list(type = "ret2"),

  getWindowPositionOld = list(
    com = "obj$windowHandle <- handle",
    args = list(handle = "\"current\""),
    type = "ret2"
  ),

  getWindowSize = list(type = "ret2"),

  getWindowSizeOld = list(
    com = "obj$windowHandle <- handle",
    args = list(handle = "\"current\""),
    type = "ret2"
  ),

  setWindowSize = list(
    com = "
  jsonBody <- toJSON(list(
    width = width, height = height
  ), auto_unbox = TRUE)",
    args = list(width = NA, height = NA),
    type = "ret1"
  ),

  setWindowSizeOld = list(
    com = "obj$windowHandle <- handle
  jsonBody <- toJSON(list(
    width = width, height = height
  ), auto_unbox = TRUE)",
    args = list(width = NA, height = NA, handle = "\"current\""),
    type = "ret1"
  ),

  setWindowPosition = list(
    com = "
  jsonBody <- toJSON(list(
    x = x, y = y
  ), auto_unbox = TRUE)",
    args = list(x = NA, y = NA),
    type = "ret1"
  ),

  setWindowPositionOld = list(
    com = "obj$windowHandle <- handle
  jsonBody <- toJSON(list(
    x = x, y = y
  ), auto_unbox = TRUE)",
    args = list(x = NA, y = NA, handle = "\"current\""),
    type = "ret1"
  ),

  maximizeWindow = list(com = "jsonBody <- NULL\n", type = "ret1"),

  maximizeWindowOld = list(
    com = "jsonBody <- NULL\nobj$windowHandle <- handle",
    args = list(handle = "\"current\""),
    type = "ret1"
  ),

  switchToFrame = list(
    com = "
# Add function specific JSON to post
  if(\"wElement\" %in% class(Id)){
    # pass the webElement as Json to SS
    Id <- Id$elementId
  }
  jsonBody <- toJSON(list(
    id = Id
  ), auto_unbox = TRUE, null = \"null\")
    ",
    args = list(Id = "NULL"),
    type = "ret1"
  ),

  switchToParentFrame = list(
    com = "
# Add function specific JSON to post
  jsonBody <- NULL
  ",
    type = "ret1"
  ),

  findElement = list(
    com = "
# Add function specific JSON to post
  using <- match.arg(using)
  jsonBody <- toJSON(list(
    using = using, value = value
  ), auto_unbox = TRUE)
  ",
    args = list(
      using =
"c(\"xpath\", \"css selector\", \"id\", \"name\",
   \"tag name\", \"class name\", \"link text\",
   \"partial link text\")",
      value = NA)
    , type = "ret4"
  ),

  findElementFromElement = list(
    com = "
# Add function specific JSON to post
  using <- match.arg(using)
  jsonBody <- toJSON(list(
    using = using, value = value
  ), auto_unbox = TRUE)
  " ,
    args = list(
      using =
"c(\"xpath\", \"css selector\", \"id\", \"name\",
   \"tag name\", \"class name\", \"link text\",
   \"partial link text\")",
      value = NA)
    , type = "ret10"
  ),

  findElements = list(
    com = "
# Add function specific JSON to post
  using <- match.arg(using)
  jsonBody <- toJSON(list(
    using = using, value = value
  ), auto_unbox = TRUE)
  " ,
    args = list(
      using =
"c(\"xpath\", \"css selector\", \"id\", \"name\",
   \"tag name\", \"class name\", \"link text\",
   \"partial link text\")",
      value = NA)
    , type = "ret5"
  ),

  findElementsFromElement = list(
    com = "
# Add function specific JSON to post
  using <- match.arg(using)
  jsonBody <- toJSON(list(
    using = using, value = value
  ), auto_unbox = TRUE)
  "  ,
    args = list(
      using =
"c(\"xpath\", \"css selector\", \"id\", \"name\",
   \"tag name\", \"class name\", \"link text\",
   \"partial link text\")",
      value = NA)
    , type = "ret11"
  ),

  getActiveElement = list(type = "ret4"),

  isElementSelected = list(type = "ret2"),

  getElementAttribute = list(
    com = "obj$name <- attribute",
    args = list(attribute =NA),
    type = "ret2"
  ),

  getElementProperty = list(
    com = "obj$name <- property",
    args = list(property = NA),
    type = "ret2"
  ),

  getElementCssValue = list(
    com = "obj$propertyName <- propertyName",
    args = list(propertyName = NA),
    type = "ret2"
  ),

  getElementText = list(type = "ret2"),

  getElementTagName = list(type = "ret2"),

  getElementRect = list(type = "ret2"),

  isElementEnabled = list(type = "ret2"),

  elementClear = list(com = "jsonBody <- NULL", type = "ret7"),

  elementClick = list(com = "jsonBody <- NULL", type = "ret7"),

  elementSendKeys = list(
    com = "sendKeys <- list(...)
      jsonBody <- toJSON(list(value = matchSelKeys(sendKeys)),
    auto_unbox = TRUE)",
    type = "ret7"),

  executeScript = list(
    com = "
  args <- lapply(args, function(x){
    if('wElement' %in% class(x)){
      x$elementId
    }else{
      x
    }
  })
  jsonBody <- toJSON(list(
    script = script, args = args
  ), auto_unbox = TRUE)
",
    args = list(script = NA, args = "list()", replace = "TRUE"),
    type = "ret6"
  ),

  executeScriptOld = list(
    com = "
    args <- lapply(args, function(x){
    if('wElement' %in% class(x)){
    x$elementId
    }else{
    x
    }
    })
    jsonBody <- toJSON(list(
    script = script, args = args
    ), auto_unbox = TRUE)
    ",
    args = list(script = NA, args = "list()", replace = "TRUE"),
    type = "ret6"
  ),

  executeAsyncScript = list(
    com = "
  args <- lapply(args, function(x){
    if('wElement' %in% class(x)){
      x$elementId
    }else{
      x
    }
  })
  jsonBody <- toJSON(list(
    script = script, args = args
  ), auto_unbox = TRUE)
",
    args = list(script = NA, args = "list()", replace = "TRUE"),
    type = "ret6"
  ),

  executeAsyncScriptOld = list(
    com = "
    args <- lapply(args, function(x){
    if('wElement' %in% class(x)){
    x$elementId
    }else{
    x
    }
    })
    jsonBody <- toJSON(list(
    script = script, args = args
    ), auto_unbox = TRUE)
    ",
    args = list(script = NA, args = "list()", replace = "TRUE"),
    type = "ret6"
  ),

  getAllCookies = list(type = "ret2"),

  getNamedCookie = list(
    com = "obj$name <- name",
    args = list(name = "NULL"),
    type = "ret2"
  ),

  addCookie = list(
    com = "
  cookie <- list(name = name, value = value, path = path, domain = domain
                , secure = secure, httpOnly = httpOnly, expiry = expiry)
  cookie <- cookie[!sapply(cookie, is.null)]
  jsonBody <- toJSON(list(cookie = cookie), null = \"null\",
    auto_unbox = TRUE)",
    args = list(name = NA, value = NA, path = "NULL", domain = "NULL",
                  secure = "FALSE", httpOnly = "NULL", expiry = "NULL"),
    type = "ret1"
  ),

  deleteCookie = list(
    com = "obj$name <- name",
    args = list(name = "NULL"),
    type = "ret1"
  ),

  deleteAllCookies = list(type = "ret1"),

  dismissAlert = list(com = "jsonBody <- NULL", type = "ret1"),

  dismissAlertOld = list(com = "jsonBody <- NULL", type = "ret1"),

  acceptAlert = list(com = "jsonBody <- NULL", type = "ret1"),

  acceptAlertOld = list(com = "jsonBody <- NULL", type = "ret1"),

  getAlertText = list(type = "ret2"),

  getAlertTextOld = list(type = "ret2"),

  sendAlertText = list(
    com = "
    jsonBody <- toJSON(list(text = text), auto_unbox = TRUE)",
    args = list(text = "\"\""),
    type = "ret1"
  ),

  sendAlertTextOld = list(
    com = "
    jsonBody <- toJSON(list(text = text), auto_unbox = TRUE)",
    args = list(text = "\"\""),
    type = "ret1"
  ),

  setTimeouts = list(
    com = "
      jsonBody <- toJSON(list(type = type, ms = milliseconds),
    auto_unbox = TRUE)",
    args = list(type = '\"page load\"', milliseconds = 10000),
    type = "ret1"
  ),

  getTimeouts = list(
    com = "
      jsonBody <- toJSON(list(type = type),
    auto_unbox = TRUE)",
    args = list(type = '\"page load\"'),
    type = "ret2"
  ),

  status = list(
    type = "ret2"
  ),

  takeScreenshot = list(
    args = list(file = "NULL",
                display = 'getOption("seleniumPipes_display_screenshot")',
                  useViewer = '!is.null(getOption("viewer"))',
                returnPNG = "FALSE"),
    type = "ret12"
  ),

  takeElementScreenshot = list(
    args = list(file = "NULL",
                display = 'getOption("seleniumPipes_display_screenshot")',
                useViewer = '!is.null(getOption("viewer"))',
                returnPNG = "FALSE"),
    type = "ret13"
  )
)

selPipeFuncs <- lapply(rowSplit(methPaths), function(x){
  appFunc <- JCommands[[x[["command"]]]]
  appCommand <- appFunc[["com"]]
  if(identical(x[["method"]], "POST")){
    defCommand <- JCommands[["default"]][["com"]]
    x[["JSON_command"]] <-
      ifelse(!is.null(appCommand), appCommand, defCommand)
    x[["JSON"]] <- "jsonBody"
  }else{
    x[["JSON_command"]] <- if(!is.null(appCommand)){appCommand
    }else{
      NULL
    }
    x[["JSON"]] <- "NULL"
  }
  args <- JCommands[[x[["command"]]]][["args"]]
  if(!is.null(args)){
    x[["addArgs"]] <- paste(paste0(
      lapply(name(args), function(x){
        if(is.na(args[[x]])){
          paste0(x, ", ")
        }else{
          paste0(x," = ",args[[x]],", ")
        }
      }
      )), collapse = "")
    x[["roxyArgs"]] <-
      paste(c(paste0("#' @param ",name(args), "\n"), "#'"), collapse = "")
  }else{
    x[["roxyArgs"]] <- "#'"
  }
  type <- if(is.null(appFunc)){
    JCommands[["default"]][["type"]]
  }else{
    appFunc[["type"]]
  }
  x[["return"]] <- selReturn[[type]]
  x[["rettype"]] <- type
  x[["codecommand"]] <- paste0("\\code{", x[["command"]], "}")
  list(fbody = whisker.render(funcTemp[[x$Arg]][["fbody"]], x),
       roxy = whisker.render(funcTemp[[x$Arg]][["roxy"]], x))
}
)
methPaths[["selFuncs"]] <- vapply(selPipeFuncs, "[[", character(1), "fbody")
methPaths[["selRoxy"]] <- vapply(selPipeFuncs, "[[", character(1), "roxy")

# write the functions to file based on the groups they are in
methPaths[,write(file = paste0("R/", group, ".R"),
                 paste(selFuncs, collapse = "")),
          by = group]

# add documentation
if(DOCUMENT){
  methPaths[,write(file = paste0("R/", group, "Doc.R"),
                   paste(selRoxy, collapse = "")),
            by = group]
}