#43 implement OWSRequest, refactor OWSHttpREquest, #49 issue with OWS…

… capabilities

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ows4R
 Version: 0.2
-Date: 2021-06-03
+Date: 2021-06-011
 Title: Interface to OGC Web-Services (OWS)
 Authors@R: c(person("Emmanuel", "Blondel", role = c("aut", "cre"), email = "[email protected]", comment = c(ORCID = "0000-0002-5870-5762")),
              person("Norbert", "Billet", role = c("ctb")))

NAMESPACE

@@ -21,6 +21,7 @@ export(OGCFilter)
 export(OWSCapabilities)
 export(OWSClient)
 export(OWSGetCapabilities)
+export(OWSHttpRequest)
 export(OWSOperation)
 export(OWSOperationsMetadata)
 export(OWSRequest)

R/CSWCapabilities.R

@@ -36,8 +36,7 @@ CSWCapabilities <- R6Class("CSWCapabilities",
          "2.0.2" = "1.1",
          "3.0.0" = "2.0"
        )
-       super$initialize(url, service = "CSW", serviceVersion = version,
-                        owsVersion = owsVersion, logger = logger)
+       super$initialize(url, service = "CSW", owsVersion = owsVersion, serviceVersion = version, logger = logger)
        xmlObj <- self$getRequest()$getResponse()
      }
    )

R/CSWDescribeRecord.R

@@ -18,7 +18,7 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 CSWDescribeRecord <- R6Class("CSWDescribeRecord",
-   inherit = OWSRequest,
+   inherit = OWSHttpRequest,
    private = list(
      name = "DescribeRecord",
      defaultNamespace = "csw:http://www.opengis.net/cat/csw/2.0.2"

R/CSWGetRecordById.R

@@ -18,7 +18,7 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 CSWGetRecordById <- R6Class("CSWGetRecordById",
-    inherit = OWSRequest,
+    inherit = OWSHttpRequest,
     private = list(
       xmlElement = "GetRecordById",
       xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"),

R/CSWGetRecords.R

@@ -18,7 +18,7 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 CSWGetRecords <- R6Class("CSWGetRecords",
-  inherit = OWSRequest,
+  inherit = OWSHttpRequest,
   private = list(
     xmlElement = "GetRecords",
     xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"),

R/CSWHarvest.R

@@ -18,7 +18,7 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 CSWHarvest <- R6Class("CSWHarvest",
-   inherit = OWSRequest,
+   inherit = OWSHttpRequest,
    private = list(
      xmlElement = "Harvest",
      xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"),

R/CSWTransaction.R

@@ -19,7 +19,7 @@
 #'
 CSWTransaction <- R6Class("CSWTransaction",
   lock_objects = FALSE,
-  inherit = OWSRequest, 
+  inherit = OWSHttpRequest, 
   private = list(
     xmlElement = "Transaction",
     xmlNamespace = c(csw = "http://www.opengis.net/cat/csw")

R/OWSCapabilities.R

@@ -9,7 +9,7 @@
 #'
 #' @section Methods:
 #' \describe{
-#'  \item{\code{new(url, service, serviceVersion, owsVersion, logger)}}{
+#'  \item{\code{new(url, service,  owsVersion, serviceVersion, logger)}}{
 #'    This method is used to instantiate a OWSGetCapabilities object
 #'  }
 #'  \item{\code{getUrl()}}{
@@ -52,18 +52,18 @@ OWSCapabilities <- R6Class("OWSCapabilities",
    public = list(
 
      #initialize
-     initialize = function(url, service, serviceVersion, owsVersion, logger = NULL) {
+     initialize = function(url, service, owsVersion, serviceVersion, logger = NULL) {
        super$initialize(logger = logger)
        private$url <- url
        private$service <- service
-       private$serviceVersion <- serviceVersion
        private$owsVersion <- owsVersion
+       private$serviceVersion <- serviceVersion
        namedParams <- list(service = service, version = serviceVersion)
        private$request <- OWSGetCapabilities$new(op = NULL, url, service, serviceVersion, logger = logger)
        xmlObj <- private$request$getResponse()
-       private$serviceIdentification <- OWSServiceIdentification$new(xmlObj, owsVersion)
-       private$serviceProvider <- OWSServiceProvider$new(xmlObj, owsVersion)
-       private$operationsMetadata <- OWSOperationsMetadata$new(xmlObj, owsVersion)
+       private$serviceIdentification <- OWSServiceIdentification$new(xmlObj, owsVersion, serviceVersion)
+       private$serviceProvider <- OWSServiceProvider$new(xmlObj, owsVersion, serviceVersion)
+       private$operationsMetadata <- OWSOperationsMetadata$new(xmlObj, owsVersion, serviceVersion)
      },
 
      #getUrl

R/OWSGetCapabilities.R

@@ -18,7 +18,7 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 OWSGetCapabilities <- R6Class("OWSGetCapabilities",
-  inherit = OWSRequest,
+  inherit = OWSHttpRequest,
   private = list(
     name = "GetCapabilities"
   ),

R/OWSHttpRequest.R

@@ -0,0 +1,274 @@
+#' OWSHttpRequest
+#'
+#' @docType class
+#' @export
+#' @keywords OGC OWS HTTP Request
+#' @return Object of \code{\link{R6Class}} for modelling a generic OWS http request
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(op, type, url, request, user, pwd, namedParams, attrs, 
+#'                  contentType, mimeType, logger)}}{
+#'    This method is used to instantiate a object for doing an OWS request
+#'  }
+#'  \item{\code{getRequest()}}{
+#'    Get the request payload
+#'  }
+#'  \item{\code{getRequestHeaders()}}{
+#'    Get the request headers
+#'  }
+#'  \item{\code{getStatus()}}{
+#'    Get the request status code
+#'  }
+#'  \item{\code{getResponse()}}{
+#'    Get the request response
+#'  }
+#'  \item{\code{getException()}}{
+#'    Get the exception (in case of request failure)
+#'  }
+#'  \item{\code{getResult()}}{
+#'    Get the result \code{TRUE} if the request is successful, \code{FALSE} otherwise
+#'  }
+#' }
+#' 
+#' @note Abstract class used internally by \pkg{ows4R}
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+OWSHttpRequest <- R6Class("OWSHttpRequest",
+  inherit = OGCAbstractObject,                    
+  #private methods
+  private = list(
+    xmlElement = NULL,
+    xmlNamespace = c(ows = "http://www.opengis.net/ows"),
+    url = NA,
+    type = NA,
+    request = NA,
+    requestHeaders = NA,
+    namedParams = list(),
+    contentType = "text/xml",
+    mimeType = "text/xml",
+    status = NA,
+    response = NA,
+    exception = NA,
+    result = NA,
+
+    user = NULL,
+    pwd = NULL,
+    token = NULL,
+    auth_scheme = NULL,
+
+    #GET
+    #---------------------------------------------------------------
+    GET = function(url, request, namedParams, mimeType){
+      namedParams <- c(namedParams, request = request)
+      params <- paste(names(namedParams), namedParams, sep = "=", collapse = "&")
+      req <- url
+      if(!endsWith(url,"?")) req <- paste0(req, "?")
+      req <- paste0(req, params)
+      self$INFO(sprintf("Fetching %s", req))
+
+      #headers
+      headers <- c()
+      if(!is.null(private$token)){
+        headers <- c(headers, "Authorization" = paste(private$auth_scheme, private$token))
+      }
+
+      r <- NULL
+      if(self$verbose.debug){
+        r <- with_verbose(GET(req, add_headers(headers)))
+      }else{
+        r <- GET(req, add_headers(headers))
+      }
+      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 = "text", encoding = "UTF-8")
+        }
+      }
+      response <- list(request = request, requestHeaders = headers(r),
+                       status = status_code(r), response = responseContent)
+      return(response)
+    },
+
+    #POST
+    #---------------------------------------------------------------    
+    POST = function(url, contentType = "text/xml", mimeType = "text/xml"){
+
+      #vendor params
+      geometa_validate <- if(!is.null(private$namedParams$geometa_validate)) as.logical(private$namedParams$geometa_validate) else TRUE
+      geometa_inspire <- if(!is.null(private$namedParams$geometa_inspire)) as.logical(private$namedParams$geometa_inspire) else FALSE
+
+      #XML encoding
+      outXML <- self$encode(
+        geometa_validate = geometa_validate,
+        geometa_inspire = geometa_inspire
+      )
+
+      #headers
+      headers <- c("Accept" = "application/xml", "Content-Type" = contentType)
+      if(!is.null(private$token)){
+        headers <- c(headers, "Authorization" = paste(private$auth_scheme, private$token))
+      }
+
+      #send request
+      if(self$verbose.debug){
+        r <- with_verbose(httr::POST(
+          url = url,
+          add_headers(headers),    
+          body = as(outXML, "character")
+        ))
+      }else{
+        r <- httr::POST(
+          url = url,
+          add_headers(headers),    
+          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, requestHeaders = headers(r),
+                       status = status_code(r), response = responseContent)
+      return(response)
+    }
+  ),
+  #public methods
+  public = list(
+    #initialize
+    initialize = function(op, type, url, request,
+                          user = NULL, pwd = NULL, token = NULL, 
+                          namedParams = NULL, attrs = NULL,
+                          contentType = "text/xml", mimeType = "text/xml",
+                          logger = NULL, ...) {
+      super$initialize(logger = logger)
+      private$type = type
+      private$url = url
+      private$request = request
+      private$namedParams = namedParams
+      private$contentType = contentType
+      private$mimeType = mimeType
+
+      #authentication schemes
+      if(!is.null(user) && !is.null(pwd)){
+        #Basic authentication (user/pwd) scheme
+        private$auth_scheme = "Basic"
+        private$user = user
+        private$pwd = pwd
+        private$token = openssl::base64_encode(charToRaw(paste(user, pwd, sep=":")))
+      }
+      if(!is.null(token)){
+        #Token/Bearer authentication
+        private$auth_scheme = "Bearer"
+        private$token = token
+      }
+
+      vendorParams <- list(...)
+      #if(!is.null(op)){
+      #  for(param in names(vendorParams)){
+      #    if(!(param %in% names(op$getParameters()))){
+      #      errorMsg <- sprintf("Parameter '%s' is not among allowed parameters [%s]",
+      #                          param, paste(paste0("'",names(op$getParameters()),"'"), collapse=","))
+      #      self$ERROR(errorMsg)
+      #      stop(errorMsg)
+      #    }
+      #    value <- vendorParams[[param]]
+      #    paramAllowedValues <- op$getParameter(param)
+      #    if(!(value %in% paramAllowedValues)){
+      #      errorMsg <- sprintf("'%s' parameter value '%s' is not among allowed values [%s]",
+      #                          param, value, paste(paste0("'",paramAllowedValues,"'"), collapse=","))
+      #      self$ERROR(errorMsg)
+      #      stop(errorMsg)
+      #    }
+      #  }
+      #}
+      vendorParams <- vendorParams[!sapply(vendorParams, is.null)]
+      vendorParams <- lapply(vendorParams, curl::curl_escape)
+      private$namedParams <- c(private$namedParams, vendorParams)
+    },
+
+    #execute
+    execute = function(){
+
+      req <- switch(private$type,
+                    "GET" = private$GET(private$url, private$request, private$namedParams, private$mimeType),
+                    "POST" = private$POST(private$url, private$contentType, private$mimeType)
+      )
+
+      private$request <- req$request
+      private$requestHeaders <- req$requestHeaders
+      private$status <- req$status
+      private$response <- req$response
+
+      if(private$type == "GET"){
+        if(private$status != 200){
+          private$exception <- sprintf("Error while executing request '%s'", req$request)
+          self$ERROR(private$exception)
+        }
+      }
+      if(private$type == "POST"){
+        if(!is.null(xmlNamespaces(req$response)$ows)){
+          exception <- getNodeSet(req$response, "//ows:ExceptionText", c(ows = xmlNamespaces(req$response)$ows$uri))
+          if(length(exception)>0){
+            exception <- exception[[1]]
+            private$exception <- xmlValue(exception)
+            self$ERROR(private$exception)
+          }
+        }
+      }
+    },
+
+    #getRequest
+    getRequest = function(){
+      return(private$request)
+    },
+
+    #getRequestHeaders
+    getRequestHeaders = function(){
+      return(private$requestHeaders)
+    },
+
+    #getStatus
+    getStatus = function(){
+      return(private$status)
+    },
+
+    #getResponse
+    getResponse = function(){
+      return(private$response)
+    },
+
+    #getException
+    getException = function(){
+      return(private$exception)
+    },
+
+    #getResult
+    getResult = function(){
+      return(private$result)
+    },
+
+    #setResult
+    setResult = function(result){
+      private$result = result
+    }
+
+  )
+)