    {-# 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 = Transport -> IO Transport
    forall a. a -> IO a
    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 String
    soapAction Document
    doc = do
        case String -> Handlers -> Maybe Handler
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    soapAction Handlers
    handlers of
            Maybe Handler
    Nothing -> String -> IO ByteString
    forall a. HasCallStack => String -> a
    error (String -> IO ByteString) -> String -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ String
    "No handler for action " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    soapAction
            Just Handler
    h -> Handler
    h Document
    doc

    -- | Process a Document and wrap result in a SOAP Envelope.
    handler :: (ToXML a) => (Document -> IO a) -> Handler
    handler :: forall a. ToXML a => (Document -> IO a) -> Handler
    handler Document -> IO a
    h Document
    doc = do
        result <- Document -> IO a
    h Document
    doc
        return . renderLBS def
               . document (sname "Envelope")
               . element (sname "Body")
               . toXML
               $ result
        where
            sname :: Text -> Name
    sname Text
    n = Text -> Maybe Text -> Maybe Text -> Name
    Name Text
    n (Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "http://schemas.xmlsoap.org/soap/envelope/") (Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "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 Text
    c Text
    s 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 a. a -> IO a
    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 Name
    "Fault" (XML -> XML) -> XML -> XML
    forall a b. (a -> b) -> a -> b
    $ do
            Name -> Text -> XML
    forall a. ToXML a => Name -> a -> XML
    element Name
    "faultcode" Text
    c
            Name -> Text -> XML
    forall a. ToXML a => Name -> a -> XML
    element Name
    "faultstring" Text
    s
            Name -> Text -> XML
    forall a. ToXML a => Name -> a -> XML
    element Name
    "detail" Text
    d