diff --git a/soap.cabal b/soap.cabal --- a/soap.cabal +++ b/soap.cabal @@ -1,5 +1,5 @@ name: soap -version: 0.2.0.4 +version: 0.2.1.1 synopsis: SOAP client tools description: Tools to build SOAP clients using xml-conduit. @@ -62,11 +62,25 @@ Network.SOAP.Parsing.Cursor Network.SOAP.Parsing.Stream build-depends: - base ==4.*, - http-conduit >=1.9.0, resourcet, tls-extra, http-types, configurator, - xml-conduit-writer, xml-conduit, xml-types, conduit, data-default, - text, bytestring, iconv, - unordered-containers, mtl + base ==4.* + , http-conduit ==1.9.* + , resourcet + , tls-extra + , http-types + + , configurator + + , xml-conduit-writer + , xml-conduit + , xml-types + , conduit + , data-default + + , text + , bytestring + , iconv + , unordered-containers + , mtl test-suite tests type: exitcode-stdio-1.0 diff --git a/src/Network/SOAP.hs b/src/Network/SOAP.hs --- a/src/Network/SOAP.hs +++ b/src/Network/SOAP.hs @@ -3,12 +3,18 @@ {-# LANGUAGE OverloadedStrings, Rank2Types, FlexibleContexts #-} module Network.SOAP ( + -- * Requests invokeWS, Transport + -- * Response parsing , ResponseParser(..) , Parser + -- * Exceptions + , SOAPFault(..), SOAPParsingError(..) ) where import Network.SOAP.Transport (Transport) +import Network.SOAP.Exception +import qualified Control.Exception as E import Data.Conduit @@ -20,6 +26,7 @@ import qualified Text.XML.Stream.Parse as XSP import Data.XML.Types (Event) import Text.XML.Writer (ToXML, soap) +import qualified Data.Text as T -- | Different parsing modes available to extract reply contents. data ResponseParser a = StreamParser (Parser a) -- ^ Streaming parser from Text.XML.Stream.Parse @@ -42,7 +49,7 @@ lbs <- transport soapAction $! soap header body case parser of StreamParser sink -> runResourceT $ XSP.parseLBS def lbs $$ unwrapEnvelopeSink sink - CursorParser func -> return . func . unwrapEnvelopeCursor . XML.fromDocument $ XML.parseLBS_ def lbs + CursorParser func -> checkFault func . unwrapEnvelopeCursor . XML.fromDocument $ XML.parseLBS_ def lbs DocumentParser func -> return . func $ XML.parseLBS_ def lbs RawParser func -> return . func $ lbs @@ -53,5 +60,13 @@ unwrapEnvelopeCursor :: Cursor -> Cursor unwrapEnvelopeCursor c = forceCur $ c $| laxElement "Envelope" &/ laxElement "Body" - where forceCur [] = error "No SOAP Body" + where forceCur [] = E.throw $ SOAPParsingError "No SOAP Body" forceCur (x:_) = x + +checkFault :: (XML.Cursor -> a) -> Cursor -> IO a +checkFault fun c = tryCur $ c $/ laxElement "Fault" + where + tryCur [] = return $! fun c + tryCur (f:_) = E.throwIO $ SOAPFault (peek "faultcode" f) (peek "faultstring" f) (peek "detail" f) + + peek name cur = T.concat $! cur $/ laxElement name &/ content diff --git a/src/Network/SOAP/Exception.hs b/src/Network/SOAP/Exception.hs --- a/src/Network/SOAP/Exception.hs +++ b/src/Network/SOAP/Exception.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Network.SOAP.Exception - ( SOAPFault(..) - , extractSoapFault + ( SOAPParsingError(..) + , SOAPFault(..), extractSoapFault ) where import Control.Exception as E @@ -11,6 +11,9 @@ import Text.XML.Cursor import qualified Data.Text as T +data SOAPParsingError = SOAPParsingError String deriving (Show, Typeable) +instance Exception SOAPParsingError + -- | Exception to be thrown when transport encounters an exception that is -- acutally a SOAP Fault. data SOAPFault = SOAPFault { faultCode :: T.Text @@ -25,15 +28,13 @@ extractSoapFault doc = case cur' of [] -> Nothing - cur:_ -> Just $ SOAPFault { faultCode = code cur - , faultString = string cur - , faultDetail = detail cur + cur:_ -> Just $ SOAPFault { faultCode = peek "faultcode" cur + , faultString = peek "faultstring" cur + , faultDetail = peek "detail" cur } where cur' = fromDocument doc $| laxElement "Envelope" &/ laxElement "Body" &/ laxElement "Fault" - code cur = T.concat $ cur $/ laxElement "faultcode" &/ content - string cur = T.concat $ cur $/ laxElement "faultstring" &/ content - detail cur = T.concat $ cur $/ laxElement "detail" &/ content + peek name cur = T.concat $ cur $/ laxElement name &/ content diff --git a/src/Network/SOAP/Transport/HTTP/Conduit.hs b/src/Network/SOAP/Transport/HTTP/Conduit.hs --- a/src/Network/SOAP/Transport/HTTP/Conduit.hs +++ b/src/Network/SOAP/Transport/HTTP/Conduit.hs @@ -18,7 +18,6 @@ import Text.XML import Network.HTTP.Conduit -import Network.HTTP.Types(Status(..)) import Control.Monad.Trans.Resource import Data.Configurator (require, lookupDefault) @@ -28,14 +27,13 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString, unpack, fromChunks) +import Data.ByteString.Lazy.Char8 (ByteString, unpack) import Debug.Trace (trace) -import Control.Exception as E +--import Control.Exception as E import Data.Monoid ((<>)) import Network.SOAP.Transport -import Network.SOAP.Exception -- | Update request record after defaults and method-specific fields are set. type RequestP = Request (ResourceT IO) -> Request (ResourceT IO) @@ -108,24 +106,10 @@ , requestHeaders = [ ("Content-Type", "text/xml; charset=utf-8") , ("SOAPAction", BS.pack soapAction) ] + , checkStatus = \_ _ _ -> Nothing } - res <- (runResourceT $ httpLbs (updateReq request') manager) `E.catch` handle500 + res <- (runResourceT $ httpLbs (updateReq request') manager) return . updateBody . responseBody $ res - - where - handle500 :: HttpException -> IO a - handle500 e@(StatusCodeException (Status 500 _) hs _) = handleSoapFault e hs - handle500 e = E.throw e - - handleSoapFault e hs = - case lookup "X-Response-Body-Start" hs of - Nothing -> E.throw e - Just bs -> do - case parseLBS def $ fromChunks [bs] of - Left _ -> E.throw e - Right sfdoc -> case extractSoapFault sfdoc of - Nothing -> E.throw e - Just sf -> E.throw sf -- * Some common processors.