soap 0.2.0.0 → 0.2.0.2
raw patch · 8 files changed
+217/−28 lines, 8 filesdep +http-types
Dependencies added: http-types
Files
- soap.cabal +7/−5
- src/Network/SOAP.hs +7/−5
- src/Network/SOAP/Exception.hs +39/−0
- src/Network/SOAP/Parsing/Cursor.hs +11/−2
- src/Network/SOAP/Parsing/Stream.hs +50/−0
- src/Network/SOAP/Transport/HTTP/Conduit.hs +34/−4
- src/Network/SOAP/Transport/Mock.hs +18/−4
- test/Main.hs +51/−8
soap.cabal view
@@ -1,5 +1,5 @@ name: soap-version: 0.2.0.0+version: 0.2.0.2 synopsis: SOAP client tools description: Tools to build SOAP clients using xml-conduit.@@ -21,9 +21,9 @@ > listStaff t active = invokeWS t "urn:dummy:listStaff" () body parser > where > body = element "request" $ element "listStaff" $ do- > element "active" $ toXML active- > element "order" "age"- > element "limit" $ toXML (10 :: Int)+ > element "active" active+ > element "order" $ T.pack "age"+ > element "limit" (10 :: Int) > > parser = StreamParser $ force "no people" $ tagNoAttr "people" $ Parse.many parsePerson >@@ -56,12 +56,14 @@ exposed-modules: Network.SOAP Network.SOAP.Transport+ Network.SOAP.Exception Network.SOAP.Transport.HTTP.Conduit Network.SOAP.Transport.Mock Network.SOAP.Parsing.Cursor+ Network.SOAP.Parsing.Stream build-depends: base ==4.*,- http-conduit, resourcet, tls-extra,+ http-conduit, resourcet, tls-extra, http-types, xml-conduit-writer, xml-conduit, xml-types, conduit, data-default, text, bytestring, iconv, unordered-containers, mtl
src/Network/SOAP.hs view
@@ -22,9 +22,10 @@ import Text.XML.Writer (ToXML, soap) -- | Different parsing modes available to extract reply contents.-data ResponseParser a = StreamParser (Parser a) -- ^ Streaming parser from Text.XML.Stream.Parse- | CursorParser (XML.Cursor -> a) -- ^ XPath-like parser from Text.XML.Cursor- | RawParser (LBS.ByteString -> a) -- ^ Work with a raw bytestring.+data ResponseParser a = StreamParser (Parser a) -- ^ Streaming parser from Text.XML.Stream.Parse+ | CursorParser (XML.Cursor -> a) -- ^ XPath-like parser from Text.XML.Cursor+ | DocumentParser (XML.Document -> a) -- ^ Parse raw XML document.+ | RawParser (LBS.ByteString -> a) -- ^ Work with a raw bytestring. -- | Stream parser from Text.XML.Stream.Parse. type Parser a = Sink Event (ResourceT IO) a@@ -42,11 +43,12 @@ case parser of StreamParser sink -> runResourceT $ XSP.parseLBS def lbs $$ unwrapEnvelopeSink sink CursorParser func -> return . func . unwrapEnvelopeCursor . XML.fromDocument $ XML.parseLBS_ def lbs+ DocumentParser func -> return . func $ XML.parseLBS_ def lbs RawParser func -> return . func $ lbs unwrapEnvelopeSink :: Parser a -> Parser a-unwrapEnvelopeSink sink = XSP.force "No SOAP Envelope" $ XSP.tagNoAttr "Envelope"- $ XSP.force "No SOAP Body" $ XSP.tagNoAttr "Body"+unwrapEnvelopeSink sink = XSP.force "No SOAP Envelope" $ XSP.tagNoAttr "{http://schemas.xmlsoap.org/soap/envelope/}Envelope"+ $ XSP.force "No SOAP Body" $ XSP.tagNoAttr "{http://schemas.xmlsoap.org/soap/envelope/}Body" $ sink unwrapEnvelopeCursor :: Cursor -> Cursor
+ src/Network/SOAP/Exception.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}++module Network.SOAP.Exception+ ( SOAPFault(..)+ , extractSoapFault+ ) where++import Control.Exception as E+import Data.Typeable+import Text.XML (Document)+import Text.XML.Cursor+import qualified Data.Text as T++-- | Exception to be thrown when transport encounters an exception that is+-- acutally a SOAP Fault.+data SOAPFault = SOAPFault { faultCode :: T.Text+ , faultString :: T.Text+ , faultDetail :: T.Text+ } deriving (Eq, Show, Typeable)++instance Exception SOAPFault++-- | Try to find a SOAP Fault in a document.+extractSoapFault :: Document -> Maybe SOAPFault+extractSoapFault doc =+ case cur' of+ [] -> Nothing+ cur:_ -> Just $ SOAPFault { faultCode = code cur+ , faultString = string cur+ , faultDetail = 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
src/Network/SOAP/Parsing/Cursor.hs view
@@ -7,9 +7,11 @@ -- * Extract single element readT, readC -- * Extract from multiple elements- , readDict, Dict+ , Dict, readDict, dictBy ) where +import Network.SOAP (ResponseParser(CursorParser))+ import Text.XML import Text.XML.Cursor @@ -47,6 +49,13 @@ where extract cur = HM.fromList . mapMaybe dict . map node $ cur $| child - dict (NodeElement (Element (Name n _ _) _ [NodeContent c])) = Just (n, c)+ dict (NodeElement (Element (Name n _ _) _ [NodeContent cont])) = Just (n, cont) dict (NodeElement (Element (Name n _ _) _ [])) = Just (n, T.empty) dict _ = Nothing++-- | Simple parser to grab a flat response by an element name.+--+-- > result <- invokeWS … (dictBy "BigDataResult")+-- > case HM.lookup "SuccessError" result of …+dictBy :: T.Text -> ResponseParser Dict+dictBy n = CursorParser . readDict $ anyElement &/ laxElement n
+ src/Network/SOAP/Parsing/Stream.hs view
@@ -0,0 +1,50 @@+-- | Collection of helpers to use with Text.XML.Stream.Parse parsers.+--+-- > let sink = flaxTag "MethodNameResponse"+-- > $ flaxTag "MethodNameResult" $ do+-- > info <- flaxTag "Info" $ do+-- > q <- readTag "quantity"+-- > b <- readTag "balance"+-- > return $ Info q b+-- > rc <- readTag "ResponseCode"+-- > return (rc, info)++module Network.SOAP.Parsing.Stream+ ( -- * Tags+ laxTag, flaxTag+ -- * Content+ , laxContent, flaxContent+ , readContent, readTag+ -- * Types to use in custom parser sinks+ , Sink, Event+ ) where++import Data.Conduit+import Data.XML.Types (Event)++import Text.XML (Name(..))+import qualified Text.XML.Stream.Parse as XSP++import Data.Text (Text, unpack)++-- | Namespace- and attribute- ignorant tagNoAttr.+laxTag :: (MonadThrow m) => Text -> Sink Event m a -> Sink Event m (Maybe a)+laxTag ln = XSP.tagPredicate ((== ln) . nameLocalName) XSP.ignoreAttrs . const++-- | Non-maybe version of laxTag/tagNoAttr.+flaxTag :: (MonadThrow m) => Text -> Sink Event m a -> Sink Event m a+flaxTag ln s = XSP.force ("got no " ++ show ln) $ laxTag ln s++laxContent :: (MonadThrow m) => Text -> Sink Event m (Maybe Text)+laxContent ln = laxTag ln XSP.content++flaxContent :: (MonadThrow m) => Text -> Sink Event m Text+flaxContent ln = flaxTag ln XSP.content++-- | Unpack and read a current tag content.+readContent :: (Read a, MonadThrow m) => Sink Event m a+readContent = fmap (read . unpack) XSP.content++-- | Unpack and read tag content by local name.+readTag :: (Read a, MonadThrow m) => Text -> Sink Event m a+readTag n = flaxTag n readContent
src/Network/SOAP/Transport/HTTP/Conduit.hs view
@@ -9,24 +9,28 @@ initTransport, initTransport_ , EndpointURL -- * Making a request- , RequestP, clientCert+ , RequestP, clientCert, traceRequest -- * Processing a response- , BodyP, iconv+ , BodyP, iconv, traceBody -- * Raw transport function , runQuery ) where import Text.XML import Network.HTTP.Conduit+import Network.HTTP.Types(Status(..)) import Control.Monad.Trans.Resource import Codec.Text.IConv (EncodingName, convertFuzzy, Fuzzy(Transliterate)) import qualified Network.TLS.Extra as TLS import qualified Data.ByteString.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)+import Data.ByteString.Lazy.Char8 (ByteString, unpack, fromChunks) +import Debug.Trace (trace)+import Control.Exception as E 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)@@ -69,14 +73,40 @@ , ("SOAPAction", BS.pack soapAction) ] }- res <- runResourceT $ httpLbs (updateReq request') manager+ res <- (runResourceT $ httpLbs (updateReq request') manager) `E.catch` handle500 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. -- | Create an IConv-based processor. iconv :: EncodingName -> BodyP iconv src = convertFuzzy Transliterate src "UTF-8"++-- | Show a debug dump of a response body.+traceBody :: BodyP+traceBody lbs = trace "response:" $ trace (unpack lbs) lbs++-- | Show a debug dump of a request body.+traceRequest :: RequestP+traceRequest r = trace "request:" $ trace (showBody $ requestBody r) r+ where+ showBody (RequestBodyLBS body) = unpack body+ showBody _ = "<dynamic body>" -- | Load certificate, key and make a request processor setting them. clientCert :: FilePath -- ^ Path to a certificate.
src/Network/SOAP/Transport/Mock.hs view
@@ -5,7 +5,7 @@ ( initTransport , Handler, Handlers- , handler+ , handler, fault , runQuery ) where @@ -14,6 +14,7 @@ import Text.XML import Text.XML.Writer import Data.ByteString.Lazy.Char8 as LBS+import Data.Text (Text) type Handler = Document -> IO LBS.ByteString type Handlers = [(String, Handler)]@@ -27,14 +28,27 @@ runQuery handlers soapAction doc = do case lookup soapAction handlers of Nothing -> error $ "No handler for action " ++ soapAction- Just handler -> handler doc+ Just h -> h doc -- | Process a Document and wrap result in a SOAP Envelope. handler :: (ToXML a) => (Document -> IO a) -> Handler handler h doc = do result <- h doc return . renderLBS def- . document "Envelope"- . element "Body"+ . document (sname "Envelope")+ . element (sname "Body") . toXML $ result+ where+ sname n = Name n (Just "http://schemas.xmlsoap.org/soap/envelope/") (Just "soapenv")++-- | Emulate a SOAP fault.+fault :: Text -- ^ SOAP Fault code (e.g. «soap:Server»)+ -> Text -- ^ Fault string+ -> Text -- ^ Fault detail+ -> Handler+fault c s d = handler . const . return $+ element "Fault" $ do+ element "faultcode" c+ element "faultstring" s+ element "detail" d
test/Main.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} import Network.SOAP+import Network.SOAP.Exception import Network.SOAP.Parsing.Cursor+import Network.SOAP.Parsing.Stream import qualified Network.SOAP.Transport.Mock as Mock import qualified Network.SOAP.Transport.HTTP.Conduit as HTTP import Text.XML import Text.XML.Writer-import Text.XML.Cursor hiding (element)+import Text.XML.Cursor as Cur hiding (element) import Text.XML.Stream.Parse as Parse -import Data.Text (Text)+import Data.Text (Text)+import qualified Data.Text as T import qualified Data.HashMap.Strict as HM import qualified Data.ByteString.Lazy.Char8 as LBS @@ -24,7 +27,7 @@ it "generates a soap response" $ do t <- Mock.initTransport [ ("foo", Mock.handler $ \_ -> return ())] result <- t "foo" (document "request" empty)- result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><Envelope><Body/></Envelope>"+ result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><soapenv:Envelope xmlns:soapenv=\"http://schemas.xmlsoap.org/soap/envelope/\"><soapenv:Body/></soapenv:Envelope>" context "SOAP" $ do it "Smoke-test with RawParser" $ do@@ -61,13 +64,48 @@ return $ RecipeEntry (nameLocalName name) quantity return $ Recipe ings - t <- Mock.initTransport [ ("spam", saladHandler) ]+ t <- spamTransport result <- invokeWS t "spam" () () $ StreamParser recipeParser- result `shouldBe` Recipe [ RecipeEntry "sausage" "some"- , RecipeEntry "bacon" "many"- , RecipeEntry "eggs" "2"- ]+ result `shouldBe` saladRecipe + it "extracts using lax helpers" $ do+ let recipeParser = flaxTag "salad" $ do+ s <- flaxContent "sausage"+ b <- laxContent "bacon"+ e <- readTag "eggs"+ return $ Recipe [ RecipeEntry "sausage" s+ , RecipeEntry "bacon" $ maybe "" id b+ , RecipeEntry "eggs" . T.pack $ show (e :: Int)+ ]+ result <- invokeSpam $ StreamParser recipeParser+ result `shouldBe` saladRecipe++ describe "DocumentParser" $ do+ it "gives out raw document" $ do+ let poach doc = read . T.unpack . T.concat+ $ fromDocument doc+ $// laxElement "eggs"+ &/ Cur.content+ t <- spamTransport+ result <- invokeWS t "spam" () () $ DocumentParser poach+ result `shouldBe` (2 :: Int)++ describe "Exception" $ do+ it "parses a SOAP Fault document" $ do+ t <- Mock.initTransport [ ("crash", Mock.fault "soap:Server" "The server made a boo boo." "") ]+ lbs <- t "crash" (document "request" empty)+ let Just e = extractSoapFault . parseLBS_ def $ lbs+ e `shouldBe` SOAPFault { faultCode = "soap:Server"+ , faultString = "The server made a boo boo."+ , faultDetail = ""+ }++invokeSpam parser = do+ t <- spamTransport+ invokeWS t "spam" () () parser++spamTransport = Mock.initTransport [ ("spam", saladHandler) ]+ saladHandler = Mock.handler $ \_ -> do return . element "salad" $ do element "sausage" ("some" :: Text)@@ -76,3 +114,8 @@ data RecipeEntry = RecipeEntry Text Text deriving (Eq, Show) data Recipe = Recipe [RecipeEntry] deriving (Eq, Show)++saladRecipe = Recipe [ RecipeEntry "sausage" "some"+ , RecipeEntry "bacon" "many"+ , RecipeEntry "eggs" "2"+ ]