-- | A heart of the package, 'invokeWS' assembles and executes requests.

{-# LANGUAGE BangPatterns, CPP, OverloadedStrings, Rank2Types, FlexibleContexts #-}
module Network.SOAP
    (
    -- * Requests
      invokeWS, Transport
    -- * Response parsing
    , runResponseParser
    , ResponseParser(..)
    , Parser
    -- * Exceptions
    , 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)

-- | 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
                      | 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 = ConduitM Event Void (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 :: 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 a b. IO a -> (a -> IO b) -> IO b
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 a. 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 a. 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 a. 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