R/XMLRPC.R

In rneos: XML-RPC Interface to NEOS

##
## XMLRPC-related functions
##
XMLRPCServer <- function(url, curl = NULL,
         class = if(!is.null(curl))
                      "XMLRPCServerConnection"
                 else
                     "XMLRPCServer",
          ...,
          .opts = list(...))
{
   if(is.null(curl) && length(.opts) ||
        (is.logical(curl) && curl))
     curl = getCurlHandle(.opts = .opts)
   
   ans = new(class, url)
   if(!is.null(curl))
      ans@curl = curl
   
   ans
}

setMethod("$", "XMLRPCServer",
          function(x, name) {
            function(...)
               xml.rpc(as(x, "character"), name, ...)
          })

setMethod("$", "XMLRPCServerConnection",
          function(x, name) {
            function(...)
               xml.rpc(as(x, "character"), name, ..., .curl = x@curl)
          })

xml.rpc <- function(url, method, ..., .args = list(...),
          .opts = list(),
          .defaultOpts = list(httpheader = c('Content-Type' = "text/xml"), followlocation = TRUE, useragent = useragent),
          .convert = TRUE, .curl = getCurlHandle(), useragent = "R-XMLRPC"){
    # Turn the method and arguments to an RPC body.
  body = createBody(method,  .args)

    # merge the .defaultOpts and the .opts into one list.
  .defaultOpts[["postfields"]] = saveXML(body)
  if(length(.opts))
     .defaultOpts[names(.opts)] = .opts

  rdr = dynCurlReader(.curl, baseURL = url)
  .defaultOpts[["headerfunction"]] = rdr$update
  ans = postForm(url, .opts = .defaultOpts, style = "POST", curl = .curl)

  hdr = parseHTTPHeader(rdr$header())
  if(as.integer(hdr[["status"]]) %/% 100 !=  2) {
       # call an RCurl error generator function.      
     stop("Problems")
  }
  ans = rdr$value()

   # Now either convert using the default converter fnction (convertToR)
   # or return as is or allow the caller to specify a function to use for conversion.
  if(is.logical(.convert)) {
    if(.convert)
      convertToR(ans)
    else
      ans
  } else if(is.function(.convert))
          .convert(ans)
  else
      ans
}

createBody <- function(method, args){
    top = newXMLNode("methodCall", newXMLNode("methodName", method))
    params = newXMLNode("params", parent = top)
    sapply(args, function(x) newXMLNode("param", rpc.serialize(x),
                                        parent = params))
    top
}

setGeneric("rpc.serialize", function(x, ...) standardGeneric("rpc.serialize"))

setMethod("rpc.serialize", "ANY",
           function(x, ...) {
              if(isS4(x))
                return(rpc.serialize.S4Object(x, ...))

              stop("Not sure how to convert this type of object to XMLRPC format")
           })

rpc.serialize.S4Object <- function(x, ...){
  els = slotNames(x)
  rpc.serialize(structure(lapply(els, function(id) slot(x, id)), names = els), ...)
}


basicTypeMap <-
  c("integer" = "i4",
    "double" = "double",
    "character" = "string",
    "logical" = "boolean",
    "POSIXt" = "dateTime.iso8601",
    "POSIXct" = "dateTime.iso8601",
    "Date" = "dateTime.iso8601",    
    "raw" = "base64")

cast <- function(x) {
  if (is.logical(x))
    as.integer(x)
  else
    x
}

setOldClass("AsIs")

setMethod("rpc.serialize", "AsIs",
           function(x) {
             type = basicTypeMap[typeof(x)]
             vectorArray(x, type)
           })

setMethod("rpc.serialize", "NULL",
           function(x, ...) {
             rpc.serialize(list())
           })

setMethod("rpc.serialize", "raw",
           function(x, ...) {
               val = base64Encode(x)
               newXMLNode("value", newXMLNode("base64", val))
           })

setMethod("rpc.serialize", "Date",
           function(x, ...) {
             val = format(x, "%Y%m%dT%H:%H:%S")
             if(length(x) == 1)
                newXMLNode("value", newXMLNode("dateTime.iso8601", val))
             else
                vectorArray(val, basicTypeMap["Date"])
           })

setMethod("rpc.serialize", "POSIXt",
           function(x, ...) {
             val = format(as.POSIXct(x), "%Y%m%dT%H:%H:%S")
             if(length(x) == 1)
                newXMLNode("value", newXMLNode("dateTime.iso8601", val))
             else
                vectorArray(val, basicTypeMap["POSIXt"])               
           })

setMethod("rpc.serialize", "vector",
           function(x, ...) {
               type <- basicTypeMap[typeof(x)]
               x <- cast(x)
               
              if(length(names(x))) {
                warning("Skipping names on vector!")
                names(x) = NULL
              }
              if(length(x) == 1){
                  newXMLNode("value", newXMLNode(type, if(type == "string")
                                                           newXMLCDataNode(x)
                                                       else x))
              } else {
                  vectorArray(x, type)
              }
           })


FormatStrings <- c(numeric = "%f", int = "%d", integer = "%d", logical = "%s",
                  i4 = "%d", double = "%f",
                  string = "%s", Date = "%s",  POSIXt = "%s", POSIXct = "%s")

vectorArray <- function(x, type){
  top <- newXMLNode("value")
  a <- newXMLNode("array", parent = top)
  data <- newXMLNode("data", parent = a)

  tmpl <- if(type == "string")  ## is.character(x))
            sprintf("<value><%s><![CDATA[%%s]]></%s></value>", type, type)
         else if(type == "dateTime.iso8601") {
            if(is(x, "Date"))
               x = format(x, "%Y%m%dT00:00:00")              
            else
               x = format(as.POSIXct(x), "%Y%m%dT%H:%H:%S")
            sprintf("<value><%s>%%s</%s></value>", type, type)
         } else {
           if(type == "double") {
              x = as.character(x)
              pct = "%s"
           } else
             pct = FormatStrings[type]
           
           if(is.na(pct)) pct = "%s"
           sprintf("<value><%s>%s</%s></value>", type, pct, type)
         }
  
  txt <- sprintf(tmpl, x)
  parseXMLAndAdd(txt, data)
  top
}

setMethod("rpc.serialize", "list",
           function(x, ...) {
              
              if(length(names(x))) {
                  a = newXMLNode("struct")
                  sapply(names(x), function(id) {
                                     type = basicTypeMap[typeof(x[[id]])]
                                     newXMLNode("member", newXMLNode("name", id),
                                                 rpc.serialize(x[[id]]
                                               ),
                                                parent = a)
                                   })
                  a
              } else {
                  a = newXMLNode("array")
                  data = newXMLNode("data", parent = a)
                  sapply(x, function(x) {
                               elName = basicTypeMap[typeof(x)]
                               newXMLNode("value", newXMLNode(elName, if(elName == "string") newXMLCDataNode(x) else x,
                                                               parent = data))
                             })
              a
              }
           })


setGeneric("convertToR", function(node) standardGeneric('convertToR'))

setMethod("convertToR", 'XMLInternalDocument', function(node)
{
    fault = getNodeSet(node,path="//methodResponse/fault/value/struct")
    if (length(fault) > 0) {
          fault = xmlRPCToR(fault[[1]])
          e = simpleError(paste("faultCode: ",  fault$faultCode, " faultString: ", fault$faultString))
          class(e) = c("XMLRPCError", class(e))
          stop(e)
    }
    a = xpathApply(node, "//param/value", xmlRPCToR)
    if(length(a) == 1)
      a[[1]]
    else
      a
})

setMethod("convertToR", "XMLInternalNode",
function(node)
{
   if(length(getNodeSet(node, "./param/value"))) {
     ans = xpathApply(node, "./param/value", xmlRPCToR, simplify = FALSE)
   } else
      xmlToList(node)
})

setMethod("convertToR", "character",
function(node)
{
  convertToR(xmlParse(node, asText = TRUE))
})

xmlRPCToR <- function(node, ...){
  if(is.null(node))
    return(NULL)
  
  if(xmlName(node) == "value")
    node = node[[1]]

  if(is(node, "XMLInternalTextNode"))
    return(xmlValue(node))
  
  type = xmlName(node)
  switch(type,
         'array' = xmlRPCToR.array(node, ...),
         'struct' = xmlRPCToR.struct(node, ...),
         'i4' = as.integer(xmlValue(node)),
         'int' = as.integer(xmlValue(node)),
         'boolean' = if(xmlValue(node) == "1") TRUE else FALSE,                  
         'double' = as.numeric(xmlValue(node)),
         'string' = xmlValue(node),
         'dateTime.iso8601' = as.POSIXct(strptime(xmlValue(node), "%Y%m%dT%H:%M:%S")),
         'base64' = base64(xmlValue(node), encode = FALSE),
         xmlValue(node)
        )

}

xmlRPCToR.struct <- function(node, ...){    
  ans <- xmlApply(node, function(x) xmlRPCToR(x[["value"]][[1]], ...))
  names(ans) <- xmlSApply(node, function(x) xmlValue(x[["name"]]))
  ans
}

xmlRPCToR.array <- function(node, ...){
  ans = xmlApply(node[["data"]], function(x) xmlRPCToR(x[[1]]))

  if(!is.list(ans[[1]]) && all(sapply(ans, typeof) == typeof(ans[[1]])))
    structure(unlist(ans), names = NULL)
  else
    ans
}