diff --git a/DESCRIPTION b/DESCRIPTION index 045306b..865c862 100644 --- a/DESCRIPTION +++ b/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 = "emmanuel.blondel1@gmail.com", comment = c(ORCID = "0000-0002-5870-5762")), person("Norbert", "Billet", role = c("ctb"))) diff --git a/NAMESPACE b/NAMESPACE index a1f16f9..d21b27d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,7 @@ export(OGCFilter) export(OWSCapabilities) export(OWSClient) export(OWSGetCapabilities) +export(OWSHttpRequest) export(OWSOperation) export(OWSOperationsMetadata) export(OWSRequest) diff --git a/R/CSWCapabilities.R b/R/CSWCapabilities.R index 14d4ec5..8ab3950 100644 --- a/R/CSWCapabilities.R +++ b/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() } ) diff --git a/R/CSWDescribeRecord.R b/R/CSWDescribeRecord.R index 8e01b4a..f919a7f 100644 --- a/R/CSWDescribeRecord.R +++ b/R/CSWDescribeRecord.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' CSWDescribeRecord <- R6Class("CSWDescribeRecord", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( name = "DescribeRecord", defaultNamespace = "csw:http://www.opengis.net/cat/csw/2.0.2" diff --git a/R/CSWGetRecordById.R b/R/CSWGetRecordById.R index eaaa898..d90d2ea 100644 --- a/R/CSWGetRecordById.R +++ b/R/CSWGetRecordById.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' CSWGetRecordById <- R6Class("CSWGetRecordById", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( xmlElement = "GetRecordById", xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"), diff --git a/R/CSWGetRecords.R b/R/CSWGetRecords.R index 06136d7..cf2a3ae 100644 --- a/R/CSWGetRecords.R +++ b/R/CSWGetRecords.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' CSWGetRecords <- R6Class("CSWGetRecords", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( xmlElement = "GetRecords", xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"), diff --git a/R/CSWHarvest.R b/R/CSWHarvest.R index e34f4b8..ff5e2ae 100644 --- a/R/CSWHarvest.R +++ b/R/CSWHarvest.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' CSWHarvest <- R6Class("CSWHarvest", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( xmlElement = "Harvest", xmlNamespace = c(csw = "http://www.opengis.net/cat/csw"), diff --git a/R/CSWTransaction.R b/R/CSWTransaction.R index 28e63dc..0964f9f 100644 --- a/R/CSWTransaction.R +++ b/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") diff --git a/R/OWSCapabilities.R b/R/OWSCapabilities.R index 76eba37..910e657 100644 --- a/R/OWSCapabilities.R +++ b/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 diff --git a/R/OWSGetCapabilities.R b/R/OWSGetCapabilities.R index d4cc27d..323b362 100644 --- a/R/OWSGetCapabilities.R +++ b/R/OWSGetCapabilities.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' OWSGetCapabilities <- R6Class("OWSGetCapabilities", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( name = "GetCapabilities" ), diff --git a/R/OWSHttpRequest.R b/R/OWSHttpRequest.R new file mode 100644 index 0000000..8f84b39 --- /dev/null +++ b/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 +#' +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 + } + + ) +) \ No newline at end of file diff --git a/R/OWSOperationsMetadata.R b/R/OWSOperationsMetadata.R index d018405..ae5a3a7 100644 --- a/R/OWSOperationsMetadata.R +++ b/R/OWSOperationsMetadata.R @@ -25,16 +25,21 @@ OWSOperationsMetadata <- R6Class("OWSOperationsMetadata", operations = list(), #fetchOperations - fetchOperations = function(xmlObj, serviceVersion){ + fetchOperations = function(xmlObj, owsVersion, serviceVersion){ namespaces <- NULL if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){ namespaces <- OWSUtils$getNamespaces(xmlObj) } namespaces <- as.data.frame(namespaces) - namespaceURI <- paste("http://www.opengis.net/ows", serviceVersion, sep ="/") opXML <- NULL if(nrow(namespaces) > 0){ + namespaceURI <- NULL + if(endsWith(namespaces[1L, "uri"], "ows")){ + namespaceURI <- paste(namespaces[1L, "uri"], owsVersion, sep ="/") + }else{ + namespaceURI <- paste(namespaces[1L, "uri"]) + } ns <- OWSUtils$findNamespace(namespaces, uri = namespaceURI) if(length(ns)>0){ opXML <- getNodeSet(xmlObj, "//ns:OperationsMetadata/ns:Operation", ns) @@ -58,8 +63,8 @@ OWSOperationsMetadata <- R6Class("OWSOperationsMetadata", } ), public = list( - initialize = function(xmlObj, serviceVersion){ - private$operations <- private$fetchOperations(xmlObj, serviceVersion) + initialize = function(xmlObj, owsVersion, serviceVersion){ + private$operations <- private$fetchOperations(xmlObj, owsVersion, serviceVersion) }, #getOperations diff --git a/R/OWSRequest.R b/R/OWSRequest.R index ea288e5..1c6405a 100644 --- a/R/OWSRequest.R +++ b/R/OWSRequest.R @@ -2,273 +2,72 @@ #' #' @docType class #' @export -#' @keywords OGC OWS Request -#' @return Object of \code{\link{R6Class}} for modelling a generic OWS request +#' @keywords OGC Service Request +#' @return Object of \code{\link{R6Class}} modelling a OWS Service Capability 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{new(xmlObj, capabilities, version, logger)}}{ +#' This method is used to instantiate a \code{OWSRequest} object #' } -#' \item{\code{getRequest()}}{ -#' Get the request payload +#' \item{\code{getName()}}{ +#' Get request name #' } -#' \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 +#' \item{\code{getFormats()}}{ +#' Get request formats #' } #' } #' -#' @note Abstract class used internally by \pkg{ows4R} +#' @note Abstract class used by \pkg{ows4R} #' #' @author Emmanuel Blondel #' OWSRequest <- R6Class("OWSRequest", - inherit = OGCAbstractObject, - #private methods + inherit = OGCAbstractObject, private = list( - xmlElement = NULL, - xmlNamespace = c(ows = "http://www.opengis.net/ows"), + + capabilities = NULL, url = NA, - type = NA, - request = NA, - requestHeaders = NA, - namedParams = list(), - contentType = "text/xml", - mimeType = "text/xml", - status = NA, - response = NA, - exception = NA, - result = NA, + version = 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) - }, + name = NA, + formats = list(), - #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)) - } + #fetchRequest + fetchRequest = function(xmlObj, version){ - #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) + children = xmlChildren(xmlObj) + name = xmlName(xmlObj) + formats = sapply(children[names(children)=="Format"], xmlValue) + names(formats) = NULL + request <- list(name = name, formats = formats) + return(request) } + ), - #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, ...) { + initialize = function(xmlObj, capabilities, version, 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$capabilities = capabilities + private$url = capabilities$getUrl() + private$version = version - private$request <- req$request - private$requestHeaders <- req$requestHeaders - private$status <- req$status - private$response <- req$response + request = private$fetchRequest(xmlObj, version) + private$name = request$name + private$formats = request$formats - 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) + #getName + getName = function(){ + return(private$name) }, - #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 + #getFormats + getFormats = function(){ + return(private$formats) } - ) ) \ No newline at end of file diff --git a/R/OWSServiceIdentification.R b/R/OWSServiceIdentification.R index 2d0410e..3cc23df 100644 --- a/R/OWSServiceIdentification.R +++ b/R/OWSServiceIdentification.R @@ -51,21 +51,26 @@ OWSServiceIdentification <- R6Class("OWSServiceIdentification", accessConstraints = NA, #fetchServiceIdentification - fetchServiceIdentification = function(xmlObj, serviceVersion){ + fetchServiceIdentification = function(xmlObj, owsVersion, serviceVersion){ namespaces <- NULL if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){ namespaces <- OWSUtils$getNamespaces(xmlObj) } namespaces <- as.data.frame(namespaces) - namespaceURI <- paste("http://www.opengis.net/ows", serviceVersion, sep ="/") serviceXML <- NULL if(nrow(namespaces) > 0){ + namespaceURI <- NULL + if(endsWith(namespaces[1L, "uri"], "ows")){ + namespaceURI <- paste(namespaces[1L, "uri"], owsVersion, sep ="/") + }else{ + namespaceURI <- paste(namespaces[1L, "uri"]) + } ns <- OWSUtils$findNamespace(namespaces, uri = namespaceURI) if(length(ns)>0){ - serviceXML <- getNodeSet(xmlObj, "//ns:Service", ns) - if(length(serviceXML)==0) serviceXML <- getNodeSet(xmlObj, "//ns:ServiceIdentification", ns) + serviceXML <- getNodeSet(xmlObj, "//ns:Service", ns) + if(length(serviceXML)==0) serviceXML <- getNodeSet(xmlObj, "//ns:ServiceIdentification", ns) } if(length(serviceXML)==0){ ns <- OWSUtils$findNamespace(namespaces, id = "ows") @@ -151,8 +156,8 @@ OWSServiceIdentification <- R6Class("OWSServiceIdentification", } ), public = list( - initialize = function(xmlObj, serviceVersion){ - serviceIdentification <- private$fetchServiceIdentification(xmlObj, serviceVersion) + initialize = function(xmlObj, owsVersion, serviceVersion){ + serviceIdentification <- private$fetchServiceIdentification(xmlObj, owsVersion, serviceVersion) private$name <- serviceIdentification$name private$title <- serviceIdentification$title private$abstract <- serviceIdentification$abstract diff --git a/R/OWSServiceProvider.R b/R/OWSServiceProvider.R index 4dd9c39..97333cb 100644 --- a/R/OWSServiceProvider.R +++ b/R/OWSServiceProvider.R @@ -8,7 +8,7 @@ #' #' @section Methods: #' \describe{ -#' \item{\code{new(xmlObj, version)}}{ +#' \item{\code{new(xmlObj, owsVersion, serviceVersion)}}{ #' This method is used to instantiate a OWSServiceProvider object #' } #' \item{\code{getProviderName()}}{ @@ -34,17 +34,22 @@ OWSServiceProvider <- R6Class("OWSServiceProvider", serviceContact = NA, #fetchServiceProvider - fetchServiceProvider = function(xmlObj, version){ + fetchServiceProvider = function(xmlObj, owsVersion, serviceVersion){ namespaces <- NULL if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){ namespaces <- OWSUtils$getNamespaces(xmlObj) } namespaces <- as.data.frame(namespaces) - namespaceURI <- paste("http://www.opengis.net/ows", version, sep ="/") serviceXML <- NULL if(nrow(namespaces) > 0){ + namespaceURI <- NULL + if(endsWith(namespaces[1L, "uri"], "ows")){ + namespaceURI <- paste(namespaces[1L, "uri"], owsVersion, sep ="/") + }else{ + namespaceURI <- paste(namespaces[1L, "uri"]) + } ns <- OWSUtils$findNamespace(namespaces, uri = namespaceURI) if(length(ns)>0){ serviceXML <- getNodeSet(xmlObj, "//ns:ServiceProvider", ns) @@ -128,8 +133,8 @@ OWSServiceProvider <- R6Class("OWSServiceProvider", } ), public = list( - initialize = function(xmlObj, version){ - serviceProvider <- private$fetchServiceProvider(xmlObj, version) + initialize = function(xmlObj, owsVersion, serviceVersion){ + serviceProvider <- private$fetchServiceProvider(xmlObj, owsVersion, serviceVersion) private$providerName <- serviceProvider$providerName private$providerSite <- serviceProvider$providerSite private$serviceContact <- serviceProvider$serviceContact diff --git a/R/WFSCapabilities.R b/R/WFSCapabilities.R index 1f4d2ff..6c390cb 100644 --- a/R/WFSCapabilities.R +++ b/R/WFSCapabilities.R @@ -61,8 +61,7 @@ WFSCapabilities <- R6Class("WFSCapabilities", #initialize initialize = function(url, version, logger = NULL) { - super$initialize(url, service = "WFS", serviceVersion = version, - owsVersion = "1.1", logger = logger) + super$initialize(url, service = "WFS", owsVersion = "1.1", serviceVersion = version, logger = logger) xmlObj <- self$getRequest()$getResponse() private$featureTypes = private$fetchFeatureTypes(xmlObj, version) }, diff --git a/R/WFSDescribeFeatureType.R b/R/WFSDescribeFeatureType.R index 00a5391..22516b4 100644 --- a/R/WFSDescribeFeatureType.R +++ b/R/WFSDescribeFeatureType.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' WFSDescribeFeatureType <- R6Class("WFSDescribeFeatureType", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( name = "DescribeFeatureType" ), diff --git a/R/WFSGetFeature.R b/R/WFSGetFeature.R index a2cc6f0..2e19b6d 100644 --- a/R/WFSGetFeature.R +++ b/R/WFSGetFeature.R @@ -18,7 +18,7 @@ #' @author Emmanuel Blondel #' WFSGetFeature <- R6Class("WFSGetFeature", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( name = "GetFeature" ), diff --git a/R/WMSCapabilities.R b/R/WMSCapabilities.R index 014ffb8..62fc867 100644 --- a/R/WMSCapabilities.R +++ b/R/WMSCapabilities.R @@ -18,6 +18,13 @@ #' \item{\code{new(url, version)}}{ #' This method is used to instantiate a WMSGetCapabilities object #' } +#' \item{\code{getRequests(pretty)}}{ +#' List the requests available. If \code{pretty} is TRUE, +#' the output will be an object of class \code{data.frame} +#' } +#' \item{\code{getRequestNames()}}{ +#' List the request names available. +#' } #' \item{\code{getLayers(pretty)}}{ #' List the layers available. If \code{pretty} is TRUE, #' the output will be an object of class \code{data.frame} @@ -36,7 +43,31 @@ WMSCapabilities <- R6Class("WMSCapabilities", inherit = OWSCapabilities, private = list( - layers = NA, + requests = list(), + layers = list(), + + #fetchRequests + fetchRequests = function(xmlObj, version){ + wmsNs <- NULL + if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){ + namespaces <- OWSUtils$getNamespaces(xmlObj) + if(!is.null(namespaces)) wmsNs <- OWSUtils$findNamespace(namespaces, id = "wms") + } + requestsXML <- list() + if(is.null(wmsNs)){ + requestsXML <- getNodeSet(xmlObj, "//Request") + }else{ + requestsXML <- getNodeSet(xmlObj, "//ns:Request", wmsNs) + } + requestsList <- list() + if(length(requestsXML)>0){ + requests <- xmlChildren(requestsXML[[1]]) + requestsList <- lapply(requests, function(x){ + OWSRequest$new(x, self, version, logger = self$loggerType) + }) + } + return(requestsList) + }, #fetchLayers fetchLayers = function(xmlObj, version){ @@ -63,12 +94,32 @@ WMSCapabilities <- R6Class("WMSCapabilities", #initialize initialize = function(url, version, logger = NULL) { - super$initialize(url, service = "WMS", serviceVersion = version, - owsVersion = "1.1", logger = logger) + super$initialize(url, service = "WMS", owsVersion = "1.1", serviceVersion = version, logger = logger) xmlObj <- self$getRequest()$getResponse() + private$requests = private$fetchRequests(xmlObj, version) private$layers = private$fetchLayers(xmlObj, version) }, + #getRequests + getRequests = function(pretty = FALSE){ + requests <- private$requests + if(pretty){ + requests <- do.call("rbind", lapply(requests, function(x){ + return(data.frame( + name = x$getName(), + formats = paste0(x$getFormats(), collapse=","), + stringsAsFactors = FALSE + )) + })) + } + return(requests) + }, + + #getRequestNames + getRequestNames = function(){ + return(names(private$requests)) + }, + #getLayers getLayers = function(pretty = FALSE){ layers <- private$layers diff --git a/R/WMSGetFeatureInfo.R b/R/WMSGetFeatureInfo.R index 2656d1d..bcce779 100644 --- a/R/WMSGetFeatureInfo.R +++ b/R/WMSGetFeatureInfo.R @@ -19,7 +19,7 @@ #' @author Emmanuel Blondel #' WMSGetFeatureInfo <- R6Class("WMSGetFeatureInfo", - inherit = OWSRequest, + inherit = OWSHttpRequest, private = list( name = "GetFeatureInfo" ), diff --git a/R/ows4R.R b/R/ows4R.R index 3306371..7f3a71b 100644 --- a/R/ows4R.R +++ b/R/ows4R.R @@ -16,7 +16,7 @@ #' Type: \tab Package\cr #' Version #' : \tab 0.2\cr -#' Date: \tab 2021-05-03\cr +#' Date: \tab 2021-06-11\cr #' License: \tab MIT\cr #' LazyLoad: \tab yes\cr #' } diff --git a/man/OWSCapabilities.Rd b/man/OWSCapabilities.Rd index 2f987f4..5dc1323 100644 --- a/man/OWSCapabilities.Rd +++ b/man/OWSCapabilities.Rd @@ -20,7 +20,7 @@ abstract class used by \pkg{ows4R} \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()}}{ diff --git a/man/OWSHttpRequest.Rd b/man/OWSHttpRequest.Rd new file mode 100644 index 0000000..c25fa90 --- /dev/null +++ b/man/OWSHttpRequest.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/OWSHttpRequest.R +\docType{class} +\name{OWSHttpRequest} +\alias{OWSHttpRequest} +\title{OWSHttpRequest} +\format{ +\code{\link{R6Class}} object. +} +\value{ +Object of \code{\link{R6Class}} for modelling a generic OWS http request +} +\description{ +OWSHttpRequest +} +\note{ +Abstract class used internally by \pkg{ows4R} +} +\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 + } +} +} + +\author{ +Emmanuel Blondel +} +\keyword{HTTP} +\keyword{OGC} +\keyword{OWS} +\keyword{Request} diff --git a/man/OWSRequest.Rd b/man/OWSRequest.Rd index 89fbe41..3881029 100644 --- a/man/OWSRequest.Rd +++ b/man/OWSRequest.Rd @@ -8,38 +8,25 @@ \code{\link{R6Class}} object. } \value{ -Object of \code{\link{R6Class}} for modelling a generic OWS request +Object of \code{\link{R6Class}} modelling a OWS Service Capability Request } \description{ OWSRequest } \note{ -Abstract class used internally by \pkg{ows4R} +Abstract class used by \pkg{ows4R} } \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{new(xmlObj, capabilities, version, logger)}}{ + This method is used to instantiate a \code{OWSRequest} object } - \item{\code{getRequest()}}{ - Get the request payload + \item{\code{getName()}}{ + Get request name } - \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 + \item{\code{getFormats()}}{ + Get request formats } } } @@ -48,5 +35,5 @@ Abstract class used internally by \pkg{ows4R} Emmanuel Blondel } \keyword{OGC} -\keyword{OWS} \keyword{Request} +\keyword{Service} diff --git a/man/OWSServiceProvider.Rd b/man/OWSServiceProvider.Rd index 2187644..f7df044 100644 --- a/man/OWSServiceProvider.Rd +++ b/man/OWSServiceProvider.Rd @@ -19,7 +19,7 @@ Abstract class used internally by \pkg{ows4R} \section{Methods}{ \describe{ - \item{\code{new(xmlObj, version)}}{ + \item{\code{new(xmlObj, owsVersion, serviceVersion)}}{ This method is used to instantiate a OWSServiceProvider object } \item{\code{getProviderName()}}{ diff --git a/man/WMSCapabilities.Rd b/man/WMSCapabilities.Rd index 47ee1de..f1eb118 100644 --- a/man/WMSCapabilities.Rd +++ b/man/WMSCapabilities.Rd @@ -24,6 +24,13 @@ recommended instead to benefit from the full set of capabilities associated to a \item{\code{new(url, version)}}{ This method is used to instantiate a WMSGetCapabilities object } + \item{\code{getRequests(pretty)}}{ + List the requests available. If \code{pretty} is TRUE, + the output will be an object of class \code{data.frame} + } + \item{\code{getRequestNames()}}{ + List the request names available. + } \item{\code{getLayers(pretty)}}{ List the layers available. If \code{pretty} is TRUE, the output will be an object of class \code{data.frame} diff --git a/man/ows4R.Rd b/man/ows4R.Rd index e89cb3d..4d46223 100644 --- a/man/ows4R.Rd +++ b/man/ows4R.Rd @@ -17,7 +17,7 @@ Web Processing Service (WPS). Type: \tab Package\cr Version : \tab 0.2\cr - Date: \tab 2021-05-03\cr + Date: \tab 2021-06-11\cr License: \tab MIT\cr LazyLoad: \tab yes\cr }