module Network.SOAP.Transport.HTTP
(
initTransportWithM
, EndpointURL
, RequestProc, printRequest
, BodyProc, printBody
, runQueryM
, 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
type RequestProc = Request -> IO Request
type RequestP = Request -> Request
type BodyProc = ByteString -> IO ByteString
type BodyP = ByteString -> ByteString
type EndpointURL = String
initTransport :: EndpointURL
-> RequestP
-> BodyP
-> IO Transport
initTransport = initTransportWith defaultManagerSettings
initTransport_ :: EndpointURL -> IO Transport
initTransport_ url = initTransport url id id
initTransportWith :: ManagerSettings
-> EndpointURL
-> RequestP
-> BodyP
-> IO Transport
initTransportWith settings url updateReq updateBody = do
manager <- newManager settings
return $! runQuery manager url updateReq updateBody
initTransportWithM :: ManagerSettings
-> EndpointURL
-> RequestProc
-> BodyProc
-> IO Transport
initTransportWithM settings url requestProc bodyProc = do
manager <- newManager settings
return $! runQueryM manager url requestProc bodyProc
confTransport :: Text -> Config -> IO Transport
confTransport section conf = confTransportWith defaultManagerSettings section conf id id
confTransportWith :: ManagerSettings
-> Text
-> Config
-> RequestP
-> BodyP
-> IO Transport
confTransportWith settings section conf brp bbp = do
url <- Conf.require conf (section <> ".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 r = r { responseTimeout = responseTimeoutMicro (timeout * 1000000) }
#else
let to r = r { responseTimeout = Just (timeout * 1000000) }
#endif
encoding <- Conf.lookup conf (section <> ".encoding")
let ic = maybe id iconv encoding
initTransportWith settings url (to . tr . brp) (tb . ic . bbp)
runQuery :: Manager
-> EndpointURL
-> RequestP
-> BodyP
-> Transport
runQuery manager url updateReq updateBody =
runQueryM manager url (pure . updateReq) (pure . updateBody)
runQueryM :: Manager
-> EndpointURL
-> RequestProc
-> BodyProc
-> Transport
runQueryM manager url requestProc bodyProc soapAction doc = do
let body = renderLBS def $! doc
#if MIN_VERSION_http_client(0,4,3)
request <- parseRequest 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
iconv :: EncodingName -> BodyP
iconv src = convertFuzzy Transliterate src "UTF-8"
traceBody :: BodyP
traceBody lbs = trace "response:" $ trace (unpack lbs) lbs
printBody :: BodyProc
printBody lbs = do
BSL.putStrLn $ "response:" <> lbs
pure lbs
traceRequest :: RequestP
traceRequest r = trace "request:" $ trace (showBody $ requestBody r) r
where
showBody (RequestBodyLBS body) = unpack body
showBody _ = "<dynamic body>"
printRequest :: RequestProc
printRequest req = do
BSL.putStrLn $ "request:" <> bslBody (requestBody req)
pure req
where
bslBody (RequestBodyLBS body) = body
bslBody _ = "<dynamic body>"