{-# 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_ 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

-- | 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 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

-- | 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 :: 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

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

-- | 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 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

-- * Some common processors.

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

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

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