{-# LANGUAGE BangPatterns, CPP, OverloadedStrings, Rank2Types, FlexibleContexts #-}
module Network.SOAP
(
invokeWS, Transport
, runResponseParser
, ResponseParser(..)
, Parser
, SOAPFault(..), SOAPParsingError(..)
) where
import Network.SOAP.Transport (Transport)
import Network.SOAP.Exception
import qualified Control.Exception as E
import Data.Conduit
#if MIN_VERSION_conduit(1,1,0)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
#endif
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Default (def)
import Data.Void (Void)
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)
import qualified Data.Text as T
import Network.SOAP.Parsing.Stream (laxTag)
data ResponseParser a = StreamParser (Parser a)
| CursorParser (XML.Cursor -> a)
| DocumentParser (XML.Document -> a)
| RawParser (LBS.ByteString -> a)
type Parser a = ConduitM Event Void (ResourceT IO) a
invokeWS :: (ToXML h, ToXML b)
=> Transport
-> String
-> h
-> b
-> ResponseParser a
-> IO a
invokeWS :: Transport -> String -> h -> b -> ResponseParser a -> IO a
invokeWS transport :: Transport
transport soapAction :: String
soapAction header :: h
header body :: b
body parser :: ResponseParser a
parser =
Transport
transport String
soapAction Document
doc IO ByteString -> (ByteString -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ResponseParser a -> ByteString -> IO a
forall a. ResponseParser a -> ByteString -> IO a
runResponseParser ResponseParser a
parser
where
!doc :: Document
doc = h -> b -> Document
forall h b. (ToXML h, ToXML b) => h -> b -> Document
soap h
header b
body
runResponseParser :: ResponseParser a -> LBS.ByteString -> IO a
runResponseParser :: ResponseParser a -> ByteString -> IO a
runResponseParser parser :: ResponseParser a
parser lbs :: ByteString
lbs =
case ResponseParser a
parser of
StreamParser sink :: Parser a
sink ->
ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a)
-> (ConduitT () Void (ResourceT IO) a -> ResourceT IO a)
-> ConduitT () Void (ResourceT IO) a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void (ResourceT IO) a -> ResourceT IO a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (ResourceT IO) a -> IO a)
-> ConduitT () Void (ResourceT IO) a -> IO a
forall a b. (a -> b) -> a -> b
$
Conduit () (ResourceT IO) Event
-> Parser a -> ConduitT () Void (ResourceT IO) a
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitM b c m r -> ConduitM a c m r
fuse (ParseSettings -> ByteString -> Conduit () (ResourceT IO) Event
forall (m :: * -> *) i.
MonadThrow m =>
ParseSettings -> ByteString -> ConduitT i Event m ()
XSP.parseLBS ParseSettings
forall a. Default a => a
def ByteString
lbs) (Parser a -> Parser a
forall a. Parser a -> Parser a
unwrapEnvelopeSink Parser a
sink)
CursorParser func :: Cursor -> a
func ->
(Cursor -> a) -> Cursor -> IO a
forall a. (Cursor -> a) -> Cursor -> IO a
checkFault Cursor -> a
func (Cursor -> IO a) -> (Document -> Cursor) -> Document -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Cursor
unwrapEnvelopeCursor
(Cursor -> Cursor) -> (Document -> Cursor) -> Document -> Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Cursor
XML.fromDocument
(Document -> IO a) -> Document -> IO a
forall a b. (a -> b) -> a -> b
$ ParseSettings -> ByteString -> Document
XML.parseLBS_ ParseSettings
forall a. Default a => a
def ByteString
lbs
DocumentParser func :: Document -> a
func ->
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> (Document -> a) -> Document -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> a
func (Document -> IO a) -> Document -> IO a
forall a b. (a -> b) -> a -> b
$ ParseSettings -> ByteString -> Document
XML.parseLBS_ ParseSettings
forall a. Default a => a
def ByteString
lbs
RawParser func :: ByteString -> a
func ->
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> (ByteString -> a) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
func (ByteString -> IO a) -> ByteString -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString
lbs
unwrapEnvelopeSink :: Parser a -> Parser a
unwrapEnvelopeSink :: Parser a -> Parser a
unwrapEnvelopeSink sink :: Parser a
sink = String -> ConduitT Event Void (ResourceT IO) (Maybe a) -> Parser a
forall (m :: * -> *) a.
MonadThrow m =>
String -> m (Maybe a) -> m a
XSP.force "No SOAP Envelope" (ConduitT Event Void (ResourceT IO) (Maybe a) -> Parser a)
-> ConduitT Event Void (ResourceT IO) (Maybe a) -> Parser a
forall a b. (a -> b) -> a -> b
$ Text -> Parser a -> ConduitT Event Void (ResourceT IO) (Maybe a)
forall (m :: * -> *) a.
MonadThrow m =>
Text -> ConduitM Event Void m a -> ConduitM Event Void m (Maybe a)
laxTag "Envelope"
(Parser a -> ConduitT Event Void (ResourceT IO) (Maybe a))
-> Parser a -> ConduitT Event Void (ResourceT IO) (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> ConduitT Event Void (ResourceT IO) (Maybe a) -> Parser a
forall (m :: * -> *) a.
MonadThrow m =>
String -> m (Maybe a) -> m a
XSP.force "No SOAP Body" (ConduitT Event Void (ResourceT IO) (Maybe a) -> Parser a)
-> ConduitT Event Void (ResourceT IO) (Maybe a) -> Parser a
forall a b. (a -> b) -> a -> b
$ Text -> Parser a -> ConduitT Event Void (ResourceT IO) (Maybe a)
forall (m :: * -> *) a.
MonadThrow m =>
Text -> ConduitM Event Void m a -> ConduitM Event Void m (Maybe a)
laxTag "Body"
(Parser a -> ConduitT Event Void (ResourceT IO) (Maybe a))
-> Parser a -> ConduitT Event Void (ResourceT IO) (Maybe a)
forall a b. (a -> b) -> a -> b
$ Parser a
sink
unwrapEnvelopeCursor :: Cursor -> Cursor
unwrapEnvelopeCursor :: Cursor -> Cursor
unwrapEnvelopeCursor c :: Cursor
c = [Cursor] -> Cursor
forall p. [p] -> p
forceCur ([Cursor] -> Cursor) -> [Cursor] -> Cursor
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> a) -> a
$| Text -> Cursor -> [Cursor]
laxElement "Envelope" (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Text -> Cursor -> [Cursor]
laxElement "Body"
where forceCur :: [p] -> p
forceCur [] = SOAPParsingError -> p
forall a e. Exception e => e -> a
E.throw (SOAPParsingError -> p) -> SOAPParsingError -> p
forall a b. (a -> b) -> a -> b
$ String -> SOAPParsingError
SOAPParsingError "No SOAP Body"
forceCur (x :: p
x:_) = p
x
checkFault :: (XML.Cursor -> a) -> Cursor -> IO a
checkFault :: (Cursor -> a) -> Cursor -> IO a
checkFault fun :: Cursor -> a
fun c :: Cursor
c = [Cursor] -> IO a
tryCur ([Cursor] -> IO a) -> [Cursor] -> IO a
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Cursor -> [Cursor]
laxElement "Fault"
where
tryCur :: [Cursor] -> IO a
tryCur [] = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! Cursor -> a
fun Cursor
c
tryCur (f :: Cursor
f:_) = SOAPFault -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (SOAPFault -> IO a) -> SOAPFault -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> SOAPFault
SOAPFault (Text -> Cursor -> Text
peek "faultcode" Cursor
f) (Text -> Cursor -> Text
peek "faultstring" Cursor
f) (Text -> Cursor -> Text
peek "detail" Cursor
f)
peek :: Text -> Cursor -> Text
peek name :: Text
name cur :: Cursor
cur = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$! Cursor
cur Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Cursor -> [Cursor]
laxElement Text
name (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content