    {-# LANGUAGE CPP #-}
    {-# LANGUAGE OverloadedStrings #-}

    module Network.SOAP.Transport.HTTP
        (
          -- * Initialization
          initTransportWithM
        , EndpointURL
          -- * Making a request
        , RequestProc, printRequest
          -- * Processing a response
        , BodyProc, printBody
          -- * Raw transport function
        , runQueryM
          -- * Deprecated
        , initTransport, initTransport_, initTransportWith
        , confTransport, confTransportWith
        , RequestP, traceRequest
        , BodyP, iconv, traceBody
        , runQuery
        ) where

    import Text.XML
    import Network.HTTP.Client

    import qualified Data.Configurator as Conf
    import           Data.Configurator.Types (Config)
    import           Codec.Text.IConv (EncodingName, convertFuzzy, Fuzzy(Transliterate))

    import           Data.Text (Text)
    import qualified Data.ByteString.Char8 as BS
    import qualified Data.ByteString.Lazy.Char8 as BSL
    import           Data.ByteString.Lazy.Char8 (ByteString, unpack)

    import Control.Applicative
    import Debug.Trace (trace)
    import Data.Monoid ((<>))
    import Prelude

    import Network.SOAP.Transport

    -- | Update request record after defaults and method-specific fields are set.
    type RequestProc = Request -> IO Request

    type RequestP = Request -> Request

    -- | Process response body to make it a nice UTF8-encoded XML document.
    type BodyProc = ByteString -> IO ByteString

    type BodyP = ByteString -> ByteString

    -- | Web service URL. Configured at initialization, but you can tweak it
    --   dynamically with a request processor.
    type EndpointURL = String

    -- | Create a http-client transport. Use identity transformers if you
    --   don't need any special treatment.
    initTransport :: EndpointURL
                  -> RequestP
                  -> BodyP
                  -> IO Transport
    initTransport :: EndpointURL -> RequestP -> BodyP -> IO Transport
    initTransport = ManagerSettings -> EndpointURL -> RequestP -> BodyP -> IO Transport
    initTransportWith ManagerSettings
    defaultManagerSettings

    -- | Create a transport without any request and body processing.
    initTransport_ :: EndpointURL -> IO Transport
    initTransport_ :: EndpointURL -> IO Transport
    initTransport_ EndpointURL
    url = EndpointURL -> RequestP -> BodyP -> IO Transport
    initTransport EndpointURL
    url RequestP
    forall a. a -> a
    id BodyP
    forall a. a -> a
    id

    initTransportWith :: ManagerSettings
                      -> EndpointURL
                      -> RequestP
                      -> BodyP
                      -> IO Transport
    initTransportWith :: ManagerSettings -> EndpointURL -> RequestP -> BodyP -> IO Transport
    initTransportWith ManagerSettings
    settings EndpointURL
    url RequestP
    updateReq BodyP
    updateBody = do
        manager <- ManagerSettings -> IO Manager
    newManager ManagerSettings
    settings
        return $! runQuery manager url updateReq updateBody

    -- | Create a http-client transport using manager settings (for plugging tls etc.).
    initTransportWithM :: ManagerSettings
                       -> EndpointURL
                       -> RequestProc
                       -> BodyProc
                       -> IO Transport
    initTransportWithM :: ManagerSettings
    -> EndpointURL -> RequestProc -> BodyProc -> IO Transport
    initTransportWithM ManagerSettings
    settings EndpointURL
    url RequestProc
    requestProc BodyProc
    bodyProc = do
        manager <- ManagerSettings -> IO Manager
    newManager ManagerSettings
    settings
        return $! runQueryM manager url requestProc bodyProc

    -- | Load common transport parameters from a configurator file.
    --
    -- > soap {
    -- >   url = "https://vendor.tld/service/"
    -- >   trace = true
    -- >   timeout = 15
    -- > }
    --
    -- Only url field is required.
    --
    -- > import Data.Configurator (load, Worth(Required))
    -- > main = do
    -- >     transport <- confTransport "soap" =<< load [Required "etc/example.conf"]

    confTransport :: Text -> Config -> IO Transport
    confTransport :: Name -> Config -> IO Transport
    confTransport Name
    section Config
    conf = ManagerSettings
    -> Name -> Config -> RequestP -> BodyP -> IO Transport
    confTransportWith ManagerSettings
    defaultManagerSettings Name
    section Config
    conf RequestP
    forall a. a -> a
    id BodyP
    forall a. a -> a
    id

    -- | A more extensible transport parameter loader.
    confTransportWith :: ManagerSettings
                      -> Text
                      -> Config
                      -> RequestP
                      -> BodyP
                      -> IO Transport
    confTransportWith :: ManagerSettings
    -> Name -> Config -> RequestP -> BodyP -> IO Transport
    confTransportWith ManagerSettings
    settings Name
    section Config
    conf RequestP
    brp BodyP
    bbp = do
        url <- Config -> Name -> IO EndpointURL
    forall a. Configured a => Config -> Name -> IO a
    Conf.require Config
    conf (Name
    section Name -> Name -> Name
    forall a. Semigroup a => a -> a -> a
    <> Name
    ".url")

        tracer <- Conf.lookupDefault False conf (section <> ".trace")
        let (tr, tb) = if tracer
                           then (traceRequest, traceBody)
                           else (id, id)

        timeout <- Conf.lookupDefault 15 conf (section <> ".timeout")
    #if MIN_VERSION_http_client(0,5,0)
        let to Request
    r = Request
    r { responseTimeout = responseTimeoutMicro (timeout * 1000000) }
    #else
        let to r = r { responseTimeout = Just (timeout * 1000000) }
    #endif

        encoding <- Conf.lookup conf (section <> ".encoding")
        let ic = BodyP -> (EndpointURL -> BodyP) -> Maybe EndpointURL -> BodyP
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe BodyP
    forall a. a -> a
    id EndpointURL -> BodyP
    iconv Maybe EndpointURL
    encoding

        initTransportWith settings url (to . tr . brp) (tb . ic . bbp)

    runQuery :: Manager
             -> EndpointURL
             -> RequestP
             -> BodyP
             -> Transport
    runQuery :: Manager -> EndpointURL -> RequestP -> BodyP -> Transport
    runQuery Manager
    manager EndpointURL
    url RequestP
    updateReq BodyP
    updateBody =
        Manager -> EndpointURL -> RequestProc -> BodyProc -> Transport
    runQueryM Manager
    manager EndpointURL
    url (RequestProc
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure RequestProc -> RequestP -> RequestProc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RequestP
    updateReq) (BodyProc
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure BodyProc -> BodyP -> BodyProc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BodyP
    updateBody)

    -- | Render document, submit it as a POST request and retrieve a body.
    runQueryM :: Manager
              -> EndpointURL
              -> RequestProc
              -> BodyProc
              -> Transport
    runQueryM :: Manager -> EndpointURL -> RequestProc -> BodyProc -> Transport
    runQueryM Manager
    manager EndpointURL
    url RequestProc
    requestProc BodyProc
    bodyProc EndpointURL
    soapAction Document
    doc = do
        let body :: ByteString
    body = RenderSettings -> Document -> ByteString
    renderLBS RenderSettings
    forall a. Default a => a
    def (Document -> ByteString) -> Document -> ByteString
    forall a b. (a -> b) -> a -> b
    $! Document
    doc
    #if MIN_VERSION_http_client(0,4,30)
        request <- EndpointURL -> IO Request
    forall (m :: * -> *). MonadThrow m => EndpointURL -> m Request
    parseRequest EndpointURL
    url
    #else
        request <- parseUrl url
    #endif
        request' <- requestProc request
            { method          = "POST"
            , requestBody     = RequestBodyLBS body
            , requestHeaders  = [ ("Content-Type", "text/xml; charset=utf-8")
                                , ("SOAPAction", BS.pack soapAction)
                                ]
    #if MIN_VERSION_http_client(0,5,0)
            , responseTimeout = responseTimeoutMicro 15000000
    #else
            , responseTimeout = Just 15000000
            , checkStatus = \_ _ _ -> Nothing
    #endif
            }

        httpLbs request' manager >>= bodyProc . responseBody

    -- * Some common processors.

    -- | Create an IConv-based processor.
    iconv :: EncodingName -> BodyP
    iconv :: EndpointURL -> BodyP
    iconv EndpointURL
    src = Fuzzy -> EndpointURL -> EndpointURL -> BodyP
    convertFuzzy Fuzzy
    Transliterate EndpointURL
    src EndpointURL
    "UTF-8"

    -- | Show a debug dump of a response body.
    traceBody :: BodyP
    traceBody :: BodyP
    traceBody ByteString
    lbs = EndpointURL -> BodyP
    forall a. EndpointURL -> a -> a
    trace EndpointURL
    "response:" BodyP -> BodyP
    forall a b. (a -> b) -> a -> b
    $ EndpointURL -> BodyP
    forall a. EndpointURL -> a -> a
    trace (ByteString -> EndpointURL
    unpack ByteString
    lbs) ByteString
    lbs

    printBody :: BodyProc
    printBody :: BodyProc
    printBody ByteString
    lbs = do
        ByteString -> IO ()
    BSL.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ByteString
    "response:" ByteString -> BodyP
    forall a. Semigroup a => a -> a -> a
    <> ByteString
    lbs
        BodyProc
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ByteString
    lbs

    -- | Show a debug dump of a request body.
    traceRequest :: RequestP
    traceRequest :: RequestP
    traceRequest Request
    r = EndpointURL -> RequestP
    forall a. EndpointURL -> a -> a
    trace EndpointURL
    "request:" RequestP -> RequestP
    forall a b. (a -> b) -> a -> b
    $ EndpointURL -> RequestP
    forall a. EndpointURL -> a -> a
    trace (RequestBody -> EndpointURL
    showBody (RequestBody -> EndpointURL) -> RequestBody -> EndpointURL
    forall a b. (a -> b) -> a -> b
    $ Request -> RequestBody
    requestBody Request
    r) Request
    r
        where
            showBody :: RequestBody -> EndpointURL
    showBody (RequestBodyLBS ByteString
    body) = ByteString -> EndpointURL
    unpack ByteString
    body
            showBody RequestBody
    _ = EndpointURL
    "<dynamic body>"

    printRequest :: RequestProc
    printRequest :: RequestProc
    printRequest Request
    req = do
        ByteString -> IO ()
    BSL.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ByteString
    "request:" ByteString -> BodyP
    forall a. Semigroup a => a -> a -> a
    <> RequestBody -> ByteString
    bslBody (Request -> RequestBody
    requestBody Request
    req)
        RequestProc
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Request
    req
        where
            bslBody :: RequestBody -> ByteString
    bslBody (RequestBodyLBS ByteString
    body) = ByteString
    body
            bslBody RequestBody
    _ = ByteString
    "<dynamic body>"

    {-# DEPRECATED initTransportWith, RequestP, traceRequest, BodyP, traceBody, runQuery "Processors were lifted to IO." #-}