{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
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 :: EndpointURL -> RequestP -> BodyP -> IO Transport
initTransport = ManagerSettings -> EndpointURL -> RequestP -> BodyP -> IO Transport
initTransportWith ManagerSettings
defaultManagerSettings
initTransport_ :: EndpointURL -> IO Transport
initTransport_ :: EndpointURL -> IO Transport
initTransport_ url :: 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 settings :: ManagerSettings
settings url :: EndpointURL
url updateReq :: RequestP
updateReq updateBody :: BodyP
updateBody = do
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
settings
Transport -> IO Transport
forall (m :: * -> *) a. Monad m => a -> m a
return (Transport -> IO Transport) -> Transport -> IO Transport
forall a b. (a -> b) -> a -> b
$! Manager -> EndpointURL -> RequestP -> BodyP -> Transport
runQuery Manager
manager EndpointURL
url RequestP
updateReq BodyP
updateBody
initTransportWithM :: ManagerSettings
-> EndpointURL
-> RequestProc
-> BodyProc
-> IO Transport
initTransportWithM :: ManagerSettings
-> EndpointURL -> RequestProc -> BodyProc -> IO Transport
initTransportWithM settings :: ManagerSettings
settings url :: EndpointURL
url requestProc :: RequestProc
requestProc bodyProc :: BodyProc
bodyProc = do
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
settings
Transport -> IO Transport
forall (m :: * -> *) a. Monad m => a -> m a
return (Transport -> IO Transport) -> Transport -> IO Transport
forall a b. (a -> b) -> a -> b
$! Manager -> EndpointURL -> RequestProc -> BodyProc -> Transport
runQueryM Manager
manager EndpointURL
url RequestProc
requestProc BodyProc
bodyProc
confTransport :: Text -> Config -> IO Transport
confTransport :: Text -> Config -> IO Transport
confTransport section :: Text
section conf :: Config
conf = ManagerSettings
-> Text -> Config -> RequestP -> BodyP -> IO Transport
confTransportWith ManagerSettings
defaultManagerSettings Text
section Config
conf RequestP
forall a. a -> a
id BodyP
forall a. a -> a
id
confTransportWith :: ManagerSettings
-> Text
-> Config
-> RequestP
-> BodyP
-> IO Transport
confTransportWith :: ManagerSettings
-> Text -> Config -> RequestP -> BodyP -> IO Transport
confTransportWith settings :: ManagerSettings
settings section :: Text
section conf :: Config
conf brp :: RequestP
brp bbp :: BodyP
bbp = do
EndpointURL
url <- Config -> Text -> IO EndpointURL
forall a. Configured a => Config -> Text -> IO a
Conf.require Config
conf (Text
section Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".url")
Bool
tracer <- Bool -> Config -> Text -> IO Bool
forall a. Configured a => a -> Config -> Text -> IO a
Conf.lookupDefault Bool
False Config
conf (Text
section Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".trace")
let (tr :: RequestP
tr, tb :: BodyP
tb) = if Bool
tracer
then (RequestP
traceRequest, BodyP
traceBody)
else (RequestP
forall a. a -> a
id, BodyP
forall a. a -> a
id)
Int
timeout <- Int -> Config -> Text -> IO Int
forall a. Configured a => a -> Config -> Text -> IO a
Conf.lookupDefault 15 Config
conf (Text
section Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".timeout")
#if MIN_VERSION_http_client(0,5,0)
let to :: RequestP
to r :: Request
r = Request
r { responseTimeout :: ResponseTimeout
responseTimeout = Int -> ResponseTimeout
responseTimeoutMicro (Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000) }
#else
let to r = r { responseTimeout = Just (timeout * 1000000) }
#endif
Maybe EndpointURL
encoding <- Config -> Text -> IO (Maybe EndpointURL)
forall a. Configured a => Config -> Text -> IO (Maybe a)
Conf.lookup Config
conf (Text
section Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".encoding")
let ic :: BodyP
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
ManagerSettings -> EndpointURL -> RequestP -> BodyP -> IO Transport
initTransportWith ManagerSettings
settings EndpointURL
url (RequestP
to RequestP -> RequestP -> RequestP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestP
tr RequestP -> RequestP -> RequestP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestP
brp) (BodyP
tb BodyP -> BodyP -> BodyP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyP
ic BodyP -> BodyP -> BodyP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyP
bbp)
runQuery :: Manager
-> EndpointURL
-> RequestP
-> BodyP
-> Transport
runQuery :: Manager -> EndpointURL -> RequestP -> BodyP -> Transport
runQuery manager :: Manager
manager url :: EndpointURL
url updateReq :: RequestP
updateReq updateBody :: BodyP
updateBody =
Manager -> EndpointURL -> RequestProc -> BodyProc -> Transport
runQueryM Manager
manager EndpointURL
url (RequestProc
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 (f :: * -> *) a. Applicative f => a -> f a
pure BodyProc -> BodyP -> BodyProc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BodyP
updateBody)
runQueryM :: Manager
-> EndpointURL
-> RequestProc
-> BodyProc
-> Transport
runQueryM :: Manager -> EndpointURL -> RequestProc -> BodyProc -> Transport
runQueryM manager :: Manager
manager url :: EndpointURL
url requestProc :: RequestProc
requestProc bodyProc :: BodyProc
bodyProc soapAction :: EndpointURL
soapAction doc :: 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
request <- EndpointURL -> IO Request
forall (m :: * -> *). MonadThrow m => EndpointURL -> m Request
parseRequest EndpointURL
url
#else
request <- parseUrl url
#endif
Request
request' <- RequestProc
requestProc Request
request
{ method :: Method
method = "POST"
, requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body
, requestHeaders :: RequestHeaders
requestHeaders = [ ("Content-Type", "text/xml; charset=utf-8")
, ("SOAPAction", EndpointURL -> Method
BS.pack EndpointURL
soapAction)
]
#if MIN_VERSION_http_client(0,5,0)
, responseTimeout :: ResponseTimeout
responseTimeout = Int -> ResponseTimeout
responseTimeoutMicro 15000000
#else
, responseTimeout = Just 15000000
, checkStatus = \_ _ _ -> Nothing
#endif
}
Request -> Manager -> IO (Response ByteString)
httpLbs Request
request' Manager
manager IO (Response ByteString)
-> (Response ByteString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BodyProc
bodyProc BodyProc
-> (Response ByteString -> ByteString)
-> Response ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall body. Response body -> body
responseBody
iconv :: EncodingName -> BodyP
iconv :: EndpointURL -> BodyP
iconv src :: EndpointURL
src = Fuzzy -> EndpointURL -> EndpointURL -> BodyP
convertFuzzy Fuzzy
Transliterate EndpointURL
src "UTF-8"
traceBody :: BodyP
traceBody :: BodyP
traceBody lbs :: ByteString
lbs = EndpointURL -> BodyP
forall a. EndpointURL -> a -> a
trace "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 lbs :: ByteString
lbs = do
ByteString -> IO ()
BSL.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ "response:" ByteString -> BodyP
forall a. Semigroup a => a -> a -> a
<> ByteString
lbs
BodyProc
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
lbs
traceRequest :: RequestP
traceRequest :: RequestP
traceRequest r :: Request
r = EndpointURL -> RequestP
forall a. EndpointURL -> a -> a
trace "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 body :: ByteString
body) = ByteString -> EndpointURL
unpack ByteString
body
showBody _ = "<dynamic body>"
printRequest :: RequestProc
printRequest :: RequestProc
printRequest req :: Request
req = do
ByteString -> IO ()
BSL.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ "request:" ByteString -> BodyP
forall a. Semigroup a => a -> a -> a
<> RequestBody -> ByteString
bslBody (Request -> RequestBody
requestBody Request
req)
RequestProc
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
where
bslBody :: RequestBody -> ByteString
bslBody (RequestBodyLBS body :: ByteString
body) = ByteString
body
bslBody _ = "<dynamic body>"
{-# DEPRECATED initTransportWith, RequestP, traceRequest, BodyP, traceBody, runQuery "Processors were lifted to IO." #-}