soap 0.1.0.4 → 0.2.0.0

raw patch · 9 files changed

+388/−217 lines, 9 filesdep +HUnitdep +bytestringdep +conduitdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, bytestring, conduit, data-default, hspec, mtl, soap, xml-conduit-writer, xml-types

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• soap.cabal +57/−11
• src/Network/SOAP.hs +55/−0
• src/Network/SOAP/Parsing/Cursor.hs +52/−0
• src/Network/SOAP/Transport.hs +17/−0
• src/Network/SOAP/Transport/HTTP/Conduit.hs +89/−0
• src/Network/SOAP/Transport/Mock.hs +40/−0
• src/Web/SOAP/Service.hs +0/−114
• src/Web/SOAP/Types.hs +0/−92
• test/Main.hs +78/−0

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)] }

@@ -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

@@ -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 {<http://example.com/nonexistant/service/url.spamx>} 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

@@ -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)

@@ -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` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><Envelope><Body/></Envelope>"++    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)