diff --git a/soap.cabal b/soap.cabal --- a/soap.cabal +++ b/soap.cabal @@ -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 diff --git a/src/Network/SOAP.hs b/src/Network/SOAP.hs --- a/src/Network/SOAP.hs +++ b/src/Network/SOAP.hs @@ -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 diff --git a/src/Network/SOAP/Exception.hs b/src/Network/SOAP/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP/Exception.hs @@ -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 diff --git a/src/Network/SOAP/Parsing/Cursor.hs b/src/Network/SOAP/Parsing/Cursor.hs --- a/src/Network/SOAP/Parsing/Cursor.hs +++ b/src/Network/SOAP/Parsing/Cursor.hs @@ -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 diff --git a/src/Network/SOAP/Parsing/Stream.hs b/src/Network/SOAP/Parsing/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP/Parsing/Stream.hs @@ -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 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 @@ -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 _ = "" -- | Load certificate, key and make a request processor setting them. clientCert :: FilePath -- ^ Path to a certificate. diff --git a/src/Network/SOAP/Transport/Mock.hs b/src/Network/SOAP/Transport/Mock.hs --- a/src/Network/SOAP/Transport/Mock.hs +++ b/src/Network/SOAP/Transport/Mock.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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` "" + result `shouldBe` "" 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" + ]