module Network.SOAP.Transport.HTTP
(
initTransport, initTransport_, initTransportWith
, confTransport, confTransportWith
, EndpointURL
, 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 Data.ByteString.Lazy.Char8 (ByteString, unpack)
import Debug.Trace (trace)
import Data.Monoid ((<>))
import Network.SOAP.Transport
type RequestP = Request -> Request
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
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")
let to r = r { responseTimeout = Just (timeout * 1000000) }
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 soapAction doc = do
let body = renderLBS def $! doc
request <- parseUrl url
let request' = request { method = "POST"
, responseTimeout = Just 15000000
, requestBody = RequestBodyLBS body
, requestHeaders = [ ("Content-Type", "text/xml; charset=utf-8")
, ("SOAPAction", BS.pack soapAction)
]
, checkStatus = \_ _ _ -> Nothing
}
res <- httpLbs (updateReq request') manager
return . updateBody . responseBody $ res
iconv :: EncodingName -> BodyP
iconv src = convertFuzzy Transliterate src "UTF-8"
traceBody :: BodyP
traceBody lbs = trace "response:" $ trace (unpack lbs) lbs
traceRequest :: RequestP
traceRequest r = trace "request:" $ trace (showBody $ requestBody r) r
where
showBody (RequestBodyLBS body) = unpack body
showBody _ = "<dynamic body>"