soap 0.2.0.4 → 0.2.1.1
raw patch · 4 files changed
+50/−36 lines, 4 filesdep ~http-conduit
Dependency ranges changed: http-conduit
Files
- soap.cabal +20/−6
- src/Network/SOAP.hs +17/−2
- src/Network/SOAP/Exception.hs +9/−8
- src/Network/SOAP/Transport/HTTP/Conduit.hs +4/−20
soap.cabal view
@@ -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
src/Network/SOAP.hs view
@@ -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
src/Network/SOAP/Exception.hs view
@@ -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
src/Network/SOAP/Transport/HTTP/Conduit.hs view
@@ -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.