#3 CSW transaction insert/update + improve OWSRequest

.travis.yml

@@ -18,7 +18,7 @@ before_install:
   # docker images for integration tests
   # --> pycsw
   - docker pull geopython/pycsw:2.2.0
-  - docker run --name pycsw --publish 8000:8000 --detach geopython/pycsw
+  - docker run --name pycsw -v /inst/extdata/pycsw/pycsw.cfg:/etc/pycsw/pycsw.cfg --publish 8000:8000 geopython/pycsw
   # --> GeoNetwork
   - docker pull kartoza/postgis
   - docker run -d --name="postgis" kartoza/postgis

R/CSWClient.R

@@ -97,6 +97,64 @@ CSWClient <- R6Class("CSWClient",
        request <- CSWGetRecords$new(op, self$getUrl(), self$getVersion(),
                                     constraint = constraint, logger = self$loggerType, ...)
        return(request$response)
+     },
+
+     #transaction
+     transaction = function(type, record, constraint = NULL, ...){
+       self$INFO(sprintf("Transaction (%s) ...", type))
+       operations <- self$capabilities$getOperationsMetadata()$getOperations()
+       op <- operations[sapply(operations,function(x){x$getName()=="Transaction"})]
+       if(length(op)>0){
+         op <- op[[1]]
+       }else{
+         errorMsg <- "Operation 'Transaction' not supported by this service"
+         self$ERROR(errorMsg)
+         stop(errorMsg)
+       }
+
+       transaction <- CSWTransaction$new(op, self$getUrl(), self$getVersion(),
+                                         type = type, record = record, constraint = constraint, 
+                                         logger = self$loggerType, ...)
+
+       exception <- getNodeSet(transaction$response, "//ows:ExceptionText", c(ows = xmlNamespaces(transaction$response)$ows$uri))
+       if(length(exception)>0){
+         exception <- exception[[1]]
+         transaction$exception <- xmlValue(exception)
+         self$ERROR(transaction$exception)
+       }
+
+       summaryKey <- switch(type,
+         "Insert" = "Inserted",
+         "Update" = "Updated",
+         "Delete" = "Deleted"
+       )
+       transaction[[tolower(summaryKey)]] <- FALSE
+       result <- getNodeSet(transaction$response,paste0("//csw:total",summaryKey),
+                              c(csw = xmlNamespaces(transaction$response)$csw$uri))
+       if(length(result)>0){
+         result <- result[[1]]
+         if(xmlValue(result)>0) transaction[[tolower(summaryKey)]] <- TRUE
+       }
+       if(transaction[[tolower(summaryKey)]]){
+         self$INFO(sprintf("Successful transaction (%s)!", type))
+       }
+
+       return(transaction)
+     },
+
+     #insertRecord
+     insertRecord = function(record, ...){
+       return(self$transaction("Insert", record, constraint = NULL, ...))
+     },
+
+     #updateRecord
+     updateRecord = function(record = NULL, constraint = NULL, ...){
+       return(self$transaction("Update", record, constraint, ...))
+     },
+
+     #deleteRecord
+     deleteRecord = function(record = NULL, constraint = NULL, ...){
+       return(self$transaction("Delete", record, constraint, ...))
      }
    )
 )

R/CSWDescribeRecord.R

@@ -40,12 +40,36 @@ CSWDescribeRecord <- R6Class("CSWDescribeRecord",
        )
        namedParams <- c(namedParams, namespace = namespace, typeName = typeName)
 
-       super$initialize(op, url, namedParams, mimeType = "text/xml", logger = logger, ...)
+       super$initialize(op, "GET", url, namedParams = namedParams, mimeType = "text/xml", logger = logger, ...)
 
        #binding to XML schema
        xsdObjs <- getNodeSet(self$response, "//ns:schema", c(ns = "http://www.w3.org/2001/XMLSchema"))
        if(length(xsdObjs)>0){
          xsdObj <- xsdObjs[[1]]
+         xmlNamespaces(xsdObj) <- c(as.vector(xmlNamespace(xsdObj)), gco = "http://www.isotc211.org/2005/gco")
+         xmlNamespaces(xsdObj) <- xmlNamespaces(xmlObj)
+
+         #post-process xs imports
+         mainNamespace <- NULL
+         getRemoteSchemaLocation <- function(import, useMainNamespace = FALSE){
+           ns <- ifelse(useMainNamespace, mainNamespace, xmlGetAttr(import, "namespace"))
+           if(is.null(mainNamespace)) mainNamespace <<- ns
+           schemaLocation <- xmlGetAttr(import, "schemaLocation")
+           schemaLocation.split <- unlist(strsplit(schemaLocation, "../", fixed = TRUE))
+           n.dir <- length(unlist(regmatches(schemaLocation, gregexpr("\\.\\./", schemaLocation))))
+           ns.split <- unlist(strsplit(ns, "/"))
+           schemaLocation.new <- paste(
+            paste(ns.split[1:(length(ns.split)-n.dir)], collapse="/"),
+            schemaLocation.split[length(schemaLocation.split)],
+            sep="/"
+           )
+           attrs <-c(schemaLocation = schemaLocation.new)
+           #if(!useMainNamespace) attrs <- c(namespace = ns, attrs)
+           xmlAttrs(import) <- attrs
+         }
+         invisible(sapply(xpathApply(xsdObj, "//xs:import"), getRemoteSchemaLocation))
+         invisible(sapply(xpathApply(xsdObj, "//xs:include"), getRemoteSchemaLocation, TRUE))
+
          tempf = tempfile() 
          destfile = paste(tempf,".xsd",sep='')
          saveXML(xsdObj, destfile)

R/CSWGetRecordById.R

@@ -32,7 +32,7 @@ CSWGetRecordById <- R6Class("CSWGetRecordById",
           namedParams <- c(namedParams, outputSchema = outputSchema)
         }
 
-        super$initialize(op, url, namedParams, mimeType = "text/xml", logger = logger, ...)
+        super$initialize(op, "GET", url, namedParams = namedParams, mimeType = "text/xml", logger = logger, ...)
 
         #check response in case of ISO
         isoSchemas <- c("http://www.isotc211.org/2005/gmd","http://www.isotc211.org/2005/gfc")

R/CSWGetRecords.R

@@ -44,7 +44,7 @@ CSWGetRecords <- R6Class("CSWGetRecords",
       namedParams[["resultType"]] <- "results"
       namedParams[["CONSTRAINTLANGUAGE"]] <- "CQL_TEXT"
 
-      super$initialize(op, url, namedParams, mimeType = "text/xml", logger = logger, ...)
+      super$initialize(op, "GET", url, namedParams = namedParams, mimeType = "text/xml", logger = logger, ...)
 
       #bindings
       self$response <- switch(outputSchema,

R/CSWTransaction.R

@@ -0,0 +1,43 @@
+#' CSWTransaction
+#'
+#' @docType class
+#' @export
+#' @keywords OGC CSW Transaction
+#' @return Object of \code{\link{R6Class}} for modelling a CSW Transaction request
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(url, version, id)}}{
+#'    This method is used to instantiate a CSWTransaction object
+#'  }
+#' }
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+CSWTransaction <- R6Class("CSWTransaction",
+  lock_objects = FALSE,
+  inherit = OWSRequest, 
+  private = list(
+    name = "Transaction",
+    defaultNamespace = "http://www.opengis.net/cat/csw"
+  ),
+  public = list(
+    initialize = function(op, url, version, type, record, constraint = NULL, logger = NULL, ...) {
+      namespace = c(csw = paste(private$defaultNamespace, version, sep="/"))
+
+      namedParams <- list(request = private$name, transaction = record)
+      names(namedParams)[2] <- type
+      if(!is.null(namedParams)) namedParams <- c(namedParams, constraint = constraint)
+
+      namedAttrs <- list(service = "CSW", version = version)
+
+      super$initialize(op, "POST", url, namedParams = namedParams, namedAttrs = namedAttrs,
+                       namespace = namespace, contentType = "text/xml", mimeType = "text/xml",
+                       logger = logger, ...)
+
+
+    }
+
+  )
+)

R/OWSCapabilities.R

@@ -56,7 +56,7 @@ OWSCapabilities <- R6Class("OWSCapabilities",
      initialize = function(url, service, version, logger = NULL) {
        super$initialize(logger = logger)
        namedParams <- list(request = "GetCapabilities", version = version)
-       private$request <- OWSRequest$new(op = NULL, url, namedParams, "text/xml", logger = logger)
+       private$request <- OWSRequest$new(op = NULL, "GET", url, namedParams, "text/xml", logger = logger)
        xmlObj <- private$request$response
        private$serviceIdentification <- OWSServiceIdentification$new(xmlObj, service, version)
        private$serviceProvider <- OWSServiceProvider$new(xmlObj, service, version)

R/OWSRequest.R

@@ -23,8 +23,8 @@ OWSRequest <- R6Class("OWSRequest",
   inherit = OWSLogger,                    
   #private methods
   private = list(
-    #buildRequest
-    buildRequest = function(url, namedParams, mimeType){
+    #GET
+    GET = function(url, namedParams, mimeType){
       params <- paste(names(namedParams), namedParams, sep = "=", collapse = "&")
       request <- paste(url, "&", params, sep = "")
       self$INFO(sprintf("Fetching %s", request))
@@ -48,6 +48,77 @@ OWSRequest <- R6Class("OWSRequest",
       }
       response <- list(request = request, status = status_code(r), response = responseContent)
       return(response)
+    },
+
+    #POST
+    POST = function(url, namedParams, namedAttrs, namespace,
+                    contentType = "text/xml", mimeType = "text/xml"){
+
+      #Prepare request
+      requestName <- namedParams$request
+      namedParams <- namedParams[names(namedParams) != "request"]
+      rootXML <- xmlOutputDOM(
+        tag = requestName,
+        nameSpace = names(namespace),
+        nsURI = namespace,
+        attrs = namedAttrs
+      )
+      for(param in names(namedParams)){
+        wrapperNode <- xmlOutputDOM(tag = param, nameSpace = names(namespace))
+        content <- namedParams[[param]]
+        if(is(content, "XMLInternalDocument")){
+          content <- as(content, "character")
+          content <- gsub("<\\?xml.*?\\?>", "", content)
+          content <- gsub("<!--.*?-->", "", content)
+          content <- xmlRoot(xmlParse(content, encoding = "UTF-8"))
+        }else{
+          content <- xmlTextNode(as(content,"character"))
+        }
+        wrapperNode$addNode(content)
+        rootXML$addNode(wrapperNode$value())
+      }
+      outXML <- rootXML$value()
+      outXML <- as(outXML, "XMLInternalNode")
+      if(length(namedAttrs)>0){
+        suppressWarnings(xmlAttrs(outXML) <- namedAttrs)
+      }
+      outbuf <- xmlOutputBuffer("")
+      outbuf$add(as(outXML, "character"))
+      outXML <- xmlParse(outbuf$value(), encoding = "UTF-8")
+
+      #send request
+      if(self$verbose.debug){
+        r <- with_verbose(httr::POST(
+          url = url,
+          add_headers(
+            "Content-type" = contentType
+          ),    
+          body = as(outXML, "character")
+        ))
+      }else{
+        r <- httr::POST(
+          url = url,
+          add_headers(
+            "Content-type" = contentType
+          ),    
+          body = as(outXML, "character")
+        )
+      }
+
+      responseContent <- NULL
+      if(is.null(mimeType)){
+        responseContent <- content(r, encoding = "UTF-8")
+      }else{
+        if(regexpr("xml",mimeType)>0){
+          text <- content(r, type = "text", encoding = "UTF-8")
+          text <- gsub("<!--.*?-->", "", text)
+          responseContent <- xmlParse(text)
+        }else{
+          responseContent <- content(r, type = mimeType, encoding = "UTF-8")
+        }
+      }
+      response <- list(request = outXML, status = status_code(r), response = responseContent)
+      return(response)
     }
   ),
   #public methods
@@ -56,7 +127,9 @@ OWSRequest <- R6Class("OWSRequest",
     status = NA,
     response = NA,
     #initialize
-    initialize = function(op, url, namedParams, mimeType = "text/xml", logger = NULL, ...) {
+    initialize = function(op, type, url, namedParams, namedAttrs = NULL, namespace = NULL,
+                          contentType = "text/xml", mimeType = "text/xml",
+                          logger = NULL, ...) {
       super$initialize(logger = logger)
       vendorParams <- list(...)
       #if(!is.null(op)){
@@ -80,7 +153,11 @@ OWSRequest <- R6Class("OWSRequest",
       vendorParams <- vendorParams[!sapply(vendorParams, is.null)]
       vendorParams <- lapply(vendorParams, curl::curl_escape)
       namedParams <- c(namedParams, vendorParams)
-      req <- private$buildRequest(url, namedParams, mimeType)
+
+      req <- switch(type,
+        "GET" = private$GET(url, namedParams, mimeType),
+        "POST" = private$POST(url, namedParams, namedAttrs, namespace, contentType, mimeType)
+      )
       self$request <- req$request
       self$status <- req$status
       self$response <- req$response

R/WFSDescribeFeatureType.R

@@ -23,7 +23,7 @@ WFSDescribeFeatureType <- R6Class("WFSDescribeFeatureType",
   public = list(
     initialize = function(op, url, version, typeName, ...) {
       namedParams <- list(request = private$name, version = version, typeName = typeName)
-      super$initialize(op, url, namedParams, mimeType = "text/xml", ...)
+      super$initialize(op, "GET", url, namedParams = namedParams, mimeType = "text/xml", ...)
     }
   )
 )

R/WFSGetFeature.R

@@ -23,7 +23,7 @@ WFSGetFeature <- R6Class("WFSGetFeature",
   public = list(
      initialize = function(op, url, version, typeName, ...) {
        namedParams <- list(request = private$name, version = version, typeName = typeName)
-       super$initialize(op, url, namedParams, mimeType = "text/xml", ...)
+       super$initialize(op, "GET", url, namedParams = namedParams, mimeType = "text/xml", ...)
      }
    )
 )

README.md

@@ -9,15 +9,15 @@ R client for OGC Web-Services
 
 ``ows4R`` is a new project that aims to set-up a pure R interface to OGC Web-Services. In a first time (ongoing work), ``ows4R`` will target:
 * the Common OGC Web-Services specifications, version ``1.1.0``
-* the Catalogue Service (CSW), version ``2.0.2``
+* the Catalogue Service for the Web (CSW), versions ``2.0.2`` and ``3.0``
 * the Web Feature Service (WFS), versions ``1.0.0``, ``1.1.0``, and ``2.0.0``
 
 ## OGC standards coverage status
 
 Standard  |Description|Supported versions|Supported R bindings|Support
 ----------|-----------|------------------|--------------------|------|
 OGC Common|[Web Service Common](http://www.opengeospatial.org/standards/common)|``1.1.0``||ongoing
-OGC CSW   |[Catalogue Service](http://www.opengeospatial.org/standards/cat)|``2.0.2``|[geometa](https://github.com/eblondel/geometa) (ISO 19115 / 19119 / 19110)|ongoing
+OGC CSW   |[Catalogue Service](http://www.opengeospatial.org/standards/cat)|``2.0.2``,``3.0.0``|[geometa](https://github.com/eblondel/geometa) (ISO 19115 / 19119 / 19110)|ongoing / seeking fundings
 OGC WFS   |[Web Feature Service](http://www.opengeospatial.org/standards/wfs)|``1.0.0``,``1.1.0``,``2.0.0``|[sf](https://github.com/r-spatial/sf) (OGC Simple Feature)|ongoing
 
 In case of a missing feature, [create a ticket](https://github.com/eblondel/ows4R/issues/new).
@@ -26,5 +26,5 @@ In case of a missing feature, [create a ticket](https://github.com/eblondel/ows4
 
 * Support for additional OGC web-service standard specifications
 
-For more information, or if you are interested in funding this R package project or to contribute to it, do not hesitate to contact me by [e-mail](mailto:[email protected])
+For more information, or if you are interested in funding this R project or to contribute to it, do not hesitate to contact me by [e-mail](mailto:[email protected])