{-# 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_ 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 ManagerSettings
settings EndpointURL
url RequestP
updateReq BodyP
updateBody = do
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
settings
Transport -> IO Transport
forall a. a -> IO a
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 ManagerSettings
settings EndpointURL
url RequestProc
requestProc BodyProc
bodyProc = do
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
settings
Transport -> IO Transport
forall a. a -> IO a
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 :: Name -> Config -> IO Transport
confTransport Name
section Config
conf = ManagerSettings
-> Name -> Config -> RequestP -> BodyP -> IO Transport
confTransportWith ManagerSettings
defaultManagerSettings Name
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
-> Name -> Config -> RequestP -> BodyP -> IO Transport
confTransportWith ManagerSettings
settings Name
section Config
conf RequestP
brp BodyP
bbp = do
EndpointURL
url <- Config -> Name -> IO EndpointURL
forall a. Configured a => Config -> Name -> IO a
Conf.require Config
conf (Name
section Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
".url")
Bool
tracer <- Bool -> Config -> Name -> IO Bool
forall a. Configured a => a -> Config -> Name -> IO a
Conf.lookupDefault Bool
False Config
conf (Name
section Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
".trace")
let (RequestP
tr, 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 -> Name -> IO Int
forall a. Configured a => a -> Config -> Name -> IO a
Conf.lookupDefault Int
15 Config
conf (Name
section Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
".timeout")
#if MIN_VERSION_http_client(0,5,0)
let to :: RequestP
to Request
r = Request
r { responseTimeout = responseTimeoutMicro (timeout * 1000000) }
#else
let to r = r { responseTimeout = Just (timeout * 1000000) }
#endif
Maybe EndpointURL
encoding <- Config -> Name -> IO (Maybe EndpointURL)
forall a. Configured a => Config -> Name -> IO (Maybe a)
Conf.lookup Config
conf (Name
section Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
".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 EndpointURL
url RequestP
updateReq BodyP
updateBody =
Manager -> EndpointURL -> RequestProc -> BodyProc -> Transport
runQueryM Manager
manager EndpointURL
url (RequestProc
forall a. a -> IO a
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 a. a -> IO a
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 EndpointURL
url RequestProc
requestProc BodyProc
bodyProc EndpointURL
soapAction 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 = "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
}
Request -> Manager -> IO (Response ByteString)
httpLbs Request
request' Manager
manager IO (Response ByteString)
-> (Response ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
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 EndpointURL
src = Fuzzy -> EndpointURL -> EndpointURL -> BodyP
convertFuzzy Fuzzy
Transliterate EndpointURL
src EndpointURL
"UTF-8"
traceBody :: BodyP
traceBody :: BodyP
traceBody ByteString
lbs = EndpointURL -> BodyP
forall a. EndpointURL -> a -> a
trace EndpointURL
"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 ByteString
lbs = do
ByteString -> IO ()
BSL.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"response:" ByteString -> BodyP
forall a. Semigroup a => a -> a -> a
<> ByteString
lbs
BodyProc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
lbs
traceRequest :: RequestP
traceRequest :: RequestP
traceRequest Request
r = EndpointURL -> RequestP
forall a. EndpointURL -> a -> a
trace EndpointURL
"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 ByteString
body) = ByteString -> EndpointURL
unpack ByteString
body
showBody RequestBody
_ = EndpointURL
"<dynamic body>"
printRequest :: RequestProc
printRequest :: RequestProc
printRequest Request
req = do
ByteString -> IO ()
BSL.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"request:" ByteString -> BodyP
forall a. Semigroup a => a -> a -> a
<> RequestBody -> ByteString
bslBody (Request -> RequestBody
requestBody Request
req)
RequestProc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
where
bslBody :: RequestBody -> ByteString
bslBody (RequestBodyLBS ByteString
body) = ByteString
body
bslBody RequestBody
_ = ByteString
"<dynamic body>"
{-# DEPRECATED initTransportWith, RequestP, traceRequest, BodyP, traceBody, runQuery "Processors were lifted to IO." #-}