diff --git a/soap.cabal b/soap.cabal --- a/soap.cabal +++ b/soap.cabal @@ -1,10 +1,45 @@ --- Initial soap.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - name: soap -version: 0.1.0.4 +version: 0.2.0.0 synopsis: SOAP client tools -description: Tools to build SOAP clients using xml-conduit. +description: + Tools to build SOAP clients using xml-conduit. + . + A mildly-complicated example: + . + > main = do + > -- Initial one-time preparations. + > certP <- clientCert "priv/client.crt" "priv/client.key" + > transport <- initTransport "https://example.com/soap/endpoint" certP (iconv "cp-1251") + > + > -- Making queries + > activeStaff <- listStaff transport True + > print activeStaff + > + > data Person = Person Text Int deriving Show + > + > listStaff :: Transport -> Bool -> IO [Person] + > 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) + > + > parser = StreamParser $ force "no people" $ tagNoAttr "people" $ Parse.many parsePerson + > + > parsePerson = tagName "person" (requireAttr "age") $ \age -> do + > name <- Parse.content + > return $ Person name (read . unpack $ age) + . + Changelog + . + * 0.2: Switch to xml-conduit-writer for more clean serializers. + Pluggable transports. + Raw and streaming parsers. + . + * 0.1: Initial implementation, somewhat inflexible and warty, but working + with diverse services. + homepage: https://bitbucket.org/dpwiz/haskell-soap license: MIT license-file: LICENSE @@ -19,13 +54,24 @@ hs-source-dirs: src/ ghc-options: -Wall -O2 exposed-modules: - Web.SOAP.Service - Web.SOAP.Types --- other-modules: + Network.SOAP + Network.SOAP.Transport + Network.SOAP.Transport.HTTP.Conduit + Network.SOAP.Transport.Mock + Network.SOAP.Parsing.Cursor build-depends: base ==4.*, http-conduit, resourcet, tls-extra, - xml-conduit, - iconv, - text, + xml-conduit-writer, xml-conduit, xml-types, conduit, data-default, + text, bytestring, iconv, + unordered-containers, mtl + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/ + build-depends: + base, soap, hspec, HUnit, + xml-conduit, xml-conduit-writer, + text, bytestring, unordered-containers diff --git a/src/Network/SOAP.hs b/src/Network/SOAP.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP.hs @@ -0,0 +1,55 @@ +-- | A heart of the package, 'invokeWS' assembles and executes requests. + +{-# LANGUAGE OverloadedStrings, Rank2Types, FlexibleContexts #-} +module Network.SOAP + ( + invokeWS, Transport + , ResponseParser(..) + , Parser + ) where + +import Network.SOAP.Transport (Transport) + +import Data.Conduit + +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Data.Default (def) +import qualified Text.XML as XML +import Text.XML.Cursor as XML +import qualified Text.XML.Stream.Parse as XSP +import Data.XML.Types (Event) +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. + +-- | Stream parser from Text.XML.Stream.Parse. +type Parser a = Sink Event (ResourceT IO) a + +-- | Prepare data, assemble request and apply a parser to a response. +invokeWS :: (ToXML h, ToXML b) + => Transport -- ^ Configured transport to make requests with. + -> String -- ^ SOAPAction header. + -> h -- ^ SOAP Header element. () or Nothing will result in omiting the Header node. Put a comment if you need an empty element present. + -> b -- ^ SOAP Body element. + -> ResponseParser a -- ^ Parser to use on a request reply. + -> IO a +invokeWS transport soapAction header body parser = do + 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 + 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" + $ sink + +unwrapEnvelopeCursor :: Cursor -> Cursor +unwrapEnvelopeCursor c = forceCur $ c $| laxElement "Envelope" &/ laxElement "Body" + where forceCur [] = error "No SOAP Body" + forceCur (x:_) = x diff --git a/src/Network/SOAP/Parsing/Cursor.hs b/src/Network/SOAP/Parsing/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP/Parsing/Cursor.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +-- | Some helpers to parse documents with Text.XML.Cursor. + +module Network.SOAP.Parsing.Cursor + ( + -- * Extract single element + readT, readC + -- * Extract from multiple elements + , readDict, Dict + ) where + +import Text.XML +import Text.XML.Cursor + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM +import Data.Maybe (mapMaybe) + +-- ** Single-element extraction. + +-- | Grab node content by element name. +-- +-- > pair cur = (readT "fst" cur, readT "snd" cur) +readT :: Text -> Cursor -> Text +readT n c = T.concat $ c $/ laxElement n &/ content +{-# INLINE readT #-} + +-- | Extract a read-able type from a content of a node with given name. +-- +-- > age = readC "age" :: Cursor -> Integer +readC :: (Read a) => Text -> Cursor -> a +readC n c = read . T.unpack $ readT n c +{-# INLINE readC #-} + +-- ** Multi-element extraction. + +-- | Very generic type to catch server reply when you don't care about types. +type Dict = HM.HashMap Text Text + +-- | Apply an axis and extract a key-value from child elements. +-- +-- > invokeWS … (CursorParser . readDict $ laxElement "WebScaleResponse" &/ laxElement "BigDataResult") +readDict :: Axis -> Cursor -> Dict +readDict a c = extract . head $ c $/ a + 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 _ _) _ [])) = Just (n, T.empty) + dict _ = Nothing diff --git a/src/Network/SOAP/Transport.hs b/src/Network/SOAP/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP/Transport.hs @@ -0,0 +1,17 @@ +-- | This package comes with a single transport, but the your vendor's +-- SOAP implementation can behave very differently, so invokeWS can be +-- rigged to use anything that follows a simple interface. + +module Network.SOAP.Transport + ( + Transport + ) where + +import Text.XML (Document) +import Data.ByteString.Lazy.Char8 (ByteString) + +-- | Common transport type. Get a request and deliver it to an endpoint +-- specified during initialization. +type Transport = String -- ^ SOAPAction header + -> Document -- ^ XML document with a SOAP request + -> IO ByteString diff --git a/src/Network/SOAP/Transport/HTTP/Conduit.hs b/src/Network/SOAP/Transport/HTTP/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP/Transport/HTTP/Conduit.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A feature-rich http-conduit based transport allowing to deal with +-- HTTPS, authentication and other stuff using request and body processors. + +module Network.SOAP.Transport.HTTP.Conduit + ( + -- * Initialization + initTransport, initTransport_ + , EndpointURL + -- * Making a request + , RequestP, clientCert + -- * Processing a response + , BodyP, iconv + -- * Raw transport function + , runQuery + ) where + +import Text.XML +import Network.HTTP.Conduit +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 Network.SOAP.Transport + +-- | Update request record after defaults and method-specific fields are set. +type RequestP = Request (ResourceT IO) -> Request (ResourceT IO) + +-- | Process response body to make it a nice UTF8-encoded XML document. +type BodyP = ByteString -> ByteString + +-- | Web service URL. Configured at initialization, but you can tweak it +-- dynamically with a request processor. +type EndpointURL = String + +-- | Create a http-conduit transport. Use identity transformers if you +-- don't need any special treatment. +initTransport :: EndpointURL + -> RequestP + -> BodyP + -> IO Transport +initTransport url updateReq updateBody = do + manager <- newManager def + return $! runQuery manager url updateReq updateBody + +-- | Create a transport without any request and body processing. +initTransport_ :: EndpointURL -> IO Transport +initTransport_ url = initTransport url id id + +-- | Render document, submit it as a POST request and retrieve a body. +runQuery :: Manager + -> EndpointURL + -> RequestP + -> BodyP + -> Transport +runQuery manager url updateReq updateBody soapAction doc = do + let body = renderLBS def $! doc + + request <- parseUrl url + let request' = request { method = "POST" + , responseTimeout = Just 15000000 + , requestBody = RequestBodyLBS body + , requestHeaders = [ ("Content-Type", "text/xml; charset=utf-8") + , ("SOAPAction", BS.pack soapAction) + ] + } + res <- runResourceT $ httpLbs (updateReq request') manager + return . updateBody . responseBody $ res + +-- * Some common processors. + +-- | Create an IConv-based processor. +iconv :: EncodingName -> BodyP +iconv src = convertFuzzy Transliterate src "UTF-8" + +-- | Load certificate, key and make a request processor setting them. +clientCert :: FilePath -- ^ Path to a certificate. + -> FilePath -- ^ Path to a private key. + -> IO RequestP +clientCert certPath keyPath = do + cert <- TLS.fileReadCertificate certPath + pkey <- TLS.fileReadPrivateKey keyPath + + return $ \req -> req { clientCertificates = [(cert, Just pkey)] } diff --git a/src/Network/SOAP/Transport/Mock.hs b/src/Network/SOAP/Transport/Mock.hs new file mode 100644 --- /dev/null +++ b/src/Network/SOAP/Transport/Mock.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Debug transport to train your parsers without bugging real services. + +module Network.SOAP.Transport.Mock + ( + initTransport + , Handler, Handlers + , handler + , runQuery + ) where + +import Network.SOAP.Transport + +import Text.XML +import Text.XML.Writer +import Data.ByteString.Lazy.Char8 as LBS + +type Handler = Document -> IO LBS.ByteString +type Handlers = [(String, Handler)] + +-- | Wrap a collection of handlers into a transport. +initTransport :: Handlers -> IO Transport +initTransport handlers = return $ runQuery handlers + +-- | Choose and apply a handler. +runQuery :: [(String, Handler)] -> Transport +runQuery handlers soapAction doc = do + case lookup soapAction handlers of + Nothing -> error $ "No handler for action " ++ soapAction + Just handler -> handler 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" + . toXML + $ result diff --git a/src/Web/SOAP/Service.hs b/src/Web/SOAP/Service.hs deleted file mode 100644 --- a/src/Web/SOAP/Service.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, Rank2Types, KindSignatures #-} -module Web.SOAP.Service - ( SOAPSettings(..) - , invokeWS - , invokeWS' - , flowNS - ) where - -import Text.XML -import Text.XML.Cursor -import Network.HTTP.Conduit -import Control.Monad.Trans.Resource (ResourceT) - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy.Encoding as TLE -import qualified Codec.Text.IConv as IC -import Data.Monoid ((<>)) - -import Web.SOAP.Types - --- | SOAP service parameters -data SOAPSettings = SOAPSettings { - soapURL :: String, - soapNamespace :: Text, - soapCodepage :: IC.EncodingName -} deriving (Read, Show) - --- | Query a SOAP service. -invokeWS :: (ToNodes h, ToNodes i, FromCursor o) - => SOAPSettings -- ^ web service configuration - -> Text -- ^ SOAPAction header - -> h -- ^ request headers - -> i -- ^ request body - -> IO o -- ^ response -invokeWS = invokeWS' id - --- | Query a SOAP service with a customized 'Request'. -invokeWS' :: (ToNodes h, ToNodes i, FromCursor o) - => (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ request transformation to apply before sending - -> SOAPSettings -- ^ web service configuration - -> Text -- ^ SOAPAction header - -> h -- ^ request headers - -> i -- ^ request body - -> IO o -- ^ response -invokeWS' reqProc SOAPSettings{..} methodHeader h b = do - let headerNodes = toNodes h - let bodyNodes = toNodes b - - let doc = document $! envelope headerNodes bodyNodes - let body = renderLBS def $! doc - - putStrLn "Request:" - TL.putStrLn . renderText def { rsPretty = True } $! doc - - request <- parseUrl soapURL - let request' = request { method = "POST" - , responseTimeout = Just 15000000 - , requestBody = RequestBodyLBS body - , requestHeaders = [ ("Content-Type", "text/xml; charset=utf-8") - , ("SOAPAction", TE.encodeUtf8 methodHeader) - ] - } - res <- withManager $ httpLbs (reqProc request') - - let resBody = IC.convertFuzzy IC.Transliterate soapCodepage "utf-8" $ responseBody res - - case parseLBS def resBody of - Left err -> do - putStrLn $ "Error: " <> show err - putStrLn "Raw response:" - print $ responseBody res - error $ show err - - Right replyDoc -> do - putStrLn "Response:" - TL.putStrLn . renderText def { rsPretty = True } $ replyDoc - let reply = fromDocument replyDoc - print reply - return $! fromCursor reply - --- ** Request components - -document :: Element -> Document -document r = Document (Prologue [] Nothing []) r [] - -envelope :: [Node] -> [Node] -> Element -envelope header body = - Element - (soapenv "Envelope") - def - ( if null header - then [ NodeElement $! Element (soapenv "Body") def body ] - else [ NodeElement $! Element (soapenv "Header") def header - , NodeElement $! Element (soapenv "Body") def body - ] - ) - where - soapenv ln = Name ln (Just "http://schemas.xmlsoap.org/soap/envelope/") (Just "soapenv") - --- | Little helper to apply default service namespace to body nodes and their descendants. --- This removes the necessity to litter your code with {} in element names. --- --- > foo = "test" .=: [ "shmest" .= "spam" --- > , "spanish" .= "inquisition" --- > ] --- > foo' = map (flowNS $ Just "whatever") foo -flowNS :: Maybe Text -> Node -> Node -flowNS ns (NodeElement (Element (Name name Nothing prefix) as cs)) = NodeElement $ Element (Name name ns prefix) as $ map (flowNS ns) cs -- update element ns and continue -flowNS _ (NodeElement (Element name@(Name _ ns' _) as cs)) = NodeElement $ Element name as $ map (flowNS ns') cs -- switch to new namespace and continue -flowNS _ node = node -- ignore non-elements diff --git a/src/Web/SOAP/Types.hs b/src/Web/SOAP/Types.hs deleted file mode 100644 --- a/src/Web/SOAP/Types.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} - -module Web.SOAP.Types - ( ToNodes(..), (.=:), (.=) - , FromCursor(..), readT, readC, Dict, asDict - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Text.XML -import Text.XML.Cursor -import qualified Data.HashMap.Strict as HM -import Data.Maybe - --- * Prepare data - --- ** Construct elements - --- | Convert data to a Node list. --- One of the functions should be provided with others building up on it. --- --- Only use 'toNodes' to obtain a Node list. -class ToNodes a where - toElement :: a -> Element - toElement = undefined - - toElements :: a -> [Element] - toElements x = [toElement x] - - toNodes :: a -> [Node] - toNodes = map NodeElement . toElements - -instance ToNodes () where - toNodes () = [] - -instance ToNodes Text where - toNodes x = [NodeContent x] - -instance ToNodes [Node] where - toNodes = id - -instance (ToNodes a) => ToNodes (Name, a) where - toElement (n, b) = Element n def (toNodes b) - -instance (ToNodes a) => ToNodes [a] where - toNodes = concat . map toNodes - -(.=:) :: Name -> [Node] -> [Node] -n .=: ns = toNodes (n, ns) - -(.=) :: Name -> Text -> Node -n .= t = head $ toNodes (n, toNodes t) - --- * Extract data from XML cursor - -class FromCursor a where - fromCursor :: Cursor -> a - --- ** Single-element extraction. - -readT :: Text -> Cursor -> Text -readT n c = T.concat $ c $/ laxElement n &/ content -{-# INLINE readT #-} - -readC :: (Read a) => Text -> Cursor -> a -readC n c = read . T.unpack $ readT n c -{-# INLINE readC #-} - ---readContent :: (Read a) => Cursor -> a ---readContent = read . T.unpack . T.concat . content - --- ** Multi-element extraction. - -type Dict = HM.HashMap Text Text - -asDict :: Axis -> Cursor -> Dict -asDict a c = fromCursor . head $ c $// a - -instance FromCursor Dict where - fromCursor cur = HM.fromList . mapMaybe dict . map node $ cur $| child - -dict :: Node -> Maybe (Text, Text) -dict (NodeElement (Element (Name n _ _) _ [NodeContent c])) = Just (n, c) -dict (NodeElement (Element (Name n _ _) _ [])) = Just (n, T.empty) -dict _ = Nothing -{-# INLINE dict #-} - -instance (FromCursor a, FromCursor b) => FromCursor (a, b) where - fromCursor c = (fromCursor c, fromCursor c) - -instance (FromCursor a, FromCursor b, FromCursor c) => FromCursor (a, b, c) where - fromCursor c = (fromCursor c, fromCursor c, fromCursor c) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +import Network.SOAP +import Network.SOAP.Parsing.Cursor +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.Stream.Parse as Parse + +import Data.Text (Text) +import qualified Data.HashMap.Strict as HM +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Test.Hspec + +main = hspec $ do + describe "Transport.Mock" $ do + it "dispatches requests" $ do + t <- Mock.initTransport [ ("ping", const $ return "pong") ] + result <- t "ping" (document "request" empty) + result `shouldBe` "pong" + + it "generates a soap response" $ do + t <- Mock.initTransport [ ("foo", Mock.handler $ \_ -> return ())] + result <- t "foo" (document "request" empty) + result `shouldBe` "" + + context "SOAP" $ do + it "Smoke-test with RawParser" $ do + t <- Mock.initTransport [ ("ping", const $ return "pong") ] + result <- invokeWS t "ping" () () (RawParser id) + result `shouldBe` "pong" + + describe "CursorParser" $ do + let salad cur = head $ cur $/ laxElement "salad" + + let check parser = do + t <- Mock.initTransport [ ("spam", saladHandler )] + invokeWS t "spam" () () parser + + it "reads content" $ do + result <- check $ CursorParser (readT "bacon" . salad) + result `shouldBe` "many" + + it "reads and converts" $ do + result <- check $ CursorParser (readC "eggs" . salad) + result `shouldBe` (2 :: Integer) + + it "reads dict" $ do + result <- check $ CursorParser (readDict $ laxElement "salad" ) + result `shouldBe` HM.fromList [ ("bacon","many") + , ("sausage","some") + , ("eggs","2") + ] + describe "StreamParser" $ do + it "extracts stuff" $ do + let recipeParser = do + ings <- Parse.force "no salad" $ Parse.tagNoAttr "salad" $ Parse.many $ Parse.tag Just return $ \name -> do + quantity <- Parse.content + return $ RecipeEntry (nameLocalName name) quantity + return $ Recipe ings + + t <- Mock.initTransport [ ("spam", saladHandler) ] + result <- invokeWS t "spam" () () $ StreamParser recipeParser + result `shouldBe` Recipe [ RecipeEntry "sausage" "some" + , RecipeEntry "bacon" "many" + , RecipeEntry "eggs" "2" + ] + +saladHandler = Mock.handler $ \_ -> do + return . element "salad" $ do + element "sausage" ("some" :: Text) + element "bacon" ("many" :: Text) + element "eggs" (2 :: Integer) + +data RecipeEntry = RecipeEntry Text Text deriving (Eq, Show) +data Recipe = Recipe [RecipeEntry] deriving (Eq, Show)