module Network.SOAP.Transport.HTTP.Conduit
(
initTransport, initTransport_
, EndpointURL
, RequestP, clientCert, traceRequest
, BodyP, iconv, traceBody
, runQuery
) where
import Text.XML
import Network.HTTP.Conduit
import Network.HTTP.Types(Status(..))
import Control.Monad.Trans.Resource
import Codec.Text.IConv (EncodingName, convertFuzzy, Fuzzy(Transliterate))
import qualified Network.TLS.Extra as TLS
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString, unpack, fromChunks)
import Debug.Trace (trace)
import Control.Exception as E
import Network.SOAP.Transport
import Network.SOAP.Exception
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
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)
]
}
res <- (runResourceT $ httpLbs (updateReq request') manager) `E.catch` handle500
return . updateBody . responseBody $ res
where
handle500 :: HttpException -> IO a
handle500 e@(StatusCodeException (Status 500 _) hs _) = handleSoapFault e hs
handle500 e = E.throw e
handleSoapFault e hs =
case lookup "X-Response-Body-Start" hs of
Nothing -> E.throw e
Just bs -> do
case parseLBS def $ fromChunks [bs] of
Left _ -> E.throw e
Right sfdoc -> case extractSoapFault sfdoc of
Nothing -> E.throw e
Just sf -> E.throw sf
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)] }