{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.SOAP.Transport.HTTP
    (
      -- * Initialization
      initTransportWithM
    , EndpointURL
      -- * Making a request
    , RequestProc, printRequest
      -- * Processing a response
    , BodyProc, printBody
      -- * Raw transport function
    , runQueryM
      -- * Deprecated
    , 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

-- | Update request record after defaults and method-specific fields are set.
type RequestProc = Request -> IO Request

type RequestP = Request -> Request

-- | Process response body to make it a nice UTF8-encoded XML document.
type BodyProc = ByteString -> IO ByteString

type BodyP = ByteString -> ByteString

-- | Web service URL. Configured at initialization, but you can tweak it
--   dynamically with a request processor.
type EndpointURL = String

-- | Create a http-client transport. Use identity transformers if you
--   don't need any special treatment.
initTransport :: EndpointURL
              -> RequestP
              -> BodyP
              -> IO Transport
initTransport :: EndpointURL -> RequestP -> BodyP -> IO Transport
initTransport = ManagerSettings -> EndpointURL -> RequestP -> BodyP -> IO Transport
initTransportWith ManagerSettings
defaultManagerSettings

-- | Create a transport without any request and body processing.
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

-- | Create a http-client transport using manager settings (for plugging tls etc.).
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

-- | Load common transport parameters from a configurator file.
--
-- > soap {
-- >   url = "https://vendor.tld/service/"
-- >   trace = true
-- >   timeout = 15
-- > }
--
-- Only url field is required.
--
-- > import Data.Configurator (load, Worth(Required))
-- > main = do
-- >     transport <- confTransport "soap" =<< load [Required "etc/example.conf"]

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

-- | A more extensible transport parameter loader.
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)

-- | Render document, submit it as a POST request and retrieve a body.
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

-- * Some common processors.

-- | Create an IConv-based processor.
iconv :: EncodingName -> BodyP
iconv :: EndpointURL -> BodyP
iconv src :: EndpointURL
src = Fuzzy -> EndpointURL -> EndpointURL -> BodyP
convertFuzzy Fuzzy
Transliterate EndpointURL
src "UTF-8"

-- | Show a debug dump of a response body.
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

-- | Show a debug dump of a request body.
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." #-}