module Network.SOAP.Transport.HTTP.Conduit
(
initTransport, initTransport_, confTransport
, EndpointURL
, RequestP, clientCert, traceRequest
, BodyP, iconv, traceBody
, runQuery
) where
import Text.XML
import Network.HTTP.Conduit
import Control.Monad.Trans.Resource
import Data.Configurator (require, lookupDefault)
import Data.Configurator.Types (Config)
import Codec.Text.IConv (EncodingName, convertFuzzy, Fuzzy(Transliterate))
import qualified Network.TLS.Extra as TLS
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 (ResourceT IO) -> Request (ResourceT IO)
type BodyP = ByteString -> ByteString
type EndpointURL = String
initTransport :: EndpointURL
-> RequestP
-> BodyP
-> IO Transport
initTransport url updateReq updateBody = do
manager <- newManager def
return $! runQuery manager url updateReq updateBody
initTransport_ :: EndpointURL -> IO Transport
initTransport_ url = initTransport url id id
confTransport :: Text -> Config -> IO Transport
confTransport section conf = do
url <- require conf (section <> ".url")
cCert <- lookupDefault "" conf (section <> ".client_cert")
cKey <- lookupDefault "" conf (section <> ".client_key")
cc <- if null cCert
then return id
else clientCert cCert cKey
tracer <- lookupDefault False conf (section <> ".trace")
let (tr, tb) = if tracer
then (traceRequest, traceBody)
else (id, id)
timeout <- lookupDefault 15 conf (section <> ".timeout")
let to r = r { responseTimeout = Just (timeout * 1000000) }
initTransport url (to . tr . cc) tb
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 <- (runResourceT $ 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>"
clientCert :: FilePath
-> FilePath
-> IO RequestP
clientCert certPath keyPath = do
cert <- TLS.fileReadCertificate certPath
pkey <- TLS.fileReadPrivateKey keyPath
return $ \req -> req { clientCertificates = [(cert, Just pkey)] }