#3 CSW implementation, CSW3 GetCapabilities and CSW2 GetRecords, CSW …

…Query
eblondel · Jun 29, 2018 · f3da80a · f3da80a
1 parent a66fea1
commit f3da80a
Show file tree

Hide file tree

Showing 38 changed files with 623 additions and 154 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -10,6 +10,7 @@ export(CSWConstraint)
 export(CSWDescribeRecord)
 export(CSWGetRecordById)
 export(CSWGetRecords)
+export(CSWQuery)
 export(CSWRecordProperty)
 export(CSWTransaction)
 export(Not)
@@ -18,6 +19,7 @@ export(OGCExpression)
 export(OGCFilter)
 export(OWSCapabilities)
 export(OWSClient)
+export(OWSGetCapabilities)
 export(OWSOperation)
 export(OWSOperationsMetadata)
 export(OWSRequest)

diff --git a/R/CSWCapabilities.R b/R/CSWCapabilities.R
@@ -23,15 +23,17 @@
 #'
 CSWCapabilities <- R6Class("CSWCapabilities",
    inherit = OWSCapabilities,
-   private = list(
-
-   ),
-
+   private = list(),
    public = list(
 
      #initialize
      initialize = function(url, version, logger = NULL) {
-       super$initialize(url, service = "CSW", version, logger = logger)
+       owsVersion <- switch(version,
+         "2.0.2" = "1.1",
+         "3.0" = "2.0"
+       )
+       super$initialize(url, service = "CSW", serviceVersion = version,
+                        owsVersion = owsVersion, logger = logger)
        xmlObj <- self$getRequest()$getResponse()
      }
    )

diff --git a/R/CSWClient.R b/R/CSWClient.R
@@ -9,12 +9,12 @@
 #' 
 #' @examples
 #' \dontrun{
-#'    CSWClient$new("http://localhost:8080/geonetwork/srv/eng/csw", version = "2.0.2")
+#'    CSWClient$new("http://localhost:8080/geonetwork/srv/eng/csw", serviceVersion = "2.0.2")
 #' }
 #'
 #' @section Methods:
 #' \describe{
-#'  \item{\code{new(url, version, user, pwd, logger)}}{
+#'  \item{\code{new(url, serviceVersion, user, pwd, logger)}}{
 #'    This method is used to instantiate a CSWClient with the \code{url} of the
 #'    OGC service. Authentication (\code{user}/\code{pwd}) is not yet supported and will
 #'    be added with the support of service transactional modes. By default, the \code{logger}
@@ -45,8 +45,8 @@ CSWClient <- R6Class("CSWClient",
    ),
    public = list(
      #initialize
-     initialize = function(url, version = NULL, user = NULL, pwd = NULL, logger = NULL) {
-       super$initialize(url, service = private$serviceName, version, user, pwd, logger)
+     initialize = function(url, serviceVersion = NULL, user = NULL, pwd = NULL, logger = NULL) {
+       super$initialize(url, service = private$serviceName, serviceVersion, user, pwd, logger)
        self$capabilities = CSWCapabilities$new(self$url, self$version, logger = logger)
      },
 
@@ -83,7 +83,7 @@ CSWClient <- R6Class("CSWClient",
      },
 
      #getRecords
-     getRecords = function(constraint = NULL, ...){
+     getRecords = function(query = NULL, ...){
        self$INFO("Fetching records ...")
        operations <- self$capabilities$getOperationsMetadata()$getOperations()
        op <- operations[sapply(operations,function(x){x$getName()=="GetRecords"})]
@@ -95,7 +95,7 @@ CSWClient <- R6Class("CSWClient",
          stop(errorMsg)
        }
        request <- CSWGetRecords$new(op, self$getUrl(), self$getVersion(),
-                                    constraint = constraint, logger = self$loggerType, ...)
+                                    query = query, logger = self$loggerType, ...)
        return(request$getResponse())
      },
 
@@ -159,7 +159,7 @@ CSWClient <- R6Class("CSWClient",
      #deleteRecordById
      deleteRecordById = function(id){
        ogcFilter = OGCFilter$new( PropertyIsEqualTo$new("apiso:Identifier", id) )
-       cswConstraint = CSWConstraint$new(ogcFilter)
+       cswConstraint = CSWConstraint$new(filter = ogcFilter)
        return(self$deleteRecord(constraint = cswConstraint))
      }
    )

diff --git a/R/CSWConstraint.R b/R/CSWConstraint.R
@@ -6,7 +6,7 @@
 #' @format \code{\link{R6Class}} object.
 #' @section Methods:
 #' \describe{
-#'  \item{\code{new(filter, cswVersion)}}{
+#'  \item{\code{new(cqlText, filter, cswVersion)}}{
 #'    This method is used to instantiate an CSWConstraint object.
 #'  }
 #' }
@@ -18,15 +18,20 @@ CSWConstraint <-  R6Class("CSWConstraint",
   ),
   public = list(
     wrap = TRUE,
+    CqlText = NULL,
     filter = NULL,
-    initialize = function(filter, cswVersion = "2.0.2"){
+    initialize = function(cqlText = NULL, filter = NULL, cswVersion = "2.0.2"){
       nsName <- names(private$xmlNamespace)
       private$xmlNamespace = paste(private$xmlNamespace, cswVersion, sep="/")
       names(private$xmlNamespace) <- nsName
       super$initialize(attrs = list(version = "1.1.0"))
-      if(!is(filter, "OGCFilter")){
-        stop("The argument should be an object of class 'OGCFilter'")
+      if(!is.null(cqlText)) if(!is(cqlText, "character")){
+        stop("The argument 'cqlText' should be an object of class 'character'")
       }
+      if(!is.null(filter)) if(!is(filter, "OGCFilter")){
+        stop("The argument 'filter' should be an object of class 'OGCFilter'")
+      }
+      self$CqlText = cqlText
       self$filter = filter
     }
   )

diff --git a/R/CSWDescribeRecord.R b/R/CSWDescribeRecord.R
@@ -43,6 +43,7 @@ CSWDescribeRecord <- R6Class("CSWDescribeRecord",
        super$initialize(op, "GET", url, request = private$name,
                         namedParams = namedParams,
                         mimeType = "text/xml", logger = logger, ...)
+       self$execute()
 
        #binding to XML schema
        xsdObjs <- getNodeSet(private$response, "//ns:schema", c(ns = "http://www.w3.org/2001/XMLSchema"))

diff --git a/R/CSWGetRecordById.R b/R/CSWGetRecordById.R
@@ -35,6 +35,7 @@ CSWGetRecordById <- R6Class("CSWGetRecordById",
         super$initialize(op, "GET", url, request = private$name,
                          namedParams = namedParams,
                          mimeType = "text/xml", logger = logger, ...)
+        self$execute()
 
         #check response in case of ISO
         isoSchemas <- c("http://www.isotc211.org/2005/gmd","http://www.isotc211.org/2005/gfc")
@@ -75,8 +76,32 @@ CSWGetRecordById <- R6Class("CSWGetRecordById",
             out
           },
           "http://www.opengis.net/cat/csw/2.0.2" = {
-            warnings(sprintf("R binding not yet supported for '%s'", outputSchema))
-            private$response
+            warnMsg <- sprintf("R Dublin Core binding not yet supported for '%s'", outputSchema)
+            warnings(warnMsg)
+            self$WARN(warnMsg)
+            self$WARN("Dublin Core returned as R list...")
+            recordsXML <- getNodeSet(private$response, "//csw:Record", private$xmlNamespace[1])
+            if(length(recordsXML)>0){
+              recordXML <- recordsXML[[1]]
+              children <- xmlChildren(recordXML)
+              out <- lapply(children, xmlValue)
+              names(out) <- names(children)
+            }
+            out
+          },
+          "http://www.opengis.net/cat/csw/3.0" = {
+            warnMsg <- sprintf("R Dublin Core binding not yet supported for '%s'", outputSchema)
+            warnings(warnMsg)
+            self$WARN(warnMsg)
+            self$WARN("Dublin Core returned as R list...")
+            recordsXML <- getNodeSet(private$response, "//csw:Record", private$xmlNamespace[1])
+            if(length(recordsXML)>0){
+              recordXML <- recordsXML[[1]]
+              children <- xmlChildren(recordXML)
+              out <- lapply(children, xmlValue)
+              names(out) <- names(children)
+            }
+            out
           },
           "http://www.w3.org/ns/dcat#" = {
             warnings(sprintf("R binding not yet supported for '%s'", outputSchema))

diff --git a/R/CSWGetRecords.R b/R/CSWGetRecords.R
@@ -18,38 +18,91 @@
 CSWGetRecords <- R6Class("CSWGetRecords",
   inherit = OWSRequest,
   private = list(
-    name = "GetRecords",
-    defaultOutputSchema = "http://www.opengis.net/cat/csw/2.0.2"
+    xmlElement = "GetRecords",
+    xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"),
+    defaultAttrs = list(
+      service = "CSW",
+      version = "2.0.2",
+      resultType = "results",
+      startPosition = "1",
+      maxRecords = "5",
+      outputFormat="application/xml",
+      outputSchema= "http://www.opengis.net/cat/csw"
+    )
   ),
   public = list(
-    initialize = function(op, url, version, constraint = NULL, logger = NULL, ...) {
-      namedParams <- list(service = "CSW", version = version)
-      if(!is.null(constraint)) namedParams <- c(namedParams, constraint = constraint)
+    Query = NULL,
+    initialize = function(op, url, version = "2.0.2", query = NULL, logger = NULL, ...) {
+      super$initialize(op, "POST", url, request = private$xmlElement,
+                       contentType = "text/xml", mimeType = "text/xml",
+                       logger = logger, ...)
 
-      #default output schema
+      nsName <- names(private$xmlNamespace)
+      private$xmlNamespace = paste(private$xmlNamespace, version, sep="/")
+      names(private$xmlNamespace) <- nsName
+
+      self$attrs <- private$defaultAttrs
+
+      #version
+      self$attrs$version = version
+
+      #resultsType
+      resultType <- list(...)$resultType
+      if(!is.null(resultType)){
+        self$attrs$resultType = resultType
+      }
+
+      #startPosition
+      startPosition <- list(...)$startPosition
+      if(!is.null(startPosition)){
+        self$attrs$startPosition = startPosition
+      }
+
+      #maxRecords
+      maxRecords <- list(...)$maxRecords
+      if(!is.null(maxRecords)){
+        self$attrs$maxRecords <- maxRecords
+      }
+
+      #outputFormat
+      outputFormat <- list(...)$outputFormat
+      if(!is.null(outputFormat)){
+        self$attrs$outputFormat = outputFormat
+      }
+
+      #output schema
+      self$attrs$outputSchema = paste(self$attrs$outputSchema, version, sep="/")
       outputSchema <- list(...)$outputSchema
-      if(is.null(outputSchema)){
-        outputSchema <- private$defaultOutputSchema
-        namedParams <- c(namedParams, outputSchema = outputSchema)
+      if(!is.null(outputSchema)){
+        self$attrs$outputSchema = outputSchema
       }
 
-      #other default params
-      typeNames <- switch(outputSchema,
+      #typeNames value to pass to CSWQuery
+      typeNames <- switch(self$attrs$outputSchema,
         "http://www.isotc211.org/2005/gmd" = "gmd:MD_Metadata",
         "http://www.isotc211.org/2005/gfc" = "gfc:FC_FeatureCatalogue",
         "http://www.opengis.net/cat/csw/2.0.2" = "csw:Record",
+        "http://www.opengis.net/cat/csw/3.0" = "csw:Record",
         "http://www.w3.org/ns/dcat#" = "dcat"
       )
-      namedParams <- c(namedParams, typeNames = typeNames)
-      namedParams[["resultType"]] <- "results"
-      namedParams[["CONSTRAINTLANGUAGE"]] <- "CQL_TEXT"
+      if(typeNames != "csw:Record"){
+        private$xmlNamespace = c(private$xmlNamespace, ns = self$attrs$outputSchema)
+        names(private$xmlNamespace)[2] <- unlist(strsplit(typeNames,":"))[1]
+      }
+
+      if(!is.null(query)){
+        if(!is(query, "CSWQuery")){
+          stop("The argument 'query' should be an object of class 'CSWQuery'")
+        }
+        query$attrs$typeNames = typeNames
+        self$Query = query
+      }
 
-      super$initialize(op, "GET", url, request = private$name,
-                       namedParams = namedParams,
-                       mimeType = "text/xml", logger = logger, ...)
+      #execute
+      self$execute()
 
       #bindings
-      private$response <- switch(outputSchema,
+      private$response <- switch(self$attrs$outputSchema,
         "http://www.isotc211.org/2005/gmd" = {
           out <- NULL
           xmlObjs <- getNodeSet(private$response, "//ns:MD_Metadata", c(ns = outputSchema))
@@ -75,8 +128,43 @@ CSWGetRecords <- R6Class("CSWGetRecords",
           out
         },
         "http://www.opengis.net/cat/csw/2.0.2" = {
-          warnings(sprintf("R binding not yet supported for '%s'", outputSchema))
-          private$response
+          warnMsg <- sprintf("R Dublin Core binding not yet supported for '%s'", outputSchema)
+          warnings(warnMsg)
+          self$WARN(warnMsg)
+          self$WARN("Dublin Core returned as R lists...")
+          out <- private$response
+          if(query$ElementSetName == "full"){
+            out <- list()
+            recordsXML <- getNodeSet(private$response, "//csw:GetRecordsResponse/csw:SearchResults/csw:Record", private$xmlNamespace[1])
+            if(length(recordsXML)>0){
+              out <- lapply(recordsXML, function(recordXML){
+                children <- xmlChildren(recordXML)
+                out.obj <- lapply(children, xmlValue)
+                names(out.obj) <- names(children)
+                return(out.obj)
+              })
+            }
+          }
+          out
+        },
+        "http://www.opengis.net/cat/csw/3.0" = {
+          warnMsg <- sprintf("R Dublin Core binding not yet supported for '%s'", outputSchema)
+          self$WARN(warnMsg); warnings(warnMsg)
+          self$WARN("Dublin Core records returned as R lists...")
+          out <- private$response
+          if(query$ElementSetName == "full"){
+            out <- list()
+            recordsXML <- getNodeSet(private$response, "//csw:GetRecordsResponse/csw:SearchResults/csw:Record", private$xmlNamespace[1])
+            if(length(recordsXML)>0){
+              out <- lapply(recordsXML, function(recordXML){
+                children <- xmlChildren(recordXML)
+                out.obj <- lapply(children, xmlValue)
+                names(out.obj) <- names(children)
+                return(out.obj)
+              })
+            }
+          }
+          out
         },
         "http://www.w3.org/ns/dcat#" = {
           warnings(sprintf("R binding not yet supported for '%s'", outputSchema))

diff --git a/R/CSWQuery.R b/R/CSWQuery.R
@@ -0,0 +1,40 @@
+#' CSWQuery
+#' @docType class
+#' @export
+#' @keywords OGC Query
+#' @return Object of \code{\link{R6Class}} for modelling an CSW Query
+#' @format \code{\link{R6Class}} object.
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(filter, cswVersion)}}{
+#'    This method is used to instantiate an CSWQUery object.
+#'  }
+#' }
+CSWQuery <-  R6Class("CSWQuery",
+  inherit = OGCAbstractObject,
+  private = list(
+    xmlElement = "Query",
+    xmlNamespace = c(csw = "http://www.opengis.net/cat/csw")
+  ),
+  public = list(
+    wrap = TRUE,
+    ElementSetName = "full",
+    constraint = NULL,
+    initialize = function(elementSetName = "full", constraint = NULL,
+                          typeNames = "csw:Record", cswVersion = "2.0.2"){
+      nsName <- names(private$xmlNamespace)
+      private$xmlNamespace = paste(private$xmlNamespace, cswVersion, sep="/")
+      names(private$xmlNamespace) <- nsName
+      super$initialize(attrs = list(typeNames = typeNames))
+      if(!is(elementSetName, "character")){
+        stop("The argument 'elementSetName' should be an object of class 'character'")
+      }
+      self$ElementSetName = elementSetName
+
+      if(!is.null(constraint)) if(!is(constraint, "CSWConstraint")){
+        stop("The argument 'constraint' should be an object of class 'OGCConstraint'")
+      }
+      self$constraint = constraint
+    }
+  )
+)
diff --git a/R/CSWTransaction.R b/R/CSWTransaction.R
@@ -35,11 +35,11 @@ CSWTransaction <- R6Class("CSWTransaction",
         recordProperty = recordProperty,
         constraint = constraint
       )
-      super$initialize(op, "POST", url,
-                       request = private$xmlElement,
-                       attrs = list(service = "CSW", version = version),
+      super$initialize(op, "POST", url, request = private$xmlElement,
                        contentType = "text/xml", mimeType = "text/xml",
                        logger = logger, ...)
+      self$attrs <- list(service = "CSW", version = version)
+      self$execute()
     }
 
   )