{-# 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 :: forall h b a.
(ToXML h, ToXML b) =>
Transport -> String -> h -> b -> ResponseParser a -> IO a
invokeWS Transport
transport String
soapAction h
header b
body 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 :: forall a. ResponseParser a -> ByteString -> IO a
runResponseParser ResponseParser a
parser ByteString
lbs =
case ResponseParser a
parser of
StreamParser 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
$
ConduitT () Event (ResourceT IO) ()
-> Parser a -> ConduitT () Void (ResourceT IO) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
fuse (ParseSettings -> ByteString -> ConduitT () Event (ResourceT IO) ()
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 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 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 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 :: forall a. Parser a -> Parser a
unwrapEnvelopeSink 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 String
"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 Text
"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 String
"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 Text
"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 Cursor
c = [Cursor] -> Cursor
forall {a}. [a] -> a
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 Text
"Envelope" (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Text -> Cursor -> [Cursor]
laxElement Text
"Body"
where forceCur :: [a] -> a
forceCur [] = SOAPParsingError -> a
forall a e. Exception e => e -> a
E.throw (SOAPParsingError -> a) -> SOAPParsingError -> a
forall a b. (a -> b) -> a -> b
$ String -> SOAPParsingError
SOAPParsingError String
"No SOAP Body"
forceCur (a
x:[a]
_) = a
x
checkFault :: (XML.Cursor -> a) -> Cursor -> IO a
checkFault :: forall a. (Cursor -> a) -> Cursor -> IO a
checkFault Cursor -> a
fun 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 Text
"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 (Cursor
f:[Cursor]
_) = 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 Text
"faultcode" Cursor
f) (Text -> Cursor -> Text
peek Text
"faultstring" Cursor
f) (Text -> Cursor -> Text
peek Text
"detail" Cursor
f)
peek :: Text -> Cursor -> Text
peek Text
name 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