{-# LANGUAGE OverloadedStrings #-}
-- | Debug transport to train your parsers without bugging real services.

module Network.SOAP.Transport.Mock
    (
      initTransport
    , Handler, Handlers
    , handler, fault
    , runQuery
    ) where

import Network.SOAP.Transport

import Text.XML
import Text.XML.Writer
import Data.ByteString.Lazy.Char8 as LBS
import Data.Text (Text)

type Handler = Document -> IO LBS.ByteString
type Handlers = [(String, Handler)]

-- | Wrap a collection of handlers into a transport.
initTransport :: Handlers -> IO Transport
initTransport :: Handlers -> IO Transport
initTransport handlers :: Handlers
handlers = Transport -> IO Transport
forall (m :: * -> *) a. Monad m => a -> m a
return (Transport -> IO Transport) -> Transport -> IO Transport
forall a b. (a -> b) -> a -> b
$ Handlers -> Transport
runQuery Handlers
handlers

-- | Choose and apply a handler.
runQuery :: [(String, Handler)] -> Transport
runQuery :: Handlers -> Transport
runQuery handlers :: Handlers
handlers soapAction :: String
soapAction doc :: Document
doc = do
    case String -> Handlers -> Maybe Handler
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
soapAction Handlers
handlers of
        Nothing -> String -> IO ByteString
forall a. HasCallStack => String -> a
error (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ "No handler for action " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
soapAction
        Just h :: Handler
h -> Handler
h Document
doc

-- | Process a Document and wrap result in a SOAP Envelope.
handler :: (ToXML a) => (Document -> IO a) -> Handler
handler :: (Document -> IO a) -> Handler
handler h :: Document -> IO a
h doc :: Document
doc = do
    a
result <- Document -> IO a
h Document
doc
    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (a -> ByteString) -> a -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def
           (Document -> ByteString) -> (a -> Document) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> XML -> Document
document (Text -> Name
sname "Envelope")
           (XML -> Document) -> (a -> XML) -> a -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> XML -> XML
forall a. ToXML a => Name -> a -> XML
element (Text -> Name
sname "Body")
           (XML -> XML) -> (a -> XML) -> a -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> XML
forall a. ToXML a => a -> XML
toXML
           (a -> IO ByteString) -> a -> IO ByteString
forall a b. (a -> b) -> a -> b
$ a
result
    where
        sname :: Text -> Name
sname n :: Text
n = Text -> Maybe Text -> Maybe Text -> Name
Name Text
n (Text -> Maybe Text
forall a. a -> Maybe a
Just "http://schemas.xmlsoap.org/soap/envelope/") (Text -> Maybe Text
forall a. a -> Maybe a
Just "soapenv")

-- | Emulate a SOAP fault.
fault :: Text -- ^ SOAP Fault code (e.g. «soap:Server»)
      -> Text -- ^ Fault string
      -> Text -- ^ Fault detail
      -> Handler
fault :: Text -> Text -> Text -> Handler
fault c :: Text
c s :: Text
s d :: Text
d = (Document -> IO XML) -> Handler
forall a. ToXML a => (Document -> IO a) -> Handler
handler ((Document -> IO XML) -> Handler)
-> (XML -> Document -> IO XML) -> XML -> Handler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO XML -> Document -> IO XML
forall a b. a -> b -> a
const (IO XML -> Document -> IO XML)
-> (XML -> IO XML) -> XML -> Document -> IO XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> IO XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML -> Handler) -> XML -> Handler
forall a b. (a -> b) -> a -> b
$
    Name -> XML -> XML
forall a. ToXML a => Name -> a -> XML
element "Fault" (XML -> XML) -> XML -> XML
forall a b. (a -> b) -> a -> b
$ do
        Name -> Text -> XML
forall a. ToXML a => Name -> a -> XML
element "faultcode" Text
c
        Name -> Text -> XML
forall a. ToXML a => Name -> a -> XML
element "faultstring" Text
s
        Name -> Text -> XML
forall a. ToXML a => Name -> a -> XML
element "detail" Text
d