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