improve exceptions handling #116

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ows4R
-Version: 0.3-7
-Date: 2023-11-04
+Version: 0.4
+Date: 2024-01-23
 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("Alexandre", "Bennici", role = c("ctb"), comment = c(ORCID = "0000-0003-2160-3487")),

NAMESPACE

@@ -23,6 +23,7 @@ export(OWSBoundingBox)
 export(OWSCapabilities)
 export(OWSClient)
 export(OWSCodeType)
+export(OWSException)
 export(OWSGetCapabilities)
 export(OWSHttpRequest)
 export(OWSNamespace)

R/CSWClient.R

@@ -96,6 +96,12 @@ CSWClient <- R6Class("CSWClient",
                                         user = self$getUser(), pwd = self$getPwd(), token = self$getToken(), 
                                         headers = self$getHeaders(), config = self$getConfig(),
                                         namespace = namespace, logger = self$loggerType, ...)
+       #exception handling
+       if(request$hasException()){
+         return(request$getException())
+       }
+
+       #response handling
        return(request$getResponse())
      },
 
@@ -125,6 +131,12 @@ CSWClient <- R6Class("CSWClient",
                                        headers = self$getHeaders(), config = self$getConfig(),
                                        id = id, elementSetName = elementSetName,
                                        logger = self$loggerType, ...)
+       #exception handling
+       if(request$hasException()){
+         return(request$getException())
+       }
+
+       #response handling
        return(request$getResponse())
      },
 
@@ -161,6 +173,12 @@ CSWClient <- R6Class("CSWClient",
                                     headers = self$getHeaders(), config = self$getConfig(),
                                     query = query, logger = self$loggerType, 
                                     maxRecords = maxRecordsPerRequest, ...)
+       #exception handling
+       if(firstRequest$hasException()){
+         return(firstRequest$getException())
+       }
+
+       #response handling
        records <- firstRequest$getResponse()
 
        numberOfRecordsMatched <- attr(records, "numberOfRecordsMatched")
@@ -190,6 +208,13 @@ CSWClient <- R6Class("CSWClient",
                                           query = query, logger = self$loggerType, 
                                           startPosition = nextRecord, 
                                           maxRecords = maxRecordsPerRequest, ...)
+
+         #exception handling
+         if(nextRequest$hasException()){
+           return(nextRequest$getException())
+         }
+
+         #response handling
          nextRecords <- nextRequest$getResponse()
          records <- c(records, nextRecords)
          if(length(records) == numberOfRecordsMatched) break
@@ -233,6 +258,12 @@ CSWClient <- R6Class("CSWClient",
                                          record = record, recordProperty = recordProperty, constraint = constraint, 
                                          logger = self$loggerType, ...)
 
+       #exception handling
+       if(transaction$hasException()){
+         return(transaction$getException())
+       }
+
+       #response handling
        summaryKey <- switch(type,
          "Insert" = "Inserted",
          "Update" = "Updated",
@@ -324,6 +355,12 @@ CSWClient <- R6Class("CSWClient",
                                  source = sourceUrl, resourceType = resourceType, resourceFormat = "application/xml",
                                  logger = self$loggerType)
 
+       #exception handling
+       if(harvest$hasException()){
+         return(harvest$getException())
+       }
+
+       #response handling
        harvest$setResult(FALSE)
        if(is.null(xmlNamespaces(harvest$getResponse())$csw)){
          return(harvest)

R/OWSCapabilities.R

@@ -59,13 +59,15 @@ OWSCapabilities <- R6Class("OWSCapabilities",
           element = private$xmlElement, namespacePrefix = private$xmlNamespacePrefix,
           url, service, serviceVersion, logger = logger, ...)
        if(private$request$getStatus()==200){
-          xmlObj <- private$request$getResponse()
-          private$serviceIdentification <- OWSServiceIdentification$new(xmlObj, owsVersion, serviceVersion)
-          private$serviceProvider <- OWSServiceProvider$new(xmlObj, owsVersion, serviceVersion)
-          private$operationsMetadata <- OWSOperationsMetadata$new(xmlObj, owsVersion, serviceVersion)
+        xmlObj <- private$request$getResponse()
+        if(tolower(xmlName(xmlRoot(xmlObj)))=="html"){
+          stop(sprintf("No OGC service found at URL %s", url))
+        }
+        private$serviceIdentification <- OWSServiceIdentification$new(xmlObj, owsVersion, serviceVersion)
+        private$serviceProvider <- OWSServiceProvider$new(xmlObj, owsVersion, serviceVersion)
+        private$operationsMetadata <- OWSOperationsMetadata$new(xmlObj, owsVersion, serviceVersion)
        }else{
-          self$ERROR(private$request$getException())
-          stop(private$request$getException())
+          return(private$request$getException())
        }
      },
 

R/OWSException.R

@@ -0,0 +1,62 @@
+#' OWSException
+#'
+#' @docType class
+#' @export
+#' @keywords OGC exception
+#' @return Object of \code{\link{R6Class}} modelling a OWS Service exception
+#' @format \code{\link{R6Class}} object.
+#' 
+#' @note Abstract class used by \pkg{ows4R}
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+OWSException <- R6Class("OWSException",
+  inherit = OGCAbstractObject,                       
+  private = list(
+    capabilities = NULL,
+    url = NA,
+    version = NA,
+
+    #fetchException
+    fetchException = function(xmlObj, version){
+      children = xmlChildren(xmlObj)
+      text = sapply(children[names(children)=="ExceptionText"], xmlValue)[[1]]
+      exception = list(locator = xmlGetAttr(xmlObj, "locator"), code = xmlGetAttr(xmlObj, "exceptionCode"), text = text)
+      return(exception)
+    }
+
+  ),
+  public = list(
+
+    #'@field ExceptionText exception text
+    ExceptionText = NULL,
+
+    #'@description Initializes an object of class \link{OWSException}
+    #'@param xmlObj object of class \link{XMLInternalNode-class} from \pkg{XML}
+    #'@param logger logger
+    initialize = function(xmlObj, logger = NULL){
+      super$initialize(logger = logger)
+      exception = private$fetchException(xmlObj = xmlObj, version = version)
+      self$ExceptionText = exception$text
+      self$attrs = list(exceptionCode = exception$code, locator = exception$locator)
+    },
+
+    #'@description Get exception locator
+    #'@return the exception locator, object of class \code{character}
+    getLocator = function(){
+      return(self$attrs$locator)
+    },
+
+    #'@description Get exception code
+    #'@return the exception code, object of class \code{character}
+    getCode = function(){
+      return(self$attrs$code)
+    },
+
+    #'@description Get exception text explanation
+    #'@return the exception text, object of class \code{character}
+    getText = function(){
+      return(self$ExceptionText)
+    }
+  )
+)

R/OWSHttpRequest.R

@@ -24,10 +24,10 @@ OWSHttpRequest <- R6Class("OWSHttpRequest",
     namedParams = list(),
     contentType = "text/xml",
     mimeType = "text/xml",
-    status = NA,
-    response = NA,
-    exception = NA,
-    result = NA,
+    status = NULL,
+    response = NULL,
+    exception = NULL,
+    result = NULL,
 
     user = NULL,
     pwd = NULL,
@@ -234,21 +234,23 @@ OWSHttpRequest <- R6Class("OWSHttpRequest",
       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(endsWith(private$mimeType, "xml")) if(!is.null(xmlNamespaces(req$response)$ows)){
-          exception <- getNodeSet(req$response, "//ows:ExceptionText", c(ows = xmlNamespaces(req$response)$ows$uri))
+      #exception handling
+      if(private$status != 200){ #usually a status code 400
+        exception_tmp_file = tempfile(fileext = ".xml")
+        writeBin(req$response, exception_tmp_file)
+        xmlObj = try(XML::xmlParse(exception_tmp_file), silent = TRUE)
+        if(!is(xmlObj, "try-error")) if(!is.null(xmlNamespaces(xmlObj)$ows)){
+          exception <- getNodeSet(xmlObj, "//ows:Exception", c(ows = xmlNamespaces(xmlObj)$ows$uri))
           if(length(exception)>0){
-            exception <- exception[[1]]
-            private$exception <- xmlValue(exception)
-            self$ERROR(private$exception)
+            exception <- OWSException$new(xmlObj = exception[[1]])
+            self$ERROR(sprintf("Exception [locator:'%s' code:'%s']: %s", exception$getLocator(), exception$getCode(), exception$getText()))
+            private$exception <- exception
+            private$response <- NULL
+            self$setResult(FALSE)
           }
         }
+      }else{
+        self$setResult(TRUE)
       }
     },
 
@@ -288,6 +290,12 @@ OWSHttpRequest <- R6Class("OWSHttpRequest",
       return(private$exception)
     },
 
+    #'@description Indicates if it has an exception
+    #'@return \code{TRUE} if it has an exception, \code{FALSE} otherwise
+    hasException = function(){
+      return(!is.null(private$exception))
+    },
+
     #'@description Get the result \code{TRUE} if the request is successful, \code{FALSE} otherwise
     #'@return the result, object of class \code{logical}
     getResult = function(){

R/WCSCoverageSummary.R

@@ -176,6 +176,12 @@ WCSCoverageSummary <- R6Class("WCSCoverageSummary",
       covDescription <- WCSDescribeCoverage$new(capabilities = private$capabilities, op = op, url = private$url, 
                                                 serviceVersion = private$version, coverageId = self$CoverageId, 
                                                 logger = self$loggerType)
+      #exception handling
+      if(covDescription$hasException()){
+        return(covDescription$getException())
+      }
+
+      #response handling
       xmlObj <- covDescription$getResponse()
       wcsNs <- NULL
       if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){
@@ -573,18 +579,14 @@ WCSCoverageSummary <- R6Class("WCSCoverageSummary",
                                                format = format, rangesubset = rangesubset, 
                                                gridbaseCRS = gridbaseCRS, gridtype = gridtype, gridCS = gridCS, 
                                                gridorigin = gridorigin, gridoffsets = gridoffsets, ...)
-      resp <- getCoverageRequest$getResponse()
 
-      if(!is(resp, "raw")){
-        hasError <- xmlName(xmlRoot(resp)) == "ExceptionReport"
-        if(hasError){
-          errMsg <- sprintf("Error while getting coverage: %s", xpathSApply(resp, "//ows:ExceptionText", xmlValue))
-          self$ERROR(errMsg)
-          return(NULL)
-        }
+      #exception handling
+      if(getCoverageRequest$hasException()){
+        return(getCoverageRequest$getException())
       }
 
       #response handling
+      resp <- getCoverageRequest$getResponse()
       if(substr(private$version,1,3)=="1.1"){
         #for WCS 1.1, wrap with WCSCoverage object and get data
         namespaces <- OWSUtils$getNamespaces(xmlRoot(resp))

R/WFSFeatureType.R

@@ -192,6 +192,12 @@ WFSFeatureType <- R6Class("WFSFeatureType",
       ftDescription <- WFSDescribeFeatureType$new(private$capabilities, op = op, private$url, private$version, private$name, 
                                                   user = client$getUser(), pwd = client$getPwd(), token = client$getToken(), headers = client$getHeaders(),
                                                   logger = self$loggerType)
+      #exception handling
+      if(ftDescription$hasException()){
+        return(ftDescription$getException())
+      }
+
+      #response handling
       xmlObj <- ftDescription$getResponse()
       namespaces <- OWSUtils$getNamespaces(xmlObj)
       xsdNs <- OWSUtils$findNamespace(namespaces, "XMLSchema")
@@ -287,7 +293,9 @@ WFSFeatureType <- R6Class("WFSFeatureType",
       if(is.null(self$description)){
         self$description = self$getDescription()
       }
-
+      if(is(self$description, "OWSException")){
+        stop("Feature type could not be described, aborting getting features...")
+      }
       vendorParams <- list(...)
 
       if(paging){
@@ -337,6 +345,12 @@ WFSFeatureType <- R6Class("WFSFeatureType",
       ftFeatures <- WFSGetFeature$new(private$capabilities, op = op, private$url, private$version, private$name, outputFormat = outputFormat, 
                                       user = client$getUser(), pwd = client$getPwd(), token = client$getToken(), headers = client$getHeaders(),
                                       logger = self$loggerType, ...)
+      #exception handling
+      if(ftFeatures$hasException()){
+        return(ftFeatures$getException())
+      }
+
+      #response handling
       obj <- ftFeatures$getResponse()
 
       if(length(vendorParams)>0){

R/WMSLayer.R

@@ -298,6 +298,13 @@ WMSLayer <- R6Class("WMSLayer",
         user = client$getUser(), pwd = client$getPwd(), token = client$getToken(), 
         headers = client$getHeaders(), config = client$getConfig(),
         logger = self$loggerType, ...)
+
+      #exception handling
+      if(ftFeatures$hasException()){
+        return(ftFeatures$getException())
+      }
+
+      #response handling
       obj <- ftFeatures$getResponse()
 
       #write the file to disk

R/WPSProcess.R

@@ -105,6 +105,12 @@ WPSProcess <- R6Class("WPSProcess",
       processDescription <- WPSDescribeProcess$new(capabilities = private$capabilities, op = op, private$url, private$version, private$identifier, 
                                                    user = client$getUser(), pwd = client$getPwd(), token = client$getToken(), headers = client$getHeaders(),
                                                    logger = self$loggerType)
+      #exception handling
+      if(processDescription$hasException()){
+        return(processDescription$getException())
+      }
+
+      #response handling
       xml <- processDescription$getResponse()
       processDescXML <- xmlChildren(xmlChildren(xml)[[1]])[[1]]
       processDesc <- WPSProcessDescription$new(xml = processDescXML, version = private$version)
@@ -139,6 +145,12 @@ WPSProcess <- R6Class("WPSProcess",
                                        storeExecuteResponse = storeExecuteResponse, lineage = lineage, status = lineage,
                                        user = client$getUser(), pwd = client$getPwd(), token = client$getToken(), headers = client$getHeaders(),
                                        logger = self$loggerType)
+      #exception handling
+      if(processExecute$hasException()){
+        return(processExecute$getException())
+      }
+
+      #response handling
       resp <- NULL
       executeStatus <- processExecute$getStatus()
       if(executeStatus == 200){